I have a macro to auto insert pictures in a table. Need help with format though.

F

frewert

Board Regular
Joined
Apr 4, 2014
Messages
188
Office Version
  1. 365
Platform
  1. Windows
Code by Macropod

Code: 
Sub AddPics()
    Application.ScreenUpdating = False
    Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long
    Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single
    On Error GoTo ErrExit
    NumCols = CLng(InputBox("How Many Columns per Row?"))
    RwHght = CSng(InputBox("What row height for the pictures, in inches (e.g. 1.5)?"))
    On Error GoTo 0
     'Select and insert the Pics
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select image files and click OK"
        .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
        .FilterIndex = 2
        If .Show = -1 Then
             'Add a 2-row by NumCols-column table to take the images
            Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=2, NumColumns:=NumCols)
            With ActiveDocument.PageSetup
                TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
            End With
            With oTbl
                .AutoFitBehavior (wdAutoFitFixed)
                .Columns.Width = TblWdth / NumCols
            End With
            CaptionLabels.Add Name:="Picture"
            For i = 1 To .SelectedItems.Count Step NumCols
                r = ((i - 1) / NumCols + 1) * 2 - 1
                 'Format the rows
                Call FormatRows(oTbl, r, RwHght)
                For c = 1 To NumCols
                    j = j + 1
                     'Insert the Picture
                    ActiveDocument.InlineShapes.AddPicture _
                    FileName:=.SelectedItems(j), LinkToFile:=False, _
                    SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range
                     'Get the Image name for the Caption
                    StrTxt = Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\")))
                    StrTxt = ": " & Split(StrTxt, ".")(0)
                     'Insert the Caption on the row below the picture
                    With oTbl.Cell(r + 1, c).Range
                        .InsertBefore vbCr
                        .Characters.First.InsertCaption _
                        Label:="Picture", Title:=StrTxt, _
                        Position:=wdCaptionPositionBelow, ExcludeLabel:=False
                        .Characters.First = vbNullString
                        .Characters.Last.Previous = vbNullString
                    End With
                     'Exit when we're done
                    If j = .SelectedItems.Count Then Exit For
                Next
                 'Add extra rows as needed
                If j < .SelectedItems.Count Then
                    oTbl.Rows.Add
                    oTbl.Rows.Add
                End If
            Next
        Else
        End If
    End With
ErrExit:
    Application.ScreenUpdating = True
End Sub
 '
Sub FormatRows(oTbl As Table, x As Long, Hght As Single)
    With oTbl
        With .Rows(x)
            .Height = InchesToPoints(Hght)
            .HeightRule = wdRowHeightExactly
            .Range.Style = "Normal"
        End With
        With .Rows(x + 1)
            .Height = CentimetersToPoints(0.5)
            .HeightRule = wdRowHeightExactly
            .Range.Style = "Caption"
        End With
    End With
End Sub

As is, this puts unnecessary space between the caption and the image. I need to reduce this to nothing.
This might solve the issue where the text of row 1 captions are touching row 2 pictures.
Also, I would like make each caption say "Sample: [the image filename]"
Bonus, if you can make everything Left aligned instead of Center.
 
Sort by date Sort by votes
I manual adjust both to -0.5 for their Left Indent property.

Btw, thanks to your help I am exceeding productivity of all the people in the department!
 
Upvote 0

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
frewert said:
I manual adjust both to -0.5 for their Left Indent property.
Btw, thanks to your help I am exceeding productivity of all the people in the department!
Click to expand...
Glad I can help a bit in modifying of Macropod’s great code.

As to the .LeftIndent - it's still unclear why it is required at all?
See the result in the picture of this link where 3 columns and 2 inches height per each row were chosen via dialogs.
Grid of the table was added for the clear visual analyzing.
f_50914994017

As we can see:
1. Picture #1 Storm is placed in cell #1 and adjusted by the height because the picture’s height is bigger than its weight.
2. Picture #2 Fiolent1 is placed in cell #2 and has the weight equal to the height, thus this picture is completely adjusted into 2 inches square cell.
3. Picture #3 Fiolent is placed in cell #3 and adjusted by the weight because the picture’s weight is bigger than its height.
And so on, and all looks for me like what it was in your requests.

Could you please describe what shifting in each cell for the pictures #1, #2, #3 and for their captions are required and why?
 
Last edited:
Upvote 0
ZVI said:
Glad I can help a bit in modifying of Macropod’s great code.

As to the .LeftIndent - it's still unclear why it is required at all?
See the result in the picture of this link where 3 columns and 2 inches height per each row were chosen via dialogs.
Grid of the table was added for the clear visual analyzing.
f_50914994017

As we can see:
1. Picture #1 Storm is placed in cell #1 and adjusted by the height because the picture’s height is bigger than its weight.
2. Picture #2 Fiolent1 is placed in cell #2 and has the weight equal to the height, thus this picture is completely adjusted into 2 inches square cell.
3. Picture #3 Fiolent is placed in cell #3 and adjusted by the weight because the picture’s weight is bigger than its height.
And so on, and all looks for me like what it was in your requests.

Could you please describe what shifting in each cell for the pictures #1, #2, #3 and for their captions are required and why?
Click to expand...


This macro is being used in an already created form. This form has off center margins for some reason. So on a blank Excel document, these pictures are centered just fine. Except in this document because of the way the margins were set (its a returned goods form, controlled document) the macro puts the pictures over to the right.

The margin starts 1-1/4" from the left edge.
 
Last edited:
Upvote 0
Then I'd suggest left padding for all cells of the table with auto decreasing of each picture width by that padding.
Something like this:
Rich (BB code): 
Sub AddPics()
 
  Const LEFT_PADDING = 0.5 ' <-- in Centimeters, change to suit
 
  Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long
  Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single
  On Error GoTo ErrExit
  NumCols = CLng(InputBox("How Many Columns per Row?"))
  RwHght = CSng(InputBox("What row height for the pictures, in inches (e.g. 1.5)?"))
  On Error GoTo 0
  Application.ScreenUpdating = False
  'Select and insert the Pics
  With Application.FileDialog(msoFileDialogFilePicker)
    .InitialFileName = ThisDocument.Path & "\"
    .Title = "Select image files and click OK"
    .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
    .FilterIndex = 2
    If .Show = -1 Then
      'Add a 2-row by NumCols-column table to take the images
      Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=2, NumColumns:=NumCols)
      ' Set zero padding
      With oTbl
        .TopPadding = 0
        .BottomPadding = 0
        .LeftPadding = CentimetersToPoints(LEFT_PADDING)
        .RightPadding = 0
        .Spacing = 0
        .AllowPageBreaks = True
        .AllowAutoFit = False
      End With
      ' Set columns width
      With ActiveDocument.PageSetup
        TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
      End With
      With oTbl
        .AutoFitBehavior wdAutoFitFixed
        .Columns.Width = TblWdth / NumCols
      End With
      ' Main
      For i = 1 To .SelectedItems.Count Step NumCols
        r = ((i - 1) / NumCols + 1) * 2 - 1
        'Format the rows
        Call FormatRows(oTbl, r, RwHght)
        For c = 1 To NumCols
          j = j + 1
          'Insert the Picture
          With ActiveDocument.InlineShapes.AddPicture( _
              Filename:=.SelectedItems(j), LinkToFile:=False, _
              SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range)
              .LockAspectRatio = msoTrue
              .Height = oTbl.Cell(r, c).Height
              If .Width > oTbl.Cell(r, c).Width + CentimetersToPoints(LEFT_PADDING) Then
                .Width = oTbl.Cell(r, c).Width - CentimetersToPoints(LEFT_PADDING)
              End If
          End With
          'Get the Image name for the Caption
          StrTxt = Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\")))
          StrTxt = ": " & Split(StrTxt, ".")(0)
          'Insert the Caption onto the row below the picture
          oTbl.Cell(r + 1, c).Range.Characters.First.InsertAfter "Sample" & StrTxt
          'Exit when we're done
          If j = .SelectedItems.Count Then Exit For
        Next
        'Add extra rows as needed
        If j < .SelectedItems.Count Then
          oTbl.Rows.Add
          oTbl.Rows.Add
        End If
      Next
    End If
  End With
ErrExit:
  Application.ScreenUpdating = True
End_Sub
 
Sub FormatRows(oTbl As Table, x As Long, Hght As Single)
  With oTbl
    With .Rows(x)
      .Height = InchesToPoints(Hght)
      .HeightRule = wdRowHeightExactly
      .Range.Style = wdStyleNormal ' "Normal"
      .Cells.VerticalAlignment = wdCellAlignVerticalBottom
    End With
    With .Rows(x + 1)
      .Height = CentimetersToPoints(1)
      .HeightRule = wdRowHeightExactly
      .Range.Style = wdStyleCaption ' "Caption"
      .Cells.VerticalAlignment = wdCellAlignVerticalTop
    End With
  End With
End Sub
Change value of Const LEFT_PADDING to suit.
 
Upvote 0
ZVI said:
Then I'd suggest left padding for all cells of the table with auto decreasing of each picture width by that padding.
Something like this:
Rich (BB code): 
Sub AddPics()
 
  Const LEFT_PADDING = 0.5 ' <-- in Centimeters, change to suit
 
  Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long
  Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single
  On Error GoTo ErrExit
  NumCols = CLng(InputBox("How Many Columns per Row?"))
  RwHght = CSng(InputBox("What row height for the pictures, in inches (e.g. 1.5)?"))
  On Error GoTo 0
  Application.ScreenUpdating = False
  'Select and insert the Pics
  With Application.FileDialog(msoFileDialogFilePicker)
    .InitialFileName = ThisDocument.Path & "\"
    .Title = "Select image files and click OK"
    .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
    .FilterIndex = 2
    If .Show = -1 Then
      'Add a 2-row by NumCols-column table to take the images
      Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=2, NumColumns:=NumCols)
      ' Set zero padding
      With oTbl
        .TopPadding = 0
        .BottomPadding = 0
        .LeftPadding = CentimetersToPoints(LEFT_PADDING)
        .RightPadding = 0
        .Spacing = 0
        .AllowPageBreaks = True
        .AllowAutoFit = False
      End With
      ' Set columns width
      With ActiveDocument.PageSetup
        TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
      End With
      With oTbl
        .AutoFitBehavior wdAutoFitFixed
        .Columns.Width = TblWdth / NumCols
      End With
      ' Main
      For i = 1 To .SelectedItems.Count Step NumCols
        r = ((i - 1) / NumCols + 1) * 2 - 1
        'Format the rows
        Call FormatRows(oTbl, r, RwHght)
        For c = 1 To NumCols
          j = j + 1
          'Insert the Picture
          With ActiveDocument.InlineShapes.AddPicture( _
              Filename:=.SelectedItems(j), LinkToFile:=False, _
              SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range)
              .LockAspectRatio = msoTrue
              .Height = oTbl.Cell(r, c).Height
              If .Width > oTbl.Cell(r, c).Width + CentimetersToPoints(LEFT_PADDING) Then
                .Width = oTbl.Cell(r, c).Width - CentimetersToPoints(LEFT_PADDING)
              End If
          End With
          'Get the Image name for the Caption
          StrTxt = Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\")))
          StrTxt = ": " & Split(StrTxt, ".")(0)
          'Insert the Caption onto the row below the picture
          oTbl.Cell(r + 1, c).Range.Characters.First.InsertAfter "Sample" & StrTxt
          'Exit when we're done
          If j = .SelectedItems.Count Then Exit For
        Next
        'Add extra rows as needed
        If j < .SelectedItems.Count Then
          oTbl.Rows.Add
          oTbl.Rows.Add
        End If
      Next
    End If
  End With
ErrExit:
  Application.ScreenUpdating = True
End_Sub
 
Sub FormatRows(oTbl As Table, x As Long, Hght As Single)
  With oTbl
    With .Rows(x)
      .Height = InchesToPoints(Hght)
      .HeightRule = wdRowHeightExactly
      .Range.Style = wdStyleNormal ' "Normal"
      .Cells.VerticalAlignment = wdCellAlignVerticalBottom
    End With
    With .Rows(x + 1)
      .Height = CentimetersToPoints(1)
      .HeightRule = wdRowHeightExactly
      .Range.Style = wdStyleCaption ' "Caption"
      .Cells.VerticalAlignment = wdCellAlignVerticalTop
    End With
  End With
End Sub
Change value of Const LEFT_PADDING to suit.
Click to expand...

This should work if only it would allow me to input a negative value like "-0.5". It gives an error highlighted at
Code: 
   .LeftPadding = CentimetersToPoints(LEFT_PADDING)
 
Upvote 0
Certainly, the LeftPadding can't be less that zero.
Applying a negative .LeftIndent to all rows like in post #6 .LeftIndent = InchesToPoints(-1) just shifts the table with its contents to the left on 1 inch.

frewert said:
This macro is being used in an already created form. This form has off center margins for some reason. So on a blank Excel document, these pictures are centered just fine. Except in this document because of the way the margins were set (its a returned goods form, controlled document) the macro puts the pictures over to the right.

The margin starts 1-1/4" from the left edge.
Click to expand...
There are too many unclear things to me:
1. What is "form"?
2. Why you've mentioned "Excel document" as all this thread is Word document about?
3. "the macro puts the pictures over to the right" - what is the macro? Why it puts the picture "to the right"? If this macro can be optimized then why not show its code here?

So, could you please upload somewhere 2 samples of Word documents with current result and with manually adjusted and post the link to download those documents to see details?
 
Last edited:
Upvote 0
Form meaning just a document my company sends to customers who need to return something.
And Excel was a mistake, I mean to say Word.

http://tempsend.com/AD55A0F834

This is a document I manually changed the Left indent for the table.
 
Last edited:
Upvote 0
Thank you for the samples and the comments, it's clear now.

Left shifting you've provided manually can be made via this line of the code:
oTbl.Rows.LeftIndent = CentimetersToPoints(LEFT_INDENT)
where LEFT_INDENT = -1.25 cm, for example.

Below is the revised code with left shifting:
Rich (BB code): 
Sub AddPics()
 
  Const LEFT_INDENT = -1.25 ' <-- LeftIndent in centimeters, change to suit
 
  Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long
  Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single
 
  On Error GoTo ErrExit
  NumCols = CLng(InputBox("How Many Columns per Row?"))
  RwHght = CSng(InputBox("What row height for the pictures, in inches (e.g. 1.5)?"))
  On Error GoTo 0
  Application.ScreenUpdating = False
 
  'Select and insert the Pics
  With Application.FileDialog(msoFileDialogFilePicker)
    .InitialFileName = ActiveDocument.Path  ' <-- look into folder of the document
    .Title = "Select image files and click OK"
    .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
    .FilterIndex = 2
    If .Show = -1 Then
      'Add a 2-row by NumCols-column table to take the images
      Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=2, NumColumns:=NumCols)
      ' Set zero padding
      With oTbl
        .TopPadding = 0
        .BottomPadding = 0
        .LeftPadding = 0
        .RightPadding = 0
        .Spacing = 0
        .AllowPageBreaks = True
        .AllowAutoFit = False
        .Rows.LeftIndent = CentimetersToPoints(LEFT_INDENT)  ' <-- shifting of the table
      End With
      ' Set columns width
      With ActiveDocument.PageSetup
        TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
      End With
      With oTbl
        .AutoFitBehavior wdAutoFitFixed
        .Columns.Width = TblWdth / NumCols
      End With
      ' Main
      For i = 1 To .SelectedItems.Count Step NumCols
        r = ((i - 1) / NumCols + 1) * 2 - 1
        'Format the rows
        Call FormatRows(oTbl, r, RwHght)
        For c = 1 To NumCols
          j = j + 1
          'Insert the Picture
          With ActiveDocument.InlineShapes.AddPicture( _
              Filename:=.SelectedItems(j), LinkToFile:=False, _
              SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range)
              .LockAspectRatio = msoTrue
              .Height = oTbl.Cell(r, c).Height
              If .Width > oTbl.Cell(r, c).Width Then
                .Width = oTbl.Cell(r, c).Width
              End If
          End With
          'Get the Image name for the Caption
          StrTxt = Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\")))
          StrTxt = ": " & Split(StrTxt, ".")(0)
          'Insert the Caption onto the row below the picture
          oTbl.Cell(r + 1, c).Range.Characters.First.InsertAfter "Sample" & StrTxt
          'Exit when we're done
          If j = .SelectedItems.Count Then Exit For
        Next
        'Add extra rows as needed
        If j < .SelectedItems.Count Then
          oTbl.Rows.Add
          oTbl.Rows.Add
        End If
      Next
    End If
  End With
ErrExit:
  Application.ScreenUpdating = True
End_Sub
 
Sub FormatRows(oTbl As Table, x As Long, Hght As Single)
  With oTbl
    With .Rows(x)
      .Height = InchesToPoints(Hght)
      .HeightRule = wdRowHeightExactly
      .Range.Style = wdStyleNormal
      .Cells.VerticalAlignment = wdCellAlignVerticalBottom
    End With
    With .Rows(x + 1)
      .Height = CentimetersToPoints(1)
      .HeightRule = wdRowHeightExactly
      .Range.Style = wdStyleCaption
      .Cells.VerticalAlignment = wdCellAlignVerticalTop
    End With
  End With
End Sub
Change value of Const LEFT_INDENT in centimeters for the proper shifting.

Best Regards,
 
Last edited:
Upvote 0
For correct aspect ratio of the inserted pictures use DOCX file format instead of the DOC.
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
Adding images in table with formatting into Outlook using a file picker
Replies
1
Views
2K
DeMoNloK
D
S
  • Question Question
Macro to insert all photos in a folder into a single word document
Replies
1
Views
6K
Macropod
Macropod
K
  • Question Question
Inserting pictures from folder automatically with VBA
Replies
1
Views
2K
kefier
K
M
  • Question Question
I need help with this code to modify the data into a table using Userform for VBA Excel (I want to do the range unlimited instead to do C7:C80000
Replies
5
Views
660
Dan_W
D
A
  • Question Question
Page break issues when exporting to pdf from userform (VBA)
Replies
0
Views
897
auglocqnuk
A

Forum statistics

Threads
1,224,816
Messages
6,181,141
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top