User Profile
AzDa2152
Copper Contributor
Joined 11 months ago
User Widgets
Recent Discussions
Change a few things in the Macro
I have included a Macro script below and seek assistance in modifying it. Specifically, I aim to enlarge the size of the text box, as depicted in the accompanying image. Presently (in the below script), the text box dimensions allow for only a single row of text, which proves insufficient. Additionally, I would like to automate the addition of descriptive text beneath each inserted picture. Ideally, the script should automatically append labels such as "Picture 1," "Picture 2," and so forth below the respective images. Currently, the script associates the picture name and positions it beneath the image. Looking forward to recieve help in getting this sorted for us. This will make our work so much easier and we would save lots of time. 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 = 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 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) .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(Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\"))), ".")(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(1#) .HeightRule = wdRowHeightExactly .Range.Style = "Normal" End With End With End Sub
