【PowerPoint】パワポに.bmpファイルの画像を貼りたい。【VBA】

経緯

PowerPointのVBAでプログラムを書いています。

.bmpの画像をいちいち切り取りソフトで画像を切り取りは貼ってを繰り返していたので、

これを自動化できないか、今回やってみました。

仕様

プログラムを走らせると、ダイアログが出てきて、画像が入っているフォルダを選びます。

すると、アクティブなスライドにフォルダに入っている画像が貼り付けられていくという仕様です。

コード

ではコードです。

Sub InsertAllBmpImages()
    Dim fDialog As FileDialog
    Dim folderPath As String
    Dim fso As Object
    Dim file As Object
    Dim slide As slide
    Dim leftPos As Single
    Dim topPos As Single
    Dim space As Single

    ' フォルダ選択ダイアログを作成
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    ' ダイアログのタイトルを設定
    fDialog.Title = "画像ファイルが含まれるフォルダーを選択してください"
    
    ' 初期フォルダーを現在のプレゼンテーションのパスに設定
    If ActivePresentation.Path <> "" Then
        fDialog.InitialFileName = ActivePresentation.Path
    Else
        fDialog.InitialFileName = "C:\"
    End If
    
    ' ダイアログを表示し、ユーザーがフォルダーを選択したかどうかを確認
    If fDialog.Show = -1 Then
        ' 選択されたフォルダーのパスを取得
        folderPath = fDialog.SelectedItems(1)
        
        ' ファイルシステムオブジェクトを作成
        Set fso = CreateObject("Scripting.FileSystemObject")
        
        ' アクティブなスライドを取得
        Set slide = Application.ActiveWindow.View.Slide
        
        ' 画像の配置位置を初期化
        leftPos = 50
        topPos = 50
        space = 20
        
        ' 選択されたフォルダー内のファイルを確認
        For Each file In fso.GetFolder(folderPath).Files
            If LCase(fso.GetExtensionName(file.Name)) = "bmp" Then
                ' 画像をスライドに貼り付け
                slide.Shapes.AddPicture FileName:=file.Path, _
                                        LinkToFile:=msoFalse, _
                                        SaveWithDocument:=msoTrue, _
                                        Left:=leftPos, _
                                        Top:=topPos, _
                                        Width:=-1, _
                                        Height:=-1
                                        
                ' 次の画像の位置を計算
                topPos = topPos + space + 100 ' 100は仮の画像高さ。実際の高さに合わせて調整。
                
                ' スライドの高さを超えた場合は左にシフトし、トップ位置を初期化
                If topPos > slide.Master.Height - 100 Then
                    topPos = 50
                    leftPos = leftPos + 100 + space ' 100は仮の画像幅。実際の幅に合わせて調整。
                End If
            End If
        Next
    Else
        ' フォルダーが選択されなかった場合
        MsgBox "フォルダーが選択されませんでした。"
    End If
End Sub

画像のサイズを決めたい。

画像のサイズが大きかったので、設定できるようにしました。

‘ 画像サイズを4cm x 4cmに設定
widthCm = 4
heightCm = 4
のところでサイズが変えられます。

Sub InsertAllBmpImages()
    Dim fDialog As FileDialog
    Dim folderPath As String
    Dim fso As Object
    Dim file As Object
    Dim slide As slide
    Dim leftPos As Single
    Dim topPos As Single
    Dim space As Single
    Dim widthCm As Single
    Dim heightCm As Single
    Dim widthPt As Single
    Dim heightPt As Single
    
    ' 画像サイズを4cm x 4cmに設定
    widthCm = 4
    heightCm = 4
    
    ' cmをポイントに変換 (1cm = 28.35ポイント)
    widthPt = widthCm * 28.35
    heightPt = heightCm * 28.35

    ' フォルダ選択ダイアログを作成
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    ' ダイアログのタイトルを設定
    fDialog.Title = "画像ファイルが含まれるフォルダーを選択してください"
    
    ' 初期フォルダーを現在のプレゼンテーションのパスに設定
    If ActivePresentation.Path <> "" Then
        fDialog.InitialFileName = ActivePresentation.Path
    Else
        fDialog.InitialFileName = "C:\"
    End If
    
    ' ダイアログを表示し、ユーザーがフォルダーを選択したかどうかを確認
    If fDialog.Show = -1 Then
        ' 選択されたフォルダーのパスを取得
        folderPath = fDialog.SelectedItems(1)
        
        ' ファイルシステムオブジェクトを作成
        Set fso = CreateObject("Scripting.FileSystemObject")
        
        ' アクティブなスライドを取得
        Set slide = Application.ActiveWindow.View.Slide
        
        ' 画像の配置位置を初期化
        leftPos = 50
        topPos = 50
        space = 20
        
        ' 選択されたフォルダー内のファイルを確認
        For Each file In fso.GetFolder(folderPath).Files
            If LCase(fso.GetExtensionName(file.Name)) = "bmp" Then
                ' 画像をスライドに貼り付け
                slide.Shapes.AddPicture FileName:=file.Path, _
                                        LinkToFile:=msoFalse, _
                                        SaveWithDocument:=msoTrue, _
                                        Left:=leftPos, _
                                        Top:=topPos, _
                                        Width:=widthPt, _
                                        Height:=heightPt
                                        
                ' 次の画像の位置を計算
                topPos = topPos + heightPt + space
                
                ' スライドの高さを超えた場合は左にシフトし、トップ位置を初期化
                If topPos > slide.Master.Height - heightPt Then
                    topPos = 50
                    leftPos = leftPos + widthPt + space
                End If
            End If
        Next
    Else
        ' フォルダーが選択されなかった場合
        MsgBox "フォルダーが選択されませんでした。"
    End If
End Sub

ファイル名も載せたい

どの画像がわからないので、ファイル名も抽出します。ファイル名の拡張子は表示してません。

Sub InsertAllBmpImagesWithText()
    Dim fDialog As FileDialog
    Dim folderPath As String
    Dim fso As Object
    Dim file As Object
    Dim slide As slide
    Dim leftPos As Single
    Dim topPos As Single
    Dim space As Single
    Dim widthCm As Single
    Dim heightCm As Single
    Dim widthPt As Single
    Dim heightPt As Single
    Dim textHeight As Single
    
    ' 画像サイズを4cm x 4cmに設定
    widthCm = 4
    heightCm = 4
    
    ' cmをポイントに変換 (1cm = 28.35ポイント)
    widthPt = widthCm * 28.35
    heightPt = heightCm * 28.35
    textHeight = 20 ' テキストボックスの高さ
    
    ' フォルダ選択ダイアログを作成
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    ' ダイアログのタイトルを設定
    fDialog.Title = "画像ファイルが含まれるフォルダーを選択してください"
    
    ' 初期フォルダーを現在のプレゼンテーションのパスに設定
    If ActivePresentation.Path <> "" Then
        fDialog.InitialFileName = ActivePresentation.Path
    Else
        fDialog.InitialFileName = "C:\"
    End If
    
    ' ダイアログを表示し、ユーザーがフォルダーを選択したかどうかを確認
    If fDialog.Show = -1 Then
        ' 選択されたフォルダーのパスを取得
        folderPath = fDialog.SelectedItems(1)
        
        ' ファイルシステムオブジェクトを作成
        Set fso = CreateObject("Scripting.FileSystemObject")
        
        ' アクティブなスライドを取得
        Set slide = Application.ActiveWindow.View.Slide
        
        ' 画像の配置位置を初期化
        leftPos = 50
        topPos = 50 + textHeight ' 最初の画像の位置をテキストボックス分下げる
        space = 20
        
        ' 選択されたフォルダー内のファイルを確認
        For Each file In fso.GetFolder(folderPath).Files
            If LCase(fso.GetExtensionName(file.Name)) = "bmp" Then
                ' 画像をスライドに貼り付け
                Dim pic As shape
                Set pic = slide.Shapes.AddPicture(FileName:=file.Path, _
                                                  LinkToFile:=msoFalse, _
                                                  SaveWithDocument:=msoTrue, _
                                                  Left:=leftPos, _
                                                  Top:=topPos, _
                                                  Width:=widthPt, _
                                                  Height:=heightPt)
                                                  
                ' ファイル名（拡張子なし）を取得
                Dim fileNameWithoutExt As String
                fileNameWithoutExt = fso.GetBaseName(file.Name)
                
                ' テキストボックスを画像の上に追加
                Dim textBox As shape
                Set textBox = slide.Shapes.AddTextbox(msoTextOrientationHorizontal, _
                                                      leftPos, _
                                                      topPos - textHeight - 5, _
                                                      widthPt, _
                                                      textHeight)
                textBox.TextFrame.TextRange.Text = fileNameWithoutExt
                
                ' 次の画像の位置を計算
                topPos = topPos + heightPt + space
                
                ' スライドの高さを超えた場合は左にシフトし、トップ位置を初期化
                If topPos > slide.Master.Height - heightPt Then
                    topPos = 50 + textHeight ' テキストボックス分下げた位置に初期化
                    leftPos = leftPos + widthPt + space
                End If
            End If
        Next
    Else
        ' フォルダーが選択されなかった場合
        MsgBox "フォルダーが選択されませんでした。"
    End If
End Sub

こんな感じです。

参考になれば、幸いです。

技術書の購入コストを抑えてスキルアップするなら

ここまで読んでいただきありがとうございます。最後に宣伝をさせてください。

プログラミングの技術書や参考書は、1冊3,000円〜5,000円するものも多く、出費がかさみがちです。Kindle Unlimitedであれば、月額980円で500万冊以上の書籍が読み放題となります。

気になる言語の入門書から、アルゴリズム、基本設計の専門書まで、手元のスマホやPCですぐに参照可能です。現在は「30日間の無料体験」や、対象者限定の「3か月499円プラン」なども実施されています。まずはご自身のアカウントでどのようなオファーが表示されるか確認してみてください。

[Kindle Unlimited 読み放題プランをチェックする]