Microsoft Office Forums

Go Back   Microsoft Office Forums > Microsoft Word > Word VBA

Reply
 
LinkBack Thread Tools Display Modes
  #1  
Old 09-24-2018, 12:47 AM
NicB NicB is offline Windows 10 Office 2016
Novice
 
Join Date: Apr 2018
Posts: 16
NicB is on a distinguished road
Default Help to adjust photo caption macro


I've used the following macro for a couple of years, which adds a single column table with space for two photos and captions underneath. It has served me very well and saved me a huge amount of time with inserting up to 300+ images into documents. This was not code I wrote - i just tweaked it to include the caption i needed and the image size I wanted.

There has been one niggle that i could never get to the bottom of - how do get a space to appear after the -? A simple thing, but for the life of me I couldn't get anything i tried to work. I literally spent hours on it and gave up in the end.

Also, it would be brilliant if i had the option to exclude the dash entirely, as there are times when I just need the label. I know I could duplicate this macro and remove the dash, but that's probably a bit overkill. Worst case, I can record a macro to find all instances of the dash and delete them (although if i'm half asleep, it could have a detrimental effect on the remainder of the document!).

I have nil understanding of VBA and wouldn't know where to begin, or if indeed it is possible. Would anyone be able to assist, please?

Code:
Sub AddCaptionedImages()
'
' Inserts a 1 column x 4 row/page table into a page, with an image in the first row and a caption in the second row
'
'

    Application.ScreenUpdating = False
    Dim oTbl As Table, i As Long, j As Long, StrTxt As String
    Dim fd As Object
    Set fd = Application.FileDialog(3)
     'Select and insert the Pics
    With fd
        .Title = "Select image files and click OK"
        .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
        .FilterIndex = 2
        If .Show = -1 Then
             'Add a 2-row by 1-column table with 7cm column width to take the images
            Set oTbl = Selection.Tables.Add(Selection.Range, 2, 1)
            With oTbl
                .AutoFitBehavior (wdAutoFitFixed)
                .Columns.Width = CentimetersToPoints(15.98)
                 'Format the rows
                Call FormatRows(oTbl, 1)
            End With
            CaptionLabels.Add Name:="Photograph"
            For i = 1 To .SelectedItems.Count
                j = i * 2 - 1
                 'Add extra rows as needed
                If j > oTbl.Rows.Count Then
                    oTbl.Rows.Add
                    oTbl.Rows.Add
                    Call FormatRows(oTbl, j)
                End If
                 'Insert the Picture
                ActiveDocument.InlineShapes.AddPicture _
                FileName:=.SelectedItems(i), LinkToFile:=False, _
                SaveWithDocument:=True, Range:=oTbl.Rows(j).Cells(1).Range
                 'Get the Image name for the Caption
                StrTxt = Split(.SelectedItems(i), "\")(UBound(Split(.SelectedItems(i), "\")))
                StrTxt = ": " & Split(StrTxt, ".")(0)
                 'Insert the Caption on the row below the picture
                With oTbl.Rows(j + 1).Cells(1).Range
                    .InsertBefore vbCr
                    .Characters.First.InsertCaption _
                    Label:="Photograph", Title:=" - ", _
                    Position:=wdCaptionPositionBelow, ExcludeLabel:=False
                    .Characters.First = vbNullString
                    .Characters.Last.Previous = vbNullString
                End With
            Next
        Else
        End If
    End With
    Application.ScreenUpdating = True
End Sub
 '
Sub FormatRows(oTbl As Table, x As Long)
    With oTbl
        With .Rows(x)
            .Height = CentimetersToPoints(10)
            .HeightRule = wdRowHeightExactly
            .Range.Style = "Normal"
            .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
        End With
        With .Rows(x + 1)
            .Height = CentimetersToPoints(1.7)
            .HeightRule = wdRowHeightExactly
            .Range.Style = "Caption"
            .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
        End With
    End With
End Sub
Reply With Quote
  #2  
Old 09-24-2018, 02:14 AM
gmayor's Avatar
gmayor gmayor is offline Windows 10 Office 2016
Expert
 
Join Date: Aug 2014
Posts: 2,705
gmayor is just really nicegmayor is just really nicegmayor is just really nicegmayor is just really nice
Default

The following changes to your first macro will address both your concerns. You may also be interested in http://www.gmayor.com/photo_gallery_template.html .



Code:
Sub AddCaptionedImages()
'
' Inserts a 1 column x 4 row/page table into a page, with an image in the first row and a caption in the second row
'
'Graham Mayor - http://www.gmayor.com - Last updated - 24 Sep 2018

Dim oTbl As Table, i As Long, j As Long, StrTxt As String
Dim fd As Object
Dim bHyphen As Boolean
Dim strTitle As String

    Application.ScreenUpdating = False
    Set fd = Application.FileDialog(3)
    'Select and insert the Pics
    With fd
        .Title = "Select image files and click OK"
        .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
        .FilterIndex = 2
        If .Show = -1 Then
            If MsgBox("Include hyphen at end of caption?", vbYesNo) = vbYes Then bHyphen = True
            If bHyphen = True Then
                strTitle = " - "
            Else
                strTitle = ""
            End If
            'Add a 2-row by 1-column table with 7cm column width to take the images
            Set oTbl = Selection.Tables.Add(Selection.Range, 2, 1)
            With oTbl
                .AutoFitBehavior (wdAutoFitFixed)
                .Columns.Width = CentimetersToPoints(15.98)
                'Format the rows
                Call FormatRows(oTbl, 1)
            End With
            CaptionLabels.Add Name:="Photograph"
            For i = 1 To .SelectedItems.Count
                j = i * 2 - 1
                'Add extra rows as needed
                If j > oTbl.Rows.Count Then
                    oTbl.Rows.Add
                    oTbl.Rows.Add
                    Call FormatRows(oTbl, j)
                End If
                'Insert the Picture
                ActiveDocument.InlineShapes.AddPicture _
                        FileName:=.SelectedItems(i), LinkToFile:=False, _
                        SaveWithDocument:=True, Range:=oTbl.Rows(j).Cells(1).Range
                'Get the Image name for the Caption
                StrTxt = Split(.SelectedItems(i), "\")(UBound(Split(.SelectedItems(i), "\")))
                StrTxt = ": " & Split(StrTxt, ".")(0)
                'Insert the Caption on the row below the picture
                With oTbl.Rows(j + 1).Cells(1).Range
                    .InsertBefore vbCr
                    .Characters.First.InsertCaption _
                            Label:="Photograph", Title:=strTitle, _
                            Position:=wdCaptionPositionBelow, ExcludeLabel:=False
                    .Characters.First = vbNullString
                    If Not bHyphen = True Then
                        .Characters.Last.Previous = vbNullString
                    Else
                        .Characters.Last.Previous = Chr(32)
                    End If
                End With
                DoEvents
            Next
        Else
        End If
    End With
    Application.ScreenUpdating = True
End Sub
__________________
Graham Mayor - MS MVP (Word)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
  #3  
Old 09-24-2018, 11:02 AM
NicB NicB is offline Windows 10 Office 2016
Novice
 
Join Date: Apr 2018
Posts: 16
NicB is on a distinguished road
Default

This is perfect - thank you very much Graham. I would never have figure the update out!

I do have the photo galley add-in on my personal laptop - it is a brilliant little app. Unfortunately, I'm unable to use it for work

Thank you again.
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Loop macro to adjust text formating within Word beardsa Word VBA 1 02-01-2018 12:10 AM
How do I adjust above spacing in table? Silverlining Word 1 07-02-2016 10:10 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
adjust lines to single rolypoly71 Word 1 08-17-2015 10:09 AM
Adjust speed of ppt animation gerryb PowerPoint 0 08-15-2009 08:45 AM


All times are GMT -7. The time now is 11:14 AM.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.
SEO by vBSEO ©2011, Crawlability, Inc.
MSOfficeForums.com is not affiliated with Microsoft