Consulting

Results 1 to 12 of 12

Thread: Insert picture caption and group

  1. #1
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location

    Insert picture caption and group

    I'd have thought this would be a simple macro to record and generalize, but no luck; the Word object model is fighting me all the way


    All I'm trying to do is select a picture (first para in attachment), and use InputBox to enter the caption


    1. If Inline, make it Square. If Square already, continue. If not 'caption-able' then exit

    2. Insert picture caption with text from InputBox (it defaults to caption style so that's good)

    3. Group the picture and the caption

    I want the end result to look like para2

    This is getting into some Word areas that are new territory for me, so I'm looking for some help. Thanks

    Capture.JPG
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  2. #2
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    Got something that works finally

    Not as robust as I would like but it seems to have the basics. Still Open to ideas and suggestions


    Option Explicit
    
    Sub AddCaptionToSelectedShape()
        Dim sShapeName As String, sCaptionName As String
        Dim sCaption As String
    
    
        'make sure a shape-type thing is selected
        If Selection.Type <> wdSelectionShape Then
            Call MsgBox("Sorry, you have to select a Shape (or Picture) first", vbCritical + vbOKOnly, "Enter Caption")
            Exit Sub
        End If
        
        
        'get caption from user
        sCaption = InputBox("Enter the caption for the selected item", "Enter Caption")
        If Trim(sCaption) = 0 Then Exit Sub
    
        If Selection.Type = wdSelectionInlineShape Then
          Selection.InlineShapes(1).ConvertToShape.WrapFormat.Type = wdWrapSquare
        End If
        sShapeName = Selection.ShapeRange(1).Name
    
    
        'add picture caption
        Selection.InsertCaption Label:="Figure", TitleAutoText:="", Title:=sCaption, Position:=wdCaptionPositionBelow, ExcludeLabel:=1
        
        'get rid of field with number
        Selection.HomeKey Unit:=wdLine
        Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        Selection.Delete Unit:=wdCharacter, Count:=1
        
        'get off text and leave textbox selected
        Selection.EscapeKey
        
        sCaptionName = Selection.ShapeRange(1).Name
         
        ActiveDocument.Shapes.Range(Array(sShapeName, sCaptionName)).Select
        Selection.ShapeRange.Group
        
    End Sub
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  3. #3
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    IMHO you'd do better to put the images & captions into floating tables, so you can ensure they always move together, using something like:
    Sub AddImageCaptionTables()
    Dim iShp As InlineShape, Rng As Range, Tbl As Table
    Dim i As Long, PicWdth As Single, PicHght As Single, VPos As Single
    Dim HPos As Single, VRel As Long, HRel As Long, BShp As Boolean
    With ActiveDocument
      For i = 1 To .InlineShapes.Count
        If .InlineShapes(i).Range.Information(wdWithInTable) = False Then
          PicWdth = .InlineShapes(i).Width
          Set Rng = .InlineShapes(i).Range
          With Rng
            If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString
            PicWdth = .InlineShapes(1).Width
            PicHght = .InlineShapes(1).Height
            .InlineShapes(1).Range.Cut
          End With
          BShp = False: VRel = 0: HRel = 0: VPos = 0: HPos = 0
          Call MakeImageTable(Rng, PicWdth, PicHght, BShp, VRel, HRel, VPos, HPos)
        End If
      Next
      While .Shapes.Count > 0
        BShp = True
        With .Shapes(1)
          PicWdth = .Width
          PicHght = .Height
          VRel = .RelativeVerticalPosition
          HRel = .RelativeHorizontalPosition
          VPos = .Top
          HPos = .Left
          Set iShp = .ConvertToInlineShape
        End With
        With iShp
          Set Rng = .Range
          .Range.Cut
        End With
        Call MakeImageTable(Rng, PicWdth, PicHght, BShp, VRel, HRel, VPos, HPos)
      Wend
    End With
    End Sub
     
    Sub MakeImageTable(Rng As Range, PicWdth As Single, PicHght As Single, BShp As Boolean, _
      VRel As Long, HRel As Long, VPos As Single, HPos As Single)
    Dim Tbl As Table
    'Create & format the table
    Set Tbl = Rng.Tables.Add(Range:=Rng, Numrows:=2, NumColumns:=1)
    With Tbl
      .Borders.Enable = True
      .Columns.Width = PicWdth
      .TopPadding = 0
      .BottomPadding = 0
      .LeftPadding = 0
      .RightPadding = 0
      .Spacing = 0
      .Rows(1).HeightRule = wdRowHeightExactly
      .Rows(1).Height = PicHght
      With .Rows
        .LeftIndent = 0
        If BShp = True Then
          .WrapAroundText = True
          .HorizontalPosition = HPos
          .RelativeHorizontalPosition = HRel
          .VerticalPosition = VPos
          .RelativeVerticalPosition = VRel
          .AllowOverlap = False
        End If
      End With
      With .Cell(1, 1).Range
        With .ParagraphFormat
          .SpaceBefore = 0
          .SpaceAfter = 0
          .LeftIndent = 0
          .RightIndent = 0
          .FirstLineIndent = 0
          .KeepWithNext = True
        End With
        .Paste
      End With
      With .Cell(2, 1).Range
        .Style = "Caption"
        .End = .End - 1
        .InsertAfter vbCr
        .InsertCaption Label:="Figure", TitleAutoText:=" ", Title:="", _
          Position:=wdCaptionPositionBelow, ExcludeLabel:=0
        .Paragraphs.First.Range.Characters.Last.Text = vbNullString
        .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
        .Borders(wdBorderRight).LineStyle = wdLineStyleNone
        .Borders(wdBorderTop).LineStyle = wdLineStyleNone
      End With
    End With
    End Sub
    The above code embeds all Shapes & InlineShapes in a document in tables as InlineShapes with a row for Captions. Whatever positioning applied to the original Shape object will apply to the table also. This arrangement has the advantage that captions in floating tables will show up in a Table of Figures, whereas captions in textboxes don't.

    To have the caption row appear above the image, instead of below, change the Rows(1) references to Rows(2), change the Cell(1, 1) references to Cell(2, 1) and change the change the Cell(2, 1) references to Cell(1, 1).

    To work with just the selected image (or multiple images in a selected range), change:
    With ActiveDocument
    to:
    With Selection
    and change:
      While .Shapes.Count > 0
        With .Shapes(1)
    to:
      While .ShapeRange.Count > 0
        With .ShapeRange(1)

    I haven't included code for the user to type in the caption while the code is running. That can be done post-reformatting and would be too error-prone (IMHO) if the code is processing multiple images.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  4. #4
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    Actually, I had Googled and found your other post from 2014


    http://www.msofficeforums.com/word-v...-document.html



    It has some advantages, but I started out thinking my need was much simpler since I wanted to do the captions one at a time.


    The table approach might be a better idea, so I'll have to see about blending some of what I have for one at a time with your table code




    This arrangement has the advantage that captions in floating tables will show up in a Table of Figures, whereas captions in textboxes don't.
    In 2016, it seems that selecting a Figure and then an Insert Caption, while it's a text box, will still show in a TOF
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  5. #5
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    Quote Originally Posted by Paul_Hossler View Post
    I started out thinking my need was much simpler since I wanted to do the captions one at a time.
    As indicated in my reply, the code is easily modified to work with one or more selected images only.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  6. #6
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    Quote Originally Posted by macropod View Post
    As indicated in my reply, the code is easily modified to work with one or more selected images only.


    The table approach might be a better idea, so I'll have to see about blending some of what I have for one at a time with your table code
    Yes, I saw that. I'll investigate
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  7. #7
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    Well, there's some progress.

    I used my 'selected shape' logic and your 'insert a table' and it works pretty good

    Couple of things I'm stuck on so I'd appreciate a (big) nudge

    1. Figure 1 is inline. How do I make the entire table square so it sits inside the paragraph like my manual PHB table?

    2. Figures 1 and 2 have a trailing paragraph in cell 2,1. How can I get rid of it?

    Thanks


    Capture.JPG



    Option Explicit
    Dim sCaption As String
    
    Sub AddImageCaptionTables()
        Dim iShp As InlineShape, Rng As Range, Tbl As Table
        Dim i As Long, PicWdth As Single, PicHght As Single, VPos As Single
        Dim HPos As Single, VRel As Long, HRel As Long, BShp As Boolean
        
        'get caption from user
        sCaption = InputBox("Enter the caption for the selected item", "Enter Caption")
        If Trim(sCaption) = 0 Then Exit Sub
    
        If Selection.Type = wdSelectionInlineShape Then
            Set iShp = Selection.InlineShapes(1)
                
            If iShp.Range.Information(wdWithInTable) = False Then
                PicWdth = iShp.Width
                Set Rng = iShp.Range
                With Rng
                    If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString
                    PicWdth = iShp.Width
                    PicHght = iShp.Height
                    iShp.Range.Cut
                End With
                BShp = False
                VRel = 0
                HRel = 0
                VPos = 0
                HPos = 0
                
                Call MakeImageTable(Rng, PicWdth, PicHght, BShp, VRel, HRel, VPos, HPos)
            End If
            
        ElseIf Selection.Type = wdSelectionShape Then
            BShp = True
            With Selection.ShapeRange
                PicWdth = .Width
                PicHght = .Height
                VRel = .RelativeVerticalPosition
                HRel = .RelativeHorizontalPosition
                VPos = .Top
                HPos = .Left
                Set iShp = .ConvertToInlineShape
            End With
            
            With iShp
                Set Rng = .Range
                .Range.Cut
            End With
            
            Call MakeImageTable(Rng, PicWdth, PicHght, BShp, VRel, HRel, VPos, HPos)
        
        Else
            Call MsgBox("Sorry, you have to select a Shape (or Picture) first", vbCritical + vbOKOnly, "Enter Caption")
        End If
        
    End Sub
     
    Sub MakeImageTable(Rng As Range, PicWdth As Single, PicHght As Single, BShp As Boolean, _
        VRel As Long, HRel As Long, VPos As Single, HPos As Single)
        Dim Tbl As Table
         'Create & format the table
        Set Tbl = Rng.Tables.Add(Range:=Rng, Numrows:=2, NumColumns:=1)
        With Tbl
            .Borders.Enable = False
            .Columns.Width = PicWdth
            .TopPadding = 0
            .BottomPadding = 0
            .LeftPadding = 0
            .RightPadding = 0
            .Spacing = 0
            .Rows(1).HeightRule = wdRowHeightExactly
            .Rows(1).Height = PicHght
            With .Rows
                .LeftIndent = 0
                If BShp = True Then
                    .WrapAroundText = True
                    .HorizontalPosition = HPos
                    .RelativeHorizontalPosition = HRel
                    .VerticalPosition = VPos
                    .RelativeVerticalPosition = VRel
                    .AllowOverlap = False
                End If
            End With
            With .Cell(1, 1).Range
                With .ParagraphFormat
                    .SpaceBefore = 0
                    .SpaceAfter = 0
                    .LeftIndent = 0
                    .RightIndent = 0
                    .FirstLineIndent = 0
                    .KeepWithNext = True
                End With
                .Paste
            End With
            With .Cell(2, 1).Range
                .Style = "Caption"
                .End = .End - 1
                .InsertAfter vbCr
                .InsertCaption Label:="Figure", TitleAutoText:=" ", Title:=" " & sCaption, Position:=wdCaptionPositionBelow, ExcludeLabel:=0
                .Paragraphs.First.Range.Characters.Last.Text = vbNullString
            End With
        End With
    End Sub
    Attached Files Attached Files
    Last edited by Paul_Hossler; 04-08-2017 at 01:36 PM. Reason: Left some old code in
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  8. #8
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    @macropod --

    I think I've got it

    I can select an Inline or Square shape and run you table macro on it and get some nice (to me anyway) results

    The captions seem to come out OK and the TOF works this way!!

    I still have a little cleanup and some commenting to do (before I forget) so that'll be the easy parts

    Capture.JPG

    Thanks for your help


    Option Explicit
    Dim sCaption As String
    
    Sub AddImageCaptionTables()
        Dim iShp As InlineShape, Rng As Range, Tbl As Table
        Dim i As Long, PicWdth As Single, PicHght As Single, VPos As Single
        Dim HPos As Single, VRel As Long, HRel As Long, BShp As Boolean
        
        
        'get caption from user
        sCaption = InputBox("Enter the caption for the selected item", "Enter Caption")
        If Trim(sCaption) = 0 Then Exit Sub
    
        If Selection.Type = wdSelectionInlineShape Then
            Set iShp = Selection.InlineShapes(1)
                
            If iShp.Range.Information(wdWithInTable) = False Then
                PicWdth = iShp.Width
                Set Rng = iShp.Range
                With Rng
                    If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString
                    PicWdth = iShp.Width
                    PicHght = iShp.Height
                    iShp.Range.Cut
                End With
                BShp = False
                VRel = 0
                HRel = 0
                VPos = 0
                HPos = 0
                
                Call MakeImageTable(Rng, PicWdth, PicHght, BShp, VRel, HRel, VPos, HPos)
            End If
            
        ElseIf Selection.Type = wdSelectionShape Then
            BShp = True
            With Selection.ShapeRange
                PicWdth = .Width
                PicHght = .Height
                VRel = .RelativeVerticalPosition
                HRel = .RelativeHorizontalPosition
                VPos = .Top
                HPos = .Left
                Set iShp = .ConvertToInlineShape
            End With
            
            With iShp
                Set Rng = .Range
                .Range.Cut
            End With
            
            Call MakeImageTable(Rng, PicWdth, PicHght, BShp, VRel, HRel, VPos, HPos)
        
        Else
            Call MsgBox("Sorry, you have to select a Shape (or Picture) first", vbCritical + vbOKOnly, "Enter Caption")
        End If
        
    End Sub
     
    Sub MakeImageTable(Rng As Range, PicWdth As Single, PicHght As Single, BShp As Boolean, _
        VRel As Long, HRel As Long, VPos As Single, HPos As Single)
        Dim Tbl As Table
         'Create & format the table
        Set Tbl = Rng.Tables.Add(Range:=Rng, Numrows:=2, NumColumns:=1)
        With Tbl
            .Borders.Enable = False
            .Columns.Width = PicWdth
            .TopPadding = 0
            .BottomPadding = 0
            .LeftPadding = 0
            .RightPadding = 0
            .Spacing = 0
            .Rows(1).HeightRule = wdRowHeightExactly
            .Rows(1).Height = PicHght
            With .Rows
                .WrapAroundText = True      '   PH
                .LeftIndent = 0
                If BShp = True Then
                    .HorizontalPosition = HPos
                    .RelativeHorizontalPosition = HRel
                    .VerticalPosition = VPos
                    .RelativeVerticalPosition = VRel
                    .AllowOverlap = False
                End If
            End With
            With .Cell(1, 1).Range
                With .ParagraphFormat
                    .SpaceBefore = 0
                    .SpaceAfter = 0
                    .LeftIndent = 0
                    .RightIndent = 0
                    .FirstLineIndent = 0
                    .KeepWithNext = True
                End With
                .Paste
            End With
            With .Cell(2, 1).Range
                .Style = "Caption"
                .End = .End - 1
                .InsertAfter vbCr
                .InsertCaption Label:="Figure", TitleAutoText:=" ", Title:=" " & sCaption, Position:=wdCaptionPositionBelow, ExcludeLabel:=0    '   PH
                .Paragraphs.First.Range.Characters.Last.Text = vbNullString
                .Paragraphs.Last.Range.Characters.Last.Text = vbNullString      '   PH
            End With
        End With
    End Sub
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  9. #9
    I'd just like to thank you all for this thread.

    I was looking for something which could answer a similar query and this answered it.

    Thanks again!

    Roderick

  10. #10
    Continuing my earlier post above, I've got a challenge when using the code in one of my templates.

    If I put Paul's final coding into a test .dotm it works perfectly every time. Thanks!

    I then transfer the code to one of my .dotm templates expecting it to run the same as the test template but it doesn't. Well, it works OK if the picture is an inline shape but when it is a shape it fails.

    The code is below:
    ElseIf Selection.Type = wdSelectionShape Then
            BShp = True
            With Selection.ShapeRange
                PicWdth = .Width
                PicHght = .Height
                VRel = .RelativeVerticalPosition
                HRel = .RelativeHorizontalPosition
                VPos = .Top
                HPos = .Left
                Set iShp = .ConvertToInlineShape
            End With
            
            With iShp
                Set Rng = .Range
                .Range.Cut
            End With
    Everything seems to work up to the point where it meets '.Range.Cut' when instead of cutting it to the clipboard it seems to just delete it as it doesn't seem to have arrived at the clipboard, therefore an error comes up when it's going to be pasted into the receiving table cell.

    I've changed the code in all ways but still the picture does not get placed in the clipboard. I cannot understand it as it worked well in my test template.

    Any thoughts or suggestions, please?

  11. #11
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    I'd have thought that a DOTM is a DOTM

    Can you attachment your DOTM - delete anything not needed to show the issue
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  12. #12
    Thanks for your post, Paul.

    As it is a client's template, I went to them for permission to post online but, regrettably, they said 'No.' Oh well...

    I agree with you: a .dotm is a.dotm, so what's the difference here? As it works in a clean and simple template with no other procedures in it, I can only come to the idea that there is something in my template which is causing it to go silly when it's not an inline shape.

    As I mentioned earlier, this part, with inline shapes, works perfectly.

    I've got a procedure already which I have been using, but I much prefer this table structure. I'm going to keep playing with it and see if I can find a solution. I'll export it to another template and see what happens.

    By the way, I'm using Windows 7 and Word 2013.

    I'n the meantime, thanks again for the coding above!

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •