Powerpoint VBA epsファイルをパワーポイントに貼り付けるマクロ - インストールレスプログラミング( ´ー`)

今日は，4月に入って初めて空が明るいうちに帰れました。

家でも仕事もしているんですが，急ぎの仕事から本当に久しぶりに開放された気分。

新しい職場で，少しずつペースと要領をつかみ始めている気がします。

（ΦωΦ）

昨年度作ったPowerpoint VBAで作った原子模型やタイマーとかは，授業でちょこっと使うのにとても役に立っています。

熱運動も比較的早い段階で使いそうなので，

手直しをしておかないと。

科学と人間生活という科目が新設されてからずいぶん経つんですが，わたしはその科目を始めて担当できる状況になりました。

手探り状態ですが，楽しくやれそうな感じです。。

さて，問題は著作権。とにかく素材は限られています。

商用等の使用も可という素材が使い勝手はいいわけなので，そういうのも含めて日々自転車操業で教材作成に取り組みつつ，長期に困らないものを作ろうと，素材をひたすら探す。

教育上であれば無料で使えますという素材もまぁあるのでその手助けも得ながらですが，難しい時もあります。

ただ，今日は著作権者の方と電話でやり取りをして，ずいぶん楽になることがありました。

コミュニケーションは大事ですね。ほんと，痛感させられます。

今年度はなんとかなりそうな算段がつくほどの素材のあてが確保でき，気持ちも少し大きくなったとこでした。。。詳しく書くのはあまりよくないと思うので，

同じような境遇の方は，きちんと著作権者の方とお話をされると突破口があるかも，とだけ書かせていただきます。

さて，そんな中，

www.ac-illust.com

こちらのプレミアム会員に加入しました。どうも自分にとってメリットはありそうだという判断です。豊富なイラストがあり，eps形式とかで取れるものが多々。

イラストレーター形式のものもとても有用なんですが，イラストレーターで開いて立ち上げたりとちょっと面倒。epsで取れるのが楽です。

epsで取れると何が楽なのかといいますと，

パワーポイントに直接貼り付けれて，グループ化の分解から辿っていくと，パワーポイント等である程度いじれる状態まで分解できます。

色を変えたりとかが最低限できる。

頂点編集もできることが多いです。

なのでとてもありがたいんですね。ベクトルデータなので，拡大等にも便利です。

ただ，Windowsの標準機能でプレビューが見れないので，

パワーポイントにぺたぺた貼っていけば使いやすいよなーということで，

スライド１枚１枚にフォルダ内のepsファイルを貼り付ける，というマクロを作りました。

短いマクロですが，なかなか自分には便利です。

Option Explicit

Sub 画像挿入()
    Dim strFileName As String
    Dim SlideNo As Long
    strFileName = Dir(ActivePresentation.Path & "\", vbNormal)
    ' ファイルが見つからなくなるまで繰り返す
    Do While strFileName <> ""
        '各ファイルに行う作業----------------------
        If strFileName Like "*.eps" Then '<> ActivePresentation.Name Then
            
            SlideNo = ActivePresentation.Slides.Count
            ActivePresentation.Slides.Add SlideNo + 1, ppLayoutBlank
            
            Dim TargetSlide As Slide: Set TargetSlide = ActivePresentation.Slides(SlideNo + 1)
            
            TargetSlide.Shapes.AddPicture ActivePresentation.Path & "\" & strFileName, msoFalse, msoTrue, 0, 50
            
            With TargetSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 200, 50)
                .TextFrame.TextRange.Text = strFileName
            End With
            
        End If
        '-------------------------------------------
        ' 次のファイル名を取得
        strFileName = Dir()
    Loop
End Sub