#1
|
|||
|
|||
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 |
#2
|
|||
|
|||
The following works in O365:
Code:
Sub InsertMultipleImagesFixed() Dim fd As FileDialog Dim imgCount As Long Dim imgTable As Table Dim index As Long Dim img As InlineShape Dim imageLoc As Variant 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 End With If fd.Show = -1 Then imgCount = fd.SelectedItems.Count With ActiveDocument With .Content.Find .Replacement.ClearFormatting .Text = "TotalImageNumber" .Replacement.Text = imgCount .Execute Replace:=wdReplaceAll End With Set imgTable = .Tables.Add(Range:=.Characters.Last, NumRows:=imgCount, NumColumns:=2) End With 'apply table settings With imgTable .Borders.Enable = False .PreferredWidthType = wdPreferredWidthPercent .PreferredWidth = 100 .Rows.Alignment = wdAlignRowCenter .Columns(1).Width = 140 .Columns(2).Width = 400 End With 'loop through table adding images and text For index = 1 To imgCount With imgTable.Cell(index, 1).Range .ParagraphFormat.Alignment = wdAlignParagraphLeft With .Font .Size = 12 .Underline = wdUnderlineSingle End With .Text = "Photograph No. " & index & ":" .Characters(.Characters.Count - 1).Font.Underline = wdUnderlineNone .InsertParagraphAfter With .Paragraphs.Last.Range .Font.Underline = wdUnderlineNone With .ParagraphFormat .RightIndent = InchesToPoints(0.02) .SpaceBeforeAuto = False .SpaceAfterAuto = False End With End With End With With imgTable.Cell(index, 2).Range.ParagraphFormat .RightIndent = InchesToPoints(0.01) .Alignment = wdAlignParagraphLeft .SpaceBeforeAuto = False .SpaceAfterAuto = False End With 'insert image Set img = _ ActiveDocument.InlineShapes.AddPicture(FileName:=imageLoc & fd.SelectedItems(index), _ LinkToFile:=False, SaveWithDocument:=True, Range:=imgTable.Cell(index, 2).Range) 'resize image With img With .Fill .Visible = msoFalse .Solid .Transparency = 0 End With With .Line .Weight = 0.75 .Transparency = 0# .Visible = msoFalse End With .LockAspectRatio = msoTrue .Height = 288 .Width = 383.75 With .PictureFormat .Brightness = 0.5 .Contrast = 0.5 .ColorType = msoPictureAutomatic 'these should all be unnecessary ' .CropLeft = 0# ' .CropRight = 0# ' .CropTop = 0# End With End With Next index End If End Sub Last edited by Italophile; 11-28-2023 at 02:16 PM. Reason: Corrected underline |
#3
|
|||
|
|||
The macro you posted produces a very similar result to our prior macro, with the exception of a continuous underline below "Photograph No. X:" and a space between successive photos. Can those attributes be added?
Thank you for the prompt response! I'm truly impressed and appreciative. |
#4
|
|||
|
|||
Please see edited code for correction to underline.
How much "space between successive photos" should there be? |
#5
|
|||
|
|||
|
#6
|
|||
|
|||
There should be one space at 12 point font between the photos (I tried to upload an image for example but apparently it has to be reviewed by a moderator first).
Thank you for your continued help! |
#7
|
|||
|
|||
Is that simply for spacing, or to provide a paragraph to type into?
|
#8
|
|||
|
|||
just for spacing between the photos.
|
#9
|
|||
|
|||
The code below adds a 12 point space to the top of the cells from row 2 onwards.
Code:
Sub InsertMultipleImagesFixed() Dim fd As FileDialog Dim imgCount As Long Dim imgTable As Table Dim index As Long Dim img As InlineShape Dim imageLoc As Variant 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 End With If fd.Show = -1 Then imgCount = fd.SelectedItems.Count With ActiveDocument With .Content.Find .Replacement.ClearFormatting .Text = "TotalImageNumber" .Replacement.Text = imgCount .Execute Replace:=wdReplaceAll End With Set imgTable = .Tables.Add(Range:=.Characters.Last, NumRows:=imgCount, NumColumns:=2) End With 'apply table settings With imgTable .Borders.Enable = False .PreferredWidthType = wdPreferredWidthPercent .PreferredWidth = 100 .Rows.Alignment = wdAlignRowLeft .Columns(1).Width = 140 .Columns(2).Width = 400 End With 'loop through table adding images and text For index = 1 To imgCount With imgTable.Cell(index, 1).Range With .ParagraphFormat If index > 1 Then .SpaceBefore = 12 End With With .Font .Size = 12 .Underline = wdUnderlineSingle End With .Text = "Photograph No. " & index & ":" .Characters(.Characters.Count - 1).Font.Underline = wdUnderlineNone .InsertParagraphAfter With .Paragraphs.Last.Range .Font.Underline = wdUnderlineNone With .ParagraphFormat .RightIndent = InchesToPoints(0.02) .SpaceBefore = 0 'the following are likely unnecessary '.SpaceBeforeAuto = False '.SpaceAfterAuto = False End With End With End With With imgTable.Cell(index, 2).Range.ParagraphFormat .RightIndent = InchesToPoints(0.01) If index > 1 Then .SpaceBefore = 12 'the following are likely unnecessary '.SpaceBeforeAuto = False '.SpaceAfterAuto = False End With 'insert image Set img = _ ActiveDocument.InlineShapes.AddPicture(FileName:=imageLoc & fd.SelectedItems(index), _ LinkToFile:=False, SaveWithDocument:=True, Range:=imgTable.Cell(index, 2).Range) 'resize image With img With .Fill .Visible = msoFalse .Solid .Transparency = 0 End With With .Line .Weight = 0.75 .Transparency = 0# .Visible = msoFalse End With 'I suspect the above should simply be '.Fill.Visible = msoFalse '.Line.Visible = msoFalse .LockAspectRatio = msoTrue .Height = 288 .Width = 383.75 With .PictureFormat .Brightness = 0.5 .Contrast = 0.5 .ColorType = msoPictureAutomatic 'these should all be unnecessary ' .CropLeft = 0# ' .CropRight = 0# ' .CropTop = 0# End With End With Next index End If End Sub |
#10
|
|||
|
|||
Nearly perfect! The table cells are just not centered on the page (8.5x11" size).
Thank you for the continued help. |
#11
|
|||
|
|||
Just change the following line
Code:
.Rows.Alignment = wdAlignRowLeft Code:
.Rows.Alignment = wdAlignRowCenter |
#12
|
|||
|
|||
Excellent, it's perfect now. Thanks again for your help. I'm so very grateful.
|
#13
|
|||
|
|||
At the risk of being even more of a pain, is there a string of code I can add to the macro so that the caption text is left justified within the cell?
|
#14
|
|||
|
|||
Quote:
Code:
Set imgTable = .Tables.Add(Range:=.Characters.Last, NumRows:=imgCount, NumColumns:=2) Code:
.Paragraphs.Last.Range.ParagraphFormat.Alignment = wdAlignParagraphLeft Set imgTable = .Tables.Add(Range:=.Characters.Last, NumRows:=imgCount, NumColumns:=2) |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Batch applying a macro to remove Header and Footer using Batch Auto Addin | Edszx | Word VBA | 2 | 05-27-2019 11:16 PM |
VBA to insert an image and centralize it (code included) | puff | Word VBA | 5 | 01-17-2018 04:32 PM |
Single Image Selection / Shortcut Key (Mac Excel 2011) Troubleshooting | chendric3 | Excel Programming | 0 | 04-14-2017 11:04 AM |
VBA batch file to insert text at end of 50 files slow, 90% CPU usage | equalizer88 | Word VBA | 3 | 08-16-2015 04:56 PM |
how to batch update linked image files path? | stanleyhuang | Word | 3 | 09-11-2014 12:51 AM |