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