#1
|
|||
|
|||
Macro for Inserting Multiple Photos from Excel List into Word
I was looking for help with a Word macro that could do the following:
(1) Insert multiple photos into a word document without having to navigate through a directory to find the photo folder. (2) Retrieve and insert the captions for those photos from a column of data in an excel sheet. (3) Format the caption font to a certain font style. I would sincerely appreciate your help. Macropod has graciously provided this code, but the user must navigate to the file folder containing the photos and the captions are created based on the image names (I apologize if I am not pasting this code correctly): Code:
Sub AddPics() Application.ScreenUpdating = False Dim Stl As Style, i As Long, j As Long, c As Long, r As Long, NumCols As Long, iShp As InlineShape Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single, ColWdth As Single 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 'Select and insert the Pics With Application.FileDialog(msoFileDialogFilePicker) .Title = "Select image files and click OK" .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png" .FilterIndex = 2 If .Show = -1 Then 'Create a paragraph Style with 0 space before/after & centre-aligned With ActiveDocument On Error Resume Next Set Stl = .Styles("TblPic") If Stl Is Nothing Then Set Stl = .Styles.Add(Name:="TblPic", Type:=wdStyleTypeParagraph) On Error GoTo 0 With .Styles("TblPic").ParagraphFormat .Alignment = wdAlignParagraphCenter .KeepWithNext = True .SpaceAfter = 0 .SpaceBefore = 0 End With 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 ActiveDocument.PageSetup TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter ColWdth = TblWdth / NumCols End With With oTbl .AutoFitBehavior (wdAutoFitFixed) .Columns.Width = ColWdth End With CaptionLabels.Add Name:="Picture" For i = 1 To .SelectedItems.Count 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 = ActiveDocument.InlineShapes.AddPicture( _ FileName:=.SelectedItems(j), 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 'Get the Image name for the Caption StrTxt = Split(.SelectedItems(j), "")(UBound(Split(.SelectedItems(j), ""))) StrTxt = ": " & Split(StrTxt, ".")(0) 'Insert the Caption on the row below the picture With oTbl.Cell(r + 1, c).Range .InsertBefore vbCr .Characters.First.InsertCaption _ Label:="Picture", 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 If j < .SelectedItems.Count Then oTbl.Rows.Add oTbl.Rows.Add End If Next Else End If End With ErrExit: Application.ScreenUpdating = True End Sub Sub FormatRows(oTbl As Table, x As Long, Hght As Single) With oTbl With .Rows(x) .Height = Hght .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 Last edited by macropod; 02-10-2020 at 09:18 PM. Reason: Added code tags |
#2
|
||||
|
||||
Do the image filenames also appear in the workbook? If not, it's impossible to guarantee the captions will be assigned to the correct images. Either way, you'll need to tell us the:
• document path; • image path; • workbook path & name; • worksheet name; and • the columns the data are to be found in.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
||||
|
||||
As an alternative approach, see Photo Gallery Add-in Template
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#4
|
|||
|
|||
Document Path: C:\Users\[username]\Box Sync\SF_Projects_Active\[project number]
Image Path: C:\Users\[username]\Box Sync\SF_Projects_Active\[project number]\[project number] Report Photos Workbook Path: C:\Users\[username]\Box Sync\[username]\RCA Workbook Name: Inspections Worksheet Name: [project number] Observations Image #s in column N Captions in column Q **Info in brackets is generic Column N contains the image names that correspond to those in the folder containing the images. For example, cell N2 contains the text IMG_0001 and an image in the image folder also contains an image named IMG_0001. In column N, they do not have any extension, simply the name, e.g. IMG_0001. In the folder, they are similarly named, i.e. IMG_0001. However, when I click on the properties/details of the image, the name is IMG_0001.JPG. |
#5
|
||||
|
||||
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 For PC macro installation & usage instructions, see: Installing Macros
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] Last edited by macropod; 02-26-2020 at 04:24 AM. |
#6
|
|||
|
|||
Yes, thank you!
One last request . Can you help me change the captions to read "Photograph X: Caption", in Times New Roman with size 10 font, and 5 spaces between the colon and caption? Also, please let me know how to make a financial contribution. Thank you! |
#7
|
||||
|
||||
Quote:
CaptionLabels.Add Name:="Picture" to: CaptionLabels.Add Name:="Photograph" Change: Label:="Picture" to: Label:="Photograph" Insert: Code:
With .Styles("Caption") With .Font .Name = "Times New Roman" .Size = 10 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 Note: Word doesn't work with spaces the way I expect you want. Using a tab-stop should give a comparable result.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#8
|
|||
|
|||
Thank you for this macro
|
#9
|
|||
|
|||
Hello, Could you please help me edit the code as the text need to come next to the picture not at the height based. (For example: if some picture are not stretched to given height the text should move up)
|
#10
|
||||
|
||||
It's not apparent to me what text you think should move. Perhaps all you need do is ensure an appropriate column width is chosen then, after running the macro change the table's text wrapping to 'around'. You could still also use the column sliders to move the left or right cell margins however far you need them to be.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#11
|
|||
|
|||
the image below pictures
You can view the image and i need to move the text near to the picture. Which i need to figure it out.
|
#12
|
||||
|
||||
It seems to me the problem is that you have specified a row height that is way too large. That said, you could change:
.Cells.VerticalAlignment = wdCellAlignVerticalCenter to: .Cells.VerticalAlignment = wdCellAlignVerticalBottom
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#13
|
|||
|
|||
Hello, I've a workbook "Inspections.xlsx" with worksheet named "Observations" saved in C:\Users\ABC\Documents\. Photos are also saved at the same folder. I've changed the code like this
Code:
StrWkBkNm = "C:\Users\ABC\Documents\Inspections.xlsx" StrDocPath = ActiveDocument.Path StrRpt = Right(StrDocPath, Len(StrDocPath) - InStrRev(StrDocPath, "\")) StrWkSht = "Observations" StrPicPath = "C:\Users\ABC\Documents\" Code:
If .Name = "TblPic" Then bFnd = False: Exit For |
#14
|
||||
|
||||
That may be implying that you don't have a style in your document called "TblPic".
Did you modify other parts of the code? For instance what is the With statement before we get to the .Name line.
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#15
|
|||
|
|||
I just modified the code listed above.
I've tried adding "TblPic" style first, but it didn't work. |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Macro for Inserting Multiple Photos into Word but retrieving Captions from Excel Sheet | macaronipasta | Word VBA | 2 | 06-27-2021 06:28 PM |
Macro to access info from Excel spreadsheet and populate Word doc with text, photos, and captions | henhelm | Word VBA | 4 | 06-27-2019 08:49 PM |
Inserting multiple photos at a specific size | Mr M | Drawing and Graphics | 2 | 06-20-2018 08:07 PM |
Inserting and formatting photos in word 2013 | tha_slughy | Word VBA | 5 | 07-13-2014 04:39 PM |
Inserting / formatting multiple photos into Word doc. | Jeremiahts | Drawing and Graphics | 1 | 03-23-2011 07:33 PM |