PowerPoint のスライド毎に画像を貼り付けていくマクロ
2007-01-27-1
数百枚ある写真を 1 枚 1 枚 PowerPoint に貼り付けていくという気の遠くなる作業を頼まれたので作成．
Option Explicit
Public Sub addPhotoParPage()
Dim i As Integer
Dim strPath As String
Dim objFileSystem As Object
Dim objFolder As Object
Dim objFile As Object
strPath = BrowseForFolder()
If strPath = "" Then
Exit Sub
End If
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFileSystem.GetFolder(strPath)
i = 0
For Each objFile In objFolder.Files
' スライドの追加
ActivePresentation.Slides.Add( _
Index:=ActivePresentation.Slides.Count + 1, _
Layout:=ppLayoutText).Select
' 画像の挿入
ActiveWindow.Selection.SlideRange.Shapes.AddPicture( _
FileName:=objFile.Path, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0).Select
' 50 回に一回 DoEvents 発生
i = i + 1
If i Mod 50 = 0 Then
DoEvents
End If
Next
Set objFile = Nothing
Set objFolder = Nothing
Set objFileSystem = Nothing
End Sub
Private Function BrowseForFolder(Optional varRoot As Variant) As String
Dim objFolder As Object
' フォルダ選択ダイアログを表示
Set objFolder = CreateObject("Shell.Application").BrowseForFolder( _
0, _
"画像があるフォルダを選択してください", _
&H11, _
varRoot)
' 選択内容を取得
If Not (objFolder Is Nothing) Then
BrowseForFolder = objFolder.Items.Item.Path
Else
BrowseForFolder = ""
End If
Set objFolder = Nothing
End Function
