Inerrt Multiple pictures in Table

SonOfGrey 1 Reputation point
2022-11-07T18:01:10.997+00:00

Good day,

I already have a code to add pictures the way I want, but he adds them all under each other. I want to put them in a table wehre 3 or 4 pictures are on 1 row, instead of all underneath eachother.
Somebody who can help?

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  
Microsoft 365 and Office | Development | Other
Microsoft 365 and Office | Word | For business | Windows
{count} votes

Your answer

Answers can be marked as Accepted Answers by the question author, which helps users to know the answer solved the author's problem.