#1
|
|||
|
|||
Add Multiple Pics & Captions to a Document
Hi Paul
I have now being working with the original code in https://www.msofficeforums.com/drawi...ument-all.html and, while I have changed a number of things and can also use Word to improve the output such as centring the caption line, the one thing I cannot do is to form fit the text to fit in the prescribed column width, hope you can help. here is my revised macro for captions 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 row height for the pictures, in Centimeters (e.g. 5)?"))) ColWdth = CentimetersToPoints(CSng(InputBox("What max column width 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 If TblWdth / NumCols < ColWdth Then ColWdth = TblWdth / NumCols End With With oTbl .AutoFitBehavior (wdAutoFitFixed) .TopPadding = 0 .BottomPadding = 0 .LeftPadding = 0 .RightPadding = 0 .Spacing = 0 .Columns.Width = ColWdth .Borders.Enable = True 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 oTbl.Cell(r + 1, c).Range.Text = StrTxt '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; 12-26-2020 at 04:30 AM. Reason: Added code tags |
#2
|
||||
|
||||
I don't see where you're centring the caption, which in any event should be accomplished by modifying the Caption Style, not by overriding the paragraph format in code. Indeed, your line:
Code:
oTbl.Cell(r + 1, c).Range.Text = StrTxt To fit the text to the cell, you could use the .FitText method. See the relevant code in the link.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
thank you, I have had trouble so I started off with your original macro for the captions and then placed this last change and it worked fine. However I dont want the label "Picture: ". How do I only show the file name please.
|
#4
|
||||
|
||||
For just the text:
Code:
With oTbl.Cell(r + 1, c).Range .Text = StrTxt End With
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
|||
|
|||
H Paul
thank you for your latest update sorry I keep asking you questions the caption is now fitting as requested however its squeezed against the adjacent captions. Ideally 0.1cm left and right margin or a run time selection for the margin and can you do it so the caption is centred please thank you |
#6
|
||||
|
||||
Change:
Code:
.FitTextWidth = ColWdth Code:
.FitTextWidth = ColWdth - CentimetersToPoints(0.1)
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#7
|
|||
|
|||
just tested it thanks
no left indent and not centred |
#8
|
||||
|
||||
As I said in an earlier reply, changes to the caption paragraph's formatting should be done by changing the Style definition. You can do that manually, or by code. In your post previous to that, you said you had already modified things so that you were getting the required centring.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#9
|
|||
|
|||
thanks Paul, sorry I had forgotten regarding centring. No code, I manually highlight the table and click on paragraph centre so that is fine,
so only thing left is the left indent please, if this is too difficult I can increase the CentimetersToPoints from 0.1 to say 0.2 and then centre it. let me know |
#10
|
||||
|
||||
Quote:
To center the captions (the pics are already centered), before: Code:
With .Styles("TblPic").ParagraphFormat Code:
.Styles("Caption").ParagraphFormat.Alignment = wdAlignParagraphCenter
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#11
|
|||
|
|||
perfect thanks
|
#12
|
|||
|
|||
Dear Paul, had to revisit this as my Word updated itself and I lost my macros
I am back now where I was after a few hours of reconstructing. The macro with the captions I still need a slight modification. For file names which seem to fit perfectly within the width of the column there appears to be no indenting, so if adjacent files names are of similar length they appear touching each other. Hope you can help. This is my file at this stage Code:
Sub Add_PicsinTable_with_Captions() 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 row height for the pictures, in Centimeters (e.g. 5)?"))) ColWdth = CentimetersToPoints(CSng(InputBox("What max column width 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 If TblWdth / NumCols < ColWdth Then ColWdth = TblWdth / NumCols End With With oTbl .AutoFitBehavior (wdAutoFitFixed) .TopPadding = 0 .BottomPadding = 0 .LeftPadding = 0 .RightPadding = 0 .Spacing = 0 .Columns.Width = ColWdth .Borders.Enable = True 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 .Text = StrTxt If .Characters.Last.Previous.Information(wdVerticalPositionRelativeToPage) <> _ .Characters.First.Information(wdVerticalPositionRelativeToPage) Then .FitTextWidth = ColWdth - CentimetersToPoints(0.3) End If 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-13-2021 at 11:47 PM. Reason: Added code tags |
#13
|
||||
|
||||
Change this:
Code:
'Insert the Caption on the row below the picture With oTbl.Cell(r + 1, c).Range .Text = StrTxt If .Characters.Last.Previous.Information(wdVerticalPositionRelativeToPage) <> _ .Characters.First.Information(wdVerticalPositionRelativeToPage) Then .FitTextWidth = ColWdth - CentimetersToPoints(0.3) End If End With Code:
'Insert the Caption on the row below the picture With oTbl.Cell(r + 1, c) .LeftPadding = CentimetersToPoints(0.15) .RightPadding = CentimetersToPoints(0.15) With .Range .Text = StrTxt If .Characters.Last.Previous.Information(wdVerticalPositionRelativeToPage) <> _ .Characters.First.Information(wdVerticalPositionRelativeToPage) Then .FitTextWidth = ColWdth - CentimetersToPoints(0.3) End If End With End With
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#14
|
|||
|
|||
thank you Paul, but this has revealed two issues
firstly can it centre first and then do the padding as this is more evident in small file names that there is no centring of the caption secondly I noticed a different issue in that the images in the 2nd row onwards are not centred, I tested it several times (this does not happen with my macro with no captions ?) regards Nick |
#15
|
||||
|
||||
Quote:
Quote:
My preferred approach would be to configure the entire table with a suitable amount of cell padding all round plus, of course, the centering of the Caption Style. For example: Code:
Sub Add_PicsinTable_with_Captions() 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, RowHght As Single, ColWdth As Single Dim HPad As Single, VPad As Single, PicHght As Single, PicWdth As Single HPad = CentimetersToPoints(0.15): VPad = CentimetersToPoints(0.05) On Error GoTo ErrExit NumCols = CLng(InputBox("How Many Columns per Row?")) RowHght = CentimetersToPoints(CSng(InputBox("What max row height for the pictures, in Centimeters (e.g. 5)?"))) ColWdth = CentimetersToPoints(CSng(InputBox("What max column width for the pictures, in Centimeters (e.g. 5)?"))) On Error GoTo 0 PicHght = RowHght - VPad * 2: PicWdth = ColWdth - HPad * 2 'MsgBox "PicWdth: " & PointsToCentimeters(PicWdth) & vbTab & "ColWdth: " & PointsToCentimeters(ColWdth) 'MsgBox "PicHght: " & PointsToCentimeters(PicHght) & vbTab & "RowHght: " & PointsToCentimeters(RowHght) '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 .Styles("Caption").ParagraphFormat.Alignment = wdAlignParagraphCenter 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 If TblWdth / NumCols < ColWdth Then ColWdth = TblWdth / NumCols End With With oTbl .AutoFitBehavior (wdAutoFitFixed) .TopPadding = VPad .BottomPadding = VPad .LeftPadding = HPad .RightPadding = HPad .Spacing = 0 .Columns.Width = ColWdth .Borders.Enable = True .Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter 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, RowHght) 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 < PicWdth Then .Width = PicWdth If .Height > PicHght Then .Height = PicHght End With 'Get the Image name for the Caption StrTxt = Split(.SelectedItems(j), "")(UBound(Split(.SelectedItems(j), ""))) StrTxt = Split(Split(StrTxt, "\")(UBound(Split(StrTxt, "\"))), ".")(0) 'Insert the Caption on the row below the picture With oTbl.Cell(r + 1, c) With .Range .Text = StrTxt If .Characters.Last.Previous.Information(wdVerticalPositionRelativeToPage) <> _ .Characters.First.Information(wdVerticalPositionRelativeToPage) Then .FitTextWidth = PicWdth End If End With 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" End With With .Rows(x + 1) .Height = CentimetersToPoints(0.5) .HeightRule = wdRowHeightExactly .Range.Style = "Caption" End With End With End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Macro for Inserting Multiple Photos from Excel List into Word | henhelm | Word VBA | 15 | 02-07-2023 05:35 PM |
Macro for Inserting Multiple Photos into Word but retrieving Captions from Excel Sheet | macaronipasta | Word VBA | 2 | 06-27-2021 06:28 PM |
I need a macro to automatically insert 4 pics per page in a word document with "Photograph No 1, 2," | NewbieLearning | Word VBA | 15 | 11-14-2017 05:03 AM |
Captions: Changing captions in Appendix update all captions | carnestw | Word | 3 | 10-27-2015 12:34 PM |
How do I type on multiple pics? | TimHudson | Drawing and Graphics | 0 | 07-28-2011 10:28 AM |