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  
Office Development
Office Development
Office: A suite of Microsoft productivity software that supports common business tasks, including word processing, email, presentations, and data management and analysis.Development: The process of researching, productizing, and refining new or existing technologies.
3,473 questions
Word Management
Word Management
Word: A family of Microsoft word processing software products for creating web, email, and print documents.Management: The act or process of organizing, handling, directing or controlling something.
891 questions
{count} votes