目次
Background
I am writing a VBA program for PowerPoint. Previously, I was manually cropping and pasting .bmp images repeatedly using image editing software. I decided to automate this process to save time.
Specifications
When you run the program:
- A dialog box appears asking you to select a folder containing images.
- The program automatically pastes all
.bmpimages from that folder onto the active slide.
Code: Basic Version
Here is the initial code. It simply inserts the images.
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
' Create folder selection dialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
' Set dialog title
fDialog.Title = "Select a folder containing image files"
' Set initial folder to the current presentation path
If ActivePresentation.Path <> "" Then
fDialog.InitialFileName = ActivePresentation.Path
Else
fDialog.InitialFileName = "C:\"
End If
' Show dialog and check if user selected a folder
If fDialog.Show = -1 Then
' Get selected folder path
folderPath = fDialog.SelectedItems(1)
' Create FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
' Get active slide
Set slide = Application.ActiveWindow.View.Slide
' Initialize image position
leftPos = 50
topPos = 50
space = 20
' Check files in the selected folder
For Each file In fso.GetFolder(folderPath).Files
If LCase(fso.GetExtensionName(file.Name)) = "bmp" Then
' Paste image to slide
slide.Shapes.AddPicture FileName:=file.Path, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=leftPos, _
Top:=topPos, _
Width:=-1, _
Height:=-1
' Calculate next image position
topPos = topPos + space + 100 ' 100 is a temporary height. Adjust as needed.
' If it exceeds slide height, shift left and reset top position
If topPos > slide.Master.Height - 100 Then
topPos = 50
leftPos = leftPos + 100 + space ' 100 is a temporary width. Adjust as needed.
End If
End If
Next
Else
' If no folder is selected
MsgBox "No folder was selected."
End If
End Sub
Setting the Image Size
The original images were too large, so I added functionality to set a specific size. In this example, the size is set to 4cm x 4cm.
You can change the size using these variables:
' Set image size to 4cm x 4cm
widthCm = 4
heightCm = 4
Here is the updated code with resizing:
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
' Set image size to 4cm x 4cm
widthCm = 4
heightCm = 4
' Convert cm to points (1cm = 28.35 points)
widthPt = widthCm * 28.35
heightPt = heightCm * 28.35
' Create folder selection dialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
' Set dialog title
fDialog.Title = "Select a folder containing image files"
' Set initial folder to current presentation path
If ActivePresentation.Path <> "" Then
fDialog.InitialFileName = ActivePresentation.Path
Else
fDialog.InitialFileName = "C:\"
End If
' Show dialog and check if user selected a folder
If fDialog.Show = -1 Then
' Get selected folder path
folderPath = fDialog.SelectedItems(1)
' Create FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
' Get active slide
Set slide = Application.ActiveWindow.View.Slide
' Initialize image position
leftPos = 50
topPos = 50
space = 20
' Check files in the selected folder
For Each file In fso.GetFolder(folderPath).Files
If LCase(fso.GetExtensionName(file.Name)) = "bmp" Then
' Paste image to slide
slide.Shapes.AddPicture FileName:=file.Path, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=leftPos, _
Top:=topPos, _
Width:=widthPt, _
Height:=heightPt
' Calculate next image position
topPos = topPos + heightPt + space
' If it exceeds slide height, shift left and reset top position
If topPos > slide.Master.Height - heightPt Then
topPos = 50
leftPos = leftPos + widthPt + space
End If
End If
Next
Else
' If no folder is selected
MsgBox "No folder was selected."
End If
End Sub
Adding Filenames
It was difficult to identify the images just by looking at them, so I modified the code to extract and display the filename (without the extension) above each image.
Here is the final version:
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
' Set image size to 4cm x 4cm
widthCm = 4
heightCm = 4
' Convert cm to points (1cm = 28.35 points)
widthPt = widthCm * 28.35
heightPt = heightCm * 28.35
textHeight = 20 ' Height of the text box
' Create folder selection dialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
' Set dialog title
fDialog.Title = "Select a folder containing image files"
' Set initial folder to current presentation path
If ActivePresentation.Path <> "" Then
fDialog.InitialFileName = ActivePresentation.Path
Else
fDialog.InitialFileName = "C:\"
End If
' Show dialog and check if user selected a folder
If fDialog.Show = -1 Then
' Get selected folder path
folderPath = fDialog.SelectedItems(1)
' Create FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
' Get active slide
Set slide = Application.ActiveWindow.View.Slide
' Initialize image position
leftPos = 50
topPos = 50 + textHeight ' Lower initial position for the text box
space = 20
' Check files in the selected folder
For Each file In fso.GetFolder(folderPath).Files
If LCase(fso.GetExtensionName(file.Name)) = "bmp" Then
' Paste image to slide
Dim pic As shape
Set pic = slide.Shapes.AddPicture(FileName:=file.Path, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=leftPos, _
Top:=topPos, _
Width:=widthPt, _
Height:=heightPt)
' Get filename without extension
Dim fileNameWithoutExt As String
fileNameWithoutExt = fso.GetBaseName(file.Name)
' Add text box above the image
Dim textBox As shape
Set textBox = slide.Shapes.AddTextbox(msoTextOrientationHorizontal, _
leftPos, _
topPos - textHeight - 5, _
widthPt, _
textHeight)
textBox.TextFrame.TextRange.Text = fileNameWithoutExt
' Calculate next image position
topPos = topPos + heightPt + space
' If it exceeds slide height, shift left and reset top position
If topPos > slide.Master.Height - heightPt Then
topPos = 50 + textHeight ' Reset to position with text box offset
leftPos = leftPos + widthPt + space
End If
End If
Next
Else
' If no folder is selected
MsgBox "No folder was selected."
End If
End Sub
I hope this code helps you automate your PowerPoint tasks.
