Give the following a go:
Code:
Sub AddPicsFromExcel()
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim StrRpt As String, StrDocPath As String, StrPicPath As String, xlFList As String, xlCList As String
Dim iDataRow As Long, c As Long, r As Long, i As Long, j As Long, k As Long, NumCols As Long
Dim iShp As InlineShape, oTbl As Table, TblWdth As Single, RwHght As Single, ColWdth As Single
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Box Sync\" & Environ("Username") & "\RCA\Inspections.xlsx"
StrDocPath = ActiveDocument.Path
StrRpt = Right(StrDocPath, Len(StrDocPath) - InStrRev(StrDocPath, "\"))
StrWkSht = StrRpt & " Observations"
StrPicPath = StrDocPath & "\" & StrRpt & " Report Photos\"
If Dir(StrWkBkNm) = "" Then
MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
Exit Sub
End If
On Error GoTo ErrExit
NumCols = CLng(InputBox("How Many Columns per Row?"))
RwHght = CentimetersToPoints(CSng(InputBox("What max height for the pictures, in centimeters (e.g. 5)?")))
On Error GoTo 0: On Error Resume Next
'Start Excel
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
MsgBox "Can't start Excel.", vbExclamation
Exit Sub
End If
On Error GoTo 0
With xlApp
'Hide our Excel session
.Visible = False
' The file is available, so open it.
Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=True, AddToMru:=False)
If xlWkBk Is Nothing Then
MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
.Quit: Exit Sub
End If
' Process the workbook.
With xlWkBk
'Ensure the worksheet exists
If SheetExists(xlWkBk, StrWkSht) = True Then
With .Worksheets(StrWkSht)
' Find the last-used row in column A.
iDataRow = .Cells(.Rows.Count, 14).End(-4162).Row ' -4162 = xlUp
' Capture the F/R data.
For i = 2 To iDataRow
' Skip over empty fields to preserve the underlying cell contents.
If Trim(.Range("N" & i)) <> vbNullString Then
xlFList = xlFList & "|" & Trim(.Range("N" & i))
xlCList = xlCList & "|" & Trim(.Range("Q" & i))
End If
Next
End With
Else
MsgBox "Cannot find the designated worksheet: " & StrWkSht, vbExclamation
End If
.Close False
End With
.Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Exit if there are no data
If xlFList = "" Then Exit Sub
With ActiveDocument
For i = 1 To .Styles.Count
With .Styles(i)
If .Name = "TblPic" Then bFnd = False: Exit For
End With
Next
If bFnd = False Then .Styles.Add Name:="TblPic", Type:=wdStyleTypeParagraph
With .Styles("TblPic").ParagraphFormat
.Alignment = wdAlignParagraphCenter
.KeepWithNext = True
.SpaceAfter = 0
.SpaceBefore = 0
End With
With .Styles("Caption")
With .Font
.Name = "Times New Roman"
.Size = 10
.Bold = False
End With
.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(2.5), Alignment:=wdAlignTabLeft
End With
'Add a 2-row by NumCols-column table to take the images
Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=2, NumColumns:=NumCols)
With .PageSetup
TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
ColWdth = TblWdth / NumCols
End With
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns.Width = ColWdth
End With
CaptionLabels.Add Name:="Photograph"
'Process each file from the F/R List
k = UBound(Split(xlFList, "|"))
For i = 1 To k Step NumCols
r = ((i - 1) / NumCols + 1) * 2 - 1
'Format the rows
Call FormatRows(oTbl, r, RwHght)
For c = 1 To NumCols
j = j + 1
'Insert the Picture
Set iShp = .InlineShapes.AddPicture( _
FileName:=StrPicPath & Split(xlFList, "|")(j) & ".jpg", LinkToFile:=False, _
SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range)
With iShp
.LockAspectRatio = True
If (.Width < ColWdth) And (.Height < RwHght) Then
.Width = ColWdth
If .Height > RwHght Then .Height = RwHght
End If
End With
'Insert the Caption on the row below the picture
With oTbl.Cell(r + 1, c).Range
.InsertBefore vbCr
.Characters.First.InsertCaption _
Label:="Photograph", Title:=vbTab & Split(xlCList, "|")(j), _
Position:=wdCaptionPositionBelow, ExcludeLabel:=False
.Characters.First = vbNullString
.Characters.Last.Previous = vbNullString
End With
'Exit when we're done
If j = k Then Exit For
Next
'Add extra rows as needed
If j < k Then
oTbl.Rows.Add
oTbl.Rows.Add
End If
Next
End With
ErrExit:
Application.ScreenUpdating = True
End Sub
Function SheetExists(xlWkBk As Object, SheetName As String) As Boolean
Dim i As Long: SheetExists = False
For i = 1 To xlWkBk.Sheets.Count
If xlWkBk.Sheets(i).Name = SheetName Then
SheetExists = True: Exit For
End If
Next
End Function
Sub FormatRows(oTbl As Table, x As Long, RwHght As Single)
With oTbl
With .Rows(x)
.Height = RwHght
.HeightRule = wdRowHeightExactly
.Range.Style = "TblPic"
.Cells.VerticalAlignment = wdCellAlignVerticalCenter
End With
With .Rows(x + 1)
.Height = CentimetersToPoints(0.5)
.HeightRule = wdRowHeightExactly
.Range.Style = "Caption"
End With
End With
End Sub
Note: If you'd prefer to work in inches, replace all the 'centimeters' references to 'inches' and, where that is followed by a number in parentheses, change that number to a suitable value for inches.
For PC macro installation & usage instructions, see:
Installing Macros