Microsoft Office Forums Help with macro - labels/caption under pictures

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 05-03-2019, 02:08 AM
Piaco Piaco is offline Help with macro - labels/caption under pictures Windows 10 Help with macro - labels/caption under pictures Office 2019
Novice
Help with macro - labels/caption under pictures
 
Join Date: May 2019
Posts: 1
Piaco is on a distinguished road
Default Help with macro - labels/caption under pictures

Hi,

Hope someone can help me out with this macro (which I think I have stolen from a post on this forum ). 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 below macro:

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
.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
Reply With Quote
  #2  
Old 05-03-2019, 02:58 AM
gmayor's Avatar
gmayor gmayor is offline Help with macro - labels/caption under pictures Windows 10 Help with macro - labels/caption under pictures Office 2016
Expert
 
Join Date: Aug 2014
Posts: 2,860
gmayor is just really nicegmayor is just really nicegmayor is just really nicegmayor is just really nice
Default

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
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Help with macro - labels/caption under pictures 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
Help with macro - labels/caption under pictures Macro to select and format all pictures at once Vincent Word VBA 1 07-31-2015 12:28 AM


All times are GMT -7. The time now is 03:58 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2019, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2019 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft