Add pictures in table

[BramGrey]

Good day,

I found a VBA Script that already does what it is suppose to do, but something needs to be adjusted and I can't find how.

Script imports pictures, and places them all underneath each other. (the spacing between them and the title is already perfect) I want them to be added in a table, always 4 pictures next to each other, not only 1 every row.

Somebody able to adjust or tell me how to fix it?

Thanks!!

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
 'define resize constraints
 max_height = 275

 'add a 1 row 2 column table to take the images
 Set oTable = Selection.Tables.Add(Selection.Range, 1, 1)
 '+++++++++++++++++++++++++++++++++++++++++++++
 'oTable.AutoFitBehavior (wdAutoFitFixed)
 oTable.Rows.Height = CentimetersToPoints(4)
 oTable.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
 '++++++++++++++++++++++++++++++++++++++++++++++

 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

 For i = 1 To .SelectedItems.Count

 iCol = 1
 iRow = i
 'get filename
 picName = Right(.SelectedItems(i), Len(.SelectedItems(i)) - InStrRev(.SelectedItems(i), "\"))
 'remove extension from filename ****
 picName = Left(picName, InStrRev(picName, ".") - 1)

 'select cell
 Set oCell = ActiveDocument.Tables(1).Cell(iRow, iCol).Range

 'insert image
 oCell.InlineShapes.AddPicture FileName:= _
 .SelectedItems(i), LinkToFile:=False, _
 SaveWithDocument:=True, Range:=oCell

 'resize image
 If oCell.InlineShapes(1).Height > max_height Then
 scale_factor = oCell.InlineShapes(1).ScaleHeight * (max_height / oCell.InlineShapes(1).Height)
 oCell.InlineShapes(1).ScaleHeight = scale_factor
 oCell.InlineShapes(1).ScaleWidth = scale_factor
 End If

 'center content
 oCell.ParagraphFormat.Alignment = wdAlignParagraphCenter

 'insert caption below image
 oCell.InlineShapes(1).Range.InsertCaption Label:="Figure", TitleAutoText:="", _
 Title:=": " & picName
 If i < .SelectedItems.Count And i Mod 2 = 0 Then 'add another row, more to go
 oTable.Rows.Add
 End If
 Next i
 End If
 End With

 Set fd = Nothing
 End Sub

[gmaxey]

The addin here will do that for you: Photo Gallery Add-In

[BramGrey]

Thanks.

Since it is not allowed to install on this corporate computer, I prefer an adjustment to the VBA code. Could you assist me with that as well?

Thanks!

[macropod]

See the Automate the Insertion of Multiple Images into a Document 'Sticky' thread at the top of the Drawing and Graphics forum: https://www.msofficeforums.com/drawi...-document.html

[macropod]

Cross-posted at: Inerrt Multiple pictures in Table - Microsoft Q&A
For cross-posting etiquette, please read: Excelguru Help Site - A message to forum cross posters
__________________

[BramGrey]

Macropod,

Thx for the info. I do have one more question.
I cannot find a way to create some space between the pictures I insert by your macro.

So imagine I use 4 picts on a row, I want a table with no borders (which is explained in your manual) But I also want the pictures to be separated with a little more space (for example, 0.5cm) between each other.

is there a simple way to do so?

Thanks!!!

[gmaxey]

Have you tried adjusting:


.TopPadding = 0
.BottomPadding = 0
.LeftPadding = 0
.RightPadding = 0

[macropod]

You could set both the column widths and the row heights to the required picture sizes, then resize the table afterwards.

[BramGrey]

Here I am again.
Since I have a new PC and Laptop, the Macro gives an Error.
Can you give me some advice?
PC = Win 10 Pro
Laptop = Win 365

Piece of the code below. It gives an error on this part.
.Characters.First.InsertCaption _
Label:="Foto", Title:=StrTxt, _
Position:=wdCaptionPositionBelow, ExcludeLabel:=False

  'Insert the Caption on the row below the picture
        With oTbl.Cell(r + 1, c).Range
          .InsertBefore vbCr
          .Characters.First.InsertCaption _
          Label:="Foto", 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

[macropod]

Does your code include the line:

CaptionLabels.Add Name:="Foto"

before the line:

For i = 1 To .SelectedItems.Count Step NumCols