none
A way to create table with pictures faster? RRS feed

  • Question

  • Hello.

    I am looking for help.

    I recently started a job that needs me to make a lot of long reports with pictures in Office.

    I looked for a way to automatically create a table that put pictures from a file, best thing would be a 2 column table, with 1 empty line under the pictures.

    I found this code; witch is handy but doesn't do a table.

    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

     If anyone could help me, it would be nice, I could save a lot of time.

    Thanks a lot in advance.

    Saturday, August 18, 2018 6:00 AM

All replies