Insert Batch Image Code - VBA / MS 365 Troubleshooting
Hi all
My engineering firm uses a VBA code to insert a batch of JPG images from a folder into a captioned table in a Word file as a report template. Recently we "upgraded" to Microsoft 365 and began having issues where the code would either not properly place the images into the table, or would produce run-time error 5941. Being semi-intelligent, I noticed that this issue coincided with the switch to MS 365 so I back-saved a report template file to Word 2003. Lo and behold, the macro worked properly. However, I would prefer to not have to use a workaround and would love for some of the experts here to help me properly solve this problem!
DISCLAIMER: I know nothing about VBA so treat me as a complete layperson. The code was created about 20 years ago by a programmer we had as an intern. Here is the current macro code:
Sub InsertMultipleImagesFixed()
Dim fd As FileDialog
Dim oTable As Table
Dim iRow As Integer
Dim iCol As Integer
Dim oCell As range
Dim i As Long
Dim sNoDoc As String
Dim picName As String
Dim scaleFactor As Long
Dim max_height As Single
Dim img As Picture
Dim docrange As range
'define resize constraints
max_height = 275
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png; *.wmf"
.FilterIndex = 2
If .Show = -1 Then
Set docrange = ActiveDocument.Content
With docrange.Find
.Replacement.ClearFormatting
.Text = "TotalImageNumber"
.Replacement.Text = fd.SelectedItems.Count
.Execute Replace:=wdReplaceAll
End With
For i = 1 To .SelectedItems.Count
Selection.EndKey Unit:=wdStory
'add a 1 row 2 column table to take the images
Set oTable = Selection.Tables.Add(Selection.range, 1, 2)
'+++++++++++++++++++++++++++++++++++++++++++++
iCol = 2
iRow = i
Selection.Tables(1).Borders.Enable = blnTblBorders
Selection.Tables(1).PreferredWidthType = wdPreferredWidthPercent
Selection.Tables(1).PreferredWidth = 100
Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
Selection.Tables(1).Columns(1).Width = 140
Selection.Tables(1).Columns(1).Select
ActiveDocument.ActiveWindow.Selection.ParagraphFor mat.Alignment = wdAlignParagraphLeft
Selection.Font.Size = 12
Selection.Font.Underline = wdUnderlineSingle
Selection.TypeText Text:="Photograph No. " & i
Selection.Font.Underline = wdUnderlineNone
Selection.TypeText Text:=":"
ActiveDocument.ActiveWindow.Selection.TypeParagrap h
ActiveDocument.ActiveWindow.Selection.ParagraphFor mat.RightIndent = InchesToPoints(0.02)
ActiveDocument.ActiveWindow.Selection.ParagraphFor mat.Alignment = wdAlignParagraphLeft
ActiveDocument.ActiveWindow.Selection.ParagraphFor mat.SpaceBeforeAuto = False
ActiveDocument.ActiveWindow.Selection.ParagraphFor mat.SpaceAfterAuto = False
Selection.Tables(1).Columns(2).Width = 400
Selection.Tables(1).Columns(2).Select
ActiveDocument.ActiveWindow.Selection.ParagraphFor mat.RightIndent = InchesToPoints(0.01)
ActiveDocument.ActiveWindow.Selection.ParagraphFor mat.Alignment = wdAlignParagraphLeft
ActiveDocument.ActiveWindow.Selection.ParagraphFor mat.SpaceBeforeAuto = False
ActiveDocument.ActiveWindow.Selection.ParagraphFor mat.SpaceAfterAuto = False
'insert image
Selection.InlineShapes.AddPicture FileName:=imageLoc & _
.SelectedItems(i), LinkToFile:=False, SaveWithDocument:=True
'resize image
ActiveDocument.InlineShapes(i + 1).Fill.Visible = msoFalse
ActiveDocument.InlineShapes(i + 1).Fill.Solid
ActiveDocument.InlineShapes(i + 1).Fill.Transparency = 0#
ActiveDocument.InlineShapes(i + 1).Line.Weight = 0.75
ActiveDocument.InlineShapes(i + 1).Line.Transparency = 0#
ActiveDocument.InlineShapes(i + 1).Line.Visible = msoFalse
ActiveDocument.InlineShapes(i + 1).LockAspectRatio = msoTrue
ActiveDocument.InlineShapes(i + 1).Height = 288
ActiveDocument.InlineShapes(i + 1).Width = 383.75
ActiveDocument.InlineShapes(i + 1).PictureFormat.Brightness = 0.5
ActiveDocument.InlineShapes(i + 1).PictureFormat.Contrast = 0.5
ActiveDocument.InlineShapes(i + 1).PictureFormat.ColorType = msoPictureAutomatic
ActiveDocument.InlineShapes(i + 1).PictureFormat.CropLeft = 0#
ActiveDocument.InlineShapes(i + 1).PictureFormat.CropRight = 0#
ActiveDocument.InlineShapes(i + 1).PictureFormat.CropTop = 0#
Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
Selection.WholeStory
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.TypeParagraph
Next i
End If
End With
End Sub
|