【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

こんな感じです。

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

ここまで読んでいただきありがとうございました。

スクールの紹介

最後に宣伝をさせてください。

技術で未来を切り拓く―あなたの夢を現実にするプログラミングスクール

Webデザインやプログラミングで成功を目指している方々にとって、このオンラインスクールは夢を叶えるための最適な場所です。皆さんのキャリアを次の段階へと引き上げるためにデザインされたこのスクールは、一人ひとりの成功を心から願い、それを実現するための全てを提供しています。ここでは、このスクールの魅力について詳しくご紹介します。

◆圧倒的な費用対効果
このオンラインプログラミングスクールは、Web系教育において最高の費用対効果を提供しています。多くの高額スクールが存在する中で、ここではリーズナブルな価格で、質の高い教材、無限のサポート、そして実際に市場で求められるスキルの習得機会を提供しています。

◆現役フリーランスの講師陣
講師たちは全員、現役のフリーランスプロフェッショナルです。市場で活躍している講師から直接、最新のトレンドや実践的なスキルを学べるのは、このスクールの大きな特徴です。

◆柔軟な学習コース
固定のコースがなく、学習者の興味やニーズに応じて自由に学習できます。進路変更も自由で、最低契約期間は1ヶ月という柔軟性を持っています。自分のペースで、自分に合った学習が可能です。

◆無制限の添削とサポート
理解できるまで、そして満足するまで、無制限に添削と質問への回答を提供しています。進路相談や技術面以外の相談にも対応しており、全面的にサポートします。

◆社長から学べる貴重な機会
デザイナー、プログラマー、ディレクター、マーケターとして豊富な経験を持つ社長から直接学べるのも、このスクールの特別な点です。他のスクールでは得られない、貴重な機会です。

◆実績作りへの徹底的なサポート
就職、転職、フリーランスとして成功するためには、高品質な実績が必要です。生徒の作品レベルを最大限に高め、市場で求められる実績を作り上げることに力を入れています。案件を取得できない生徒には、直接案件を提供することもあります。

◆メッセージからの約束
高額な授業料を支払わせて結果を出せないスクールとは違い、物理的なサポートは提供できないかもしれませんが、継続的な努力を通じて最高の結果を出せるようにサポートします。一緒に不正なスクールを撲滅し、あなたの夢を実現しましょう。

このプログラミングスクールは、Webデザインやプログラミングでの成功を目指す方々に必要な全てを備えています。今こそ、このコミュニティに参加し、あなたのキャリアを加速させる時です。

詳しくはこちら↓