Insert Batch Image Code

Rfuchs730 · #1 11-28-2023, 07:23 AM

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

Italophile · #2 11-28-2023, 09:42 AM

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

There are a number of lines of code, aside from those I have commented out, that I consider unnecessary. As I have no knowledge of why these lines were included I have left them in, although I suspect they were probably the product of the macro recorder and never did serve any useful purpose.

Rfuchs730 · #3 11-28-2023, 01:49 PM

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.

Italophile · #4 11-28-2023, 02:17 PM

Please see edited code for correction to underline.
How much "space between successive photos" should there be?

Rfuchs730 · #5 11-28-2023, 02:29 PM

There should be one space at 12 point font, as shown below for example

Rfuchs730 · #6 11-28-2023, 04:12 PM

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!

Italophile · #7 11-29-2023, 05:09 AM

Quote:

Originally Posted by Rfuchs730

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!

Is that simply for spacing, or to provide a paragraph to type into?

Rfuchs730 · #8 11-29-2023, 05:52 AM

just for spacing between the photos.

Italophile · #9 11-29-2023, 07:07 AM

Quote:

Originally Posted by Rfuchs730

just for spacing between the photos.

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

Rfuchs730 · #10 11-29-2023, 07:55 AM

Nearly perfect! The table cells are just not centered on the page (8.5x11" size).

Thank you for the continued help.

Italophile · #11 11-29-2023, 09:19 AM

Just change the following line

Code:

.Rows.Alignment = wdAlignRowLeft

To:

Code:

.Rows.Alignment = wdAlignRowCenter

Rfuchs730 · #12 11-29-2023, 10:19 AM

Excellent, it's perfect now. Thanks again for your help. I'm so very grateful.

Rfuchs730 · #13 11-29-2023, 11:31 AM

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?

Italophile · #14 11-29-2023, 12:58 PM

Quote:

Originally Posted by Rfuchs730

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?

Change:

Code:

            Set imgTable = .Tables.Add(Range:=.Characters.Last, NumRows:=imgCount, NumColumns:=2)

To:

Code:

            .Paragraphs.Last.Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
            Set imgTable = .Tables.Add(Range:=.Characters.Last, NumRows:=imgCount, NumColumns:=2)

This will ensure that the table contents are left aligned

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