Add pictures in table

BramGrey · #1 11-08-2022, 12:32 AM

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!!

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
 '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 · #2 11-08-2022, 04:00 AM

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

BramGrey · #3 11-08-2022, 07:21 AM

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 · #4 11-08-2022, 02:27 PM

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 · #5 11-08-2022, 03:00 PM

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 · #6 11-15-2022, 05:44 AM

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 · #7 11-15-2022, 08:23 AM

Have you tried adjusting:

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

macropod · #8 11-18-2022, 03:39 PM

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

BramGrey · #9 01-29-2023, 04:39 AM

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

Code:

  '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 · #10 02-15-2023, 03:23 PM

Does your code include the line:

Code:

CaptionLabels.Add Name:="Foto"

before the line:

Code:

For i = 1 To .SelectedItems.Count Step NumCols

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Word Table inserting Pictures	stu_c	Word Tables	2	07-28-2022 02:39 PM
Create Table for Multiple Pictures. 1 picture, 1 table and space between tables	gorkac	Word VBA	9	03-11-2022 05:12 AM
Create Table for Multiple Pictures	victorybadges	Word VBA	4	12-25-2020 02:11 PM
Mac - Macro insert pictures in table	Nina	Word VBA	16	08-27-2018 01:53 AM
Inserting Images/Pictures into Table of Content	Simon	Word	11	09-12-2016 11:37 PM