Insert Picture w/ Filename as Caption - Add Resize and Correcting Image Order
Below is a macro I found that I recently started using. As I use it more, I've been refining/adding to it to suit my application. A few functional adds I would like but cannot figure out:
- Major issue is that it does not always pull filenames in ascending order. Sometimes it does, sometimes the order is seemingly random. I cannot figure out a pattern for it. Would love if the code can be modified such that images are pulled in ascending filename order.
- Change image size for each picture as it is being inserted. Width = 4.33 inches; Height = 3.25 inches
- Format text = Black at the start of the macro
Code:
Sub PicWithCaption() Dim xFileDialog As FileDialog
Dim xPath, xFile As Variant
On Error Resume Next
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDialog.Show = -1 Then
xPath = xFileDialog.SelectedItems.Item(1)
If xPath <> "" Then
xFile = Dir(xPath & "\*.*")
Do While xFile <> ""
If UCase(Right(xFile, 3)) = "PNG" Or _
UCase(Right(xFile, 3)) = "TIF" Or _
UCase(Right(xFile, 3)) = "JPG" Or _
UCase(Right(xFile, 3)) = "GIF" Or _
UCase(Right(xFile, 3)) = "BMP" Then
With Selection
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.InlineShapes.AddPicture xPath & "\" & xFile, False, True
.InsertAfter vbCrLf
.MoveDown wdLine
.Text = xFile & Chr(10)
.MoveDown wdLine
.TypeParagraph
.TypeParagraph
End With
End If
xFile = Dir()
Loop
End If
End If
End Sub
Any help is appreciated! I have very little VBA experience, learning on the fly.
