【PowerPointVBA】画像を挿入して整列
- [記事公開]2023.02.04
- VBA
- PowerPoint, VBA
PowerPointで画像を挿入して整列させるにはどうしたらよいかという質問がありましたので、ご紹介します。
質問
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q11274662571
Powerpointのマクロについて質問です。
研究の付図作成を効率化するために指定フォルダから複数画像を一括選択して整列したいと考えております。
①指定フォルダから現在選択しているスライドに対して複数画像を挿入
②jpgファイルだけ別サイズ,位置で配列.
③pngファイルはその下に別サイズ,位置(タイル状に)配列
を行いたいです。色々見てみましたがクリティカルなものはなく,うまいこと組もうにも無知がたたって組めません。
誰かお力添えをお願いしたいと考えております。
いくつか参考にしたwebサイトを張ります。 https://kawanouso.hatenablog.com/entry/2019/10/21/235758
https://www.ka-net.org/blog/?p=8228
http://color-chips.net/pencils/archives/2014/0805_220036.html
↓参考画像です。
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q11274662571

この質問を読んで、まず思ったのは、仕様が全然足りないことです。
この画像を見るとスライドが縦方向になっていますが、VBAの中でスライドが横長か縦長かは判断しなくてもよいのでしょうか・・・。
あと、JPEGファイルは1個だけなんでしょうか?
PNGファイルは順番があるのでしょうか。
・・・などと、分からないことだらけでしたが、適当に仕様を考えて作ってみました。
回答
まず、前提として
- スライドは縦長になっている
- JPEGファイルはフォルダの中に1個しか入っていない
- JPEGファイルはスライドに対して最初からちょうどよいサイズ感である(VBAの中でリサイズは必要ない)
- PNGファイルの順番はどうでもいい
- フォルダの中にサブフォルダはなく、直下に画像ファイルが入っている
ということにしました。
Option Explicit
Public Sub 複数画像を一括選択して整列()
'①指定フォルダから現在選択しているスライドに対して複数画像を挿入
Dim stPath As String
stPath = SelectFolderInBrowser("C:\")
'フォルダが選択されていなければ終了
If stPath = "" Then
Exit Sub
End If
'ファイルシステムオブジェクト群を生成
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim oFolder As Object
Set oFolder = FSO.GetFolder(stPath)
Dim f As Object
Dim Shp As Shape
'スライドのサイズ
Dim singleSlideWidth As Single '元ネタはInteger型にしていたけど、調べたらSingle型なので修正
singleSlideWidth = ActivePresentation.PageSetup.SlideWidth
Dim singleSlideHeight As Single 'Integer
singleSlideHeight = ActivePresentation.PageSetup.SlideHeight
'貼り付ける画像のサイズ
Dim iImageWidth As Single
Dim iImageHeight As Single
'画像データの横に並べる数
Const csingleClmCnt As Single = 2 'これはLong型でもInteger型でもよかったが、計算式で使うとき他の変数がすべてSingleなのでこれもSingle型に
'画像データ配置時の隙間指定
Const csingleMarginSlideEdge As Single = 25 '元ネタはDimとしていたけど使い方を見たらConstだったので変更
Const csingleMarginImage As Single = 5
'マージンの演算
Dim iMarginTotal As Single
iMarginTotal = csingleMarginSlideEdge * 2 + csingleMarginImage * (csingleClmCnt - 1)
'JPEG画像のサイズ
Dim singleJpegWidth As Single
Dim singleJpegHeight As Single
'JPEG画像の(最終的な)位置
Dim singleJpegLeft As Single
'フォルダ配下にJPEGファイルが1つとPNGファイルが複数入っているという前提
'②jpgファイルだけ別サイズ,位置で配列.
'最初にJPEGファイルを探す
For Each f In oFolder.Files
Select Case LCase(FSO.GetExtensionName(f.Path))
Case "jpg", "jpeg"
'画像を挿入
Set Shp = ActiveWindow.Selection.SlideRange.Shapes.AddPicture( _
FileName:=f.Path, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=10, _
Top:=10)
'↑いったんLeftとTopはいずれも10の位置にて挿入するけど
'このLeft:=10には全く意味がない(あとで位置調整するので)
'画像の縦横比は固定
Shp.LockAspectRatio = msoTrue
'JPEG画像のサイズを取得
singleJpegWidth = Shp.Width
singleJpegHeight = Shp.Height
'JPEG画像の位置を調整
Shp.Select
ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True '指定されたオブジェクトを左右中央揃えにします。
singleJpegLeft = Shp.Left
Exit For
End Select
Next f
Dim i As Long 'このiが重要な変数
i = 0
'③pngファイルはその下に別サイズ,位置(タイル状に)配列
'次にPNGファイルを探す
For Each f In oFolder.Files
Select Case LCase(FSO.GetExtensionName(f.Path))
Case "png"
'画像を挿入
Set Shp = ActiveWindow.Selection.SlideRange.Shapes.AddPicture( _
FileName:=f.Path, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0)
'↑いったんLeftとTopはいずれもゼロ位置にて挿入する
'けど、この位置指定は全く意味がない(後で位置調整するので)
'画像の縦横比は固定
Shp.LockAspectRatio = msoTrue
'1枚目の画像から、画像サイズ計算(フォルダ内PNG画像はすべて同じサイズとする)
If i = 0 Then
' iImageWidth = Fix((singleSlideWidth - iMarginTotal) / csingleClmCnt) 元ネタはスライドの幅を基準にしていたけど、今回質問者さんはJPEG画像の幅を基準にしたいようだったので変更
iImageWidth = Fix((singleJpegWidth - iMarginTotal) / csingleClmCnt)
Shp.Width = iImageWidth
iImageHeight = Shp.Height
End If
'画像サイズ・位置の指定
Shp.Width = iImageWidth
Shp.Height = iImageHeight
' Shp.Left = csingleMarginSlideEdge + Int(i Mod csingleClmCnt) * (iImageWidth + csingleMarginImage)元ネタはスライドの幅を基準にしていたけど、今回質問者さんはJPEG画像の左端を基準にしたいようだったので変更
Shp.Left = singleJpegLeft + Int(i Mod csingleClmCnt) * (iImageWidth + csingleMarginImage)
' Shp.Top = csingleMarginSlideEdge + Int(i / csingleClmCnt) * (iImageHeight + csingleMarginImage)元ネタはスライドの高さを基準にしていたけど、今回質問者さんはJPEG画像の後にPNGを並べたいので変更
Shp.Top = csingleMarginSlideEdge + Int(i / csingleClmCnt) * (iImageHeight + csingleMarginImage) + singleJpegHeight
'画像が多い場合、スライドの追加
If ((i + 1) Mod csingleClmCnt) = 0 And (Shp.Top + Shp.Height + csingleMarginImage + iImageHeight) > singleSlideHeight Then
ActivePresentation.Slides.Add( _
Index:=ActivePresentation.Slides.Count + 1, _
Layout:=ppLayoutBlank).Select
i = 0
'スライド追加時にDoEvents(定期的にWindowsへ(ユーザーへ)制御を戻すため)
DoEvents
Else
'10回に1度DoEvents(定期的にWindowsへ(ユーザーへ)制御を戻すため)
i = i + 1
If i Mod 10 = 0 Then
DoEvents
End If
End If
End Select
Next f
'終了処理
Set f = Nothing
Set oFolder = Nothing
Set FSO = Nothing
Set Shp = Nothing
End Sub
'フォルダ選択
Private Function SelectFolderInBrowser(Optional vRootFolder As Variant) As String
Dim oFolder As Object
Set oFolder = CreateObject("Shell.Application").BrowseForFolder( _
0, _
"画像フォルダ選択", _
&H211, _
vRootFolder)
'hwnd ダイアログ ボックスの親ウィンドウへのハンドル。 この値はゼロの場合があります。
'H001 ファイル システム ディレクトリのみを返します。 ユーザーがファイル システムの一部ではないフォルダーを選択すると、[ OK] ボタンが灰色表示されます。
'H010 ユーザーがアイテムの名前を入力できるようにする編集コントロールを参照ダイアログ ボックスに含めます。
'H200 [参照] ダイアログ ボックスに [新しいフォルダー] ボタンを含めないでください。
If Not (oFolder Is Nothing) Then
SelectFolderInBrowser = oFolder.Items.Item.Path
Else
SelectFolderInBrowser = ""
End If
Set oFolder = Nothing
End Function
コメントの中にちょいちょい出てくる「元ネタ」はこちらです↓
http://color-chips.net/pencils/archives/2014/0805_220036.html
質問者さんの質問の中にあったサイトです。
解説
元ネタのサイトのVBAを試すと、こんな風になりました。

一方、質問者さんがやりたいのはこんな風にすること↓です。

言い忘れましたが、私が今回用意したテスト環境はこちらです。

元ネタのコードの中に、JPEGを挿入するステップを追加し、JPEGの下にPNGを並べるという制御にすればよいと思いました。
元ネタでは変数をうまく使ってPNG画像をスライド幅にちょうどよく収まるように制御していましたので、それをそのまま流用することにしました。
あとはJPEGを質問者さんが希望する通りに入れてやればいいだけです。
コードの細かい解説は省略します。今回はコードの中のコメントに結構細かく書きました。
なお、元ネタでInteger型となっていた変数は全部Single型にしました。理由は、調べたらLeftとかTopとかHeightもWidthもみんなSingle型だったからです。また変数の命名の仕方も私の趣味で変えています。
-
前の記事
【ExcelVBA】突然始まる.(ドット)の意味【初心者向】 2023.02.03
-
次の記事
【ExcelVBA】VBAでFirefoxを使うには 2023.02.05