#1
|
|||
|
|||
Help with macro - labels/caption under pictures
Hi,
Hope someone can help me out with the macro in https://www.msofficeforums.com/drawi...ument-all.html . I want the label/caption under each picture to be: "Sample": "Filename". Now I get "Sample" "Count": "Filename", what do I need to change in the macro. |
#2
|
||||
|
||||
It is easy enough to lose the Caption and write text to the cell e.g. as follows, but you might find https://www.gmayor.com/photo_gallery_template.html more useful
Code:
Option Explicit Sub AddPics() Application.ScreenUpdating = False Dim 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 = 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 On Error Resume Next With ActiveDocument .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:="Sample" 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 .Collapse 1 .Text = "Sample" & StrTxt '.InsertBefore vbCr '.Characters.First.InsertCaption _ Label:="Sample", 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 = CentimetersToPoints(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
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Help to adjust photo caption macro | NicB | Word VBA | 2 | 09-24-2018 11:02 AM |
List of figures with several labels (caption) - Table of Figures sorting | ibra_ca | Word | 2 | 10-11-2017 07:02 AM |
Insert Pictures - Via MACRO | sahrens1 | Word VBA | 1 | 07-02-2017 07:16 AM |
Word 2010 Run-Time error 4198 with Insert Picture with Caption and Fram Macro | jstills116 | Word VBA | 0 | 06-24-2016 07:46 AM |
Macro to select and format all pictures at once | Vincent | Word VBA | 1 | 07-31-2015 12:28 AM |