Consulting

Results 1 to 10 of 10

Thread: Word AddPics macro mod help

  1. #1

    Word AddPics macro mod help

    Hello guys! Hope everybody is OK


    I wanted to ask you for some help with modifications, since I'm a total newbie. Got a macro from an old thread solved by macropod, this one:


    Sub AddPics()
        Application.ScreenUpdating = False
        Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long
        Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single
        On Error GoTo ErrExit
        NumCols = CLng(InputBox("How Many Columns per Row?"))
        RwHght = CSng(InputBox("What row height for the pictures, in inches (e.g. 1.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
                '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
                End With
                With oTbl
                    .AutoFitBehavior (wdAutoFitFixed)
                    .Columns.Width = TblWdth / NumCols
                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
                        ActiveDocument.InlineShapes.AddPicture _
                            FileName:=.SelectedItems(j), LinkToFile:=False, _
                            SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range
                        '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:="Foto", 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 = InchesToPoints(Hght)
                .HeightRule = wdRowHeightExactly
                .Range.Style = "Normal"
            End With
            With .Rows(x + 1)
                .Height = CentimetersToPoints(0.5)
                .HeightRule = wdRowHeightExactly
                .Range.Style = "Caption"
            End With
        End With
    End Sub


    It helped me a lot, but I need to make some modifications, and don't know where to begin.
    I work with botany, so my reports are sometimes huge, with hundreds of images. I wanted to change the caption, from "Image number - file name" to "Image number - tree number".
    I'm now doing this line by line, very very boring, with fields:


    It's always the same, at left photo of the tree, at right photo of the number tag. Sometimes, the specimens are not numbered begining with "1". See example:
    vba-forum.jpg


    The number of specimen is repeated, but the photo number is continuous... I am using fields now: "SEQ Step \r #" in first caption cell, "SEQ Step \c" in number tag cell; the following cells are all "SEQ Step \n" in next specimen photo, and repeat "SEQ Step \c" in number tags.

    Thank you in advance for your atention and, if possible, help!!

  2. #2
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,293
    Location
    So where would the macro get the tree number from?
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  3. #3
    I could number the first one, others would be sequel

  4. #4
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,293
    Location
    Try the following, which is based on a more recent version of the code than what you've been using. Note the changes in bold

    Sub AddPics()
        Application.ScreenUpdating = False    Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long
        Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single
        On Error GoTo ErrExit
        NumCols = CLng(InputBox("How Many Columns per Row?"))
        RwHght = CSng(InputBox("What row height for the pictures, in inches (e.g. 1.5)?"))
        On Error Resume Next
        CaptionLabels.Add Name:="Foto"
        ActiveDocument.Styles.Add Name:="TblPic", Type:=wdStyleTypeParagraph
        On Error GoTo 0
        With ActiveDocument.Styles("TblPic").ParagraphFormat
            .Alignment = wdAlignParagraphCenter
            .SpaceAfter = 0
            .SpaceBefore = 0
        End With
        '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
                '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
                End With
                With oTbl
                    .AutoFitBehavior (wdAutoFitFixed)
                    .Columns.Width = TblWdth / NumCols
                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
                        ActiveDocument.InlineShapes.AddPicture _
                            FileName:=.SelectedItems(j), LinkToFile:=False, _
                            SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range
                        'Add descriptive text for the Caption
                        StrTxt = ": Exemplar " & ChrW(8470) & " "
                        'Insert the Caption on the row below the picture
                        With oTbl.Cell(r + 1, c).Range
                            .InsertBefore vbCr
                            .Characters.First.InsertCaption _
                            Label:="Foto", Title:=StrTxt, _
                            Position:=wdCaptionPositionBelow, ExcludeLabel:=False
                            .Characters.First = vbNullString
                            '.Characters.Last.Previous = vbNullString
                            .Fields.Add Range:=.Characters.Last.Previous, Type:=wdFieldEmpty, _
                              Text:="SEQ Nr \c", PreserveFormatting:=False
                        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 = InchesToPoints(Hght)
                .HeightRule = wdRowHeightExactly
                .Range.Style = "TblPic"
                .Cells.VerticalAlignment = wdCellAlignVerticalCenter
            End With
            With .Rows(x + 1)
                .Height = InchesToPoints(0.25)
                .HeightRule = wdRowHeightExactly
                .Range.Style = "Caption"
            End With
        End With
    End Sub
    Last edited by macropod; 03-31-2021 at 04:22 AM.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  5. #5
    Hi Macropod, my hero hahahah

    Tested here, didn't work for me, guess Word isn't recognizing numeral symbol ChrW(2116), it returns "Exemplar 0ࡄ".
    vba-forum2.jpg
    With your initial huge step, I'll try to change that part here, if it works, let you know!

    Thanks a lot

  6. #6
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,293
    Location
    I've revised the № character reference. Try the code now.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  7. #7
    Now the "Nș" is working fine!

    But I didn't understand how this field is going to work, since they all have the same code.

    The 1st caption has to be "SEQ Nr \r #", being # the number of the first tree.
    The 2nd caption, as every other captions in right column, "SEQ Nr \c".

    Now the 3rd, and all of the following left column captions, gotta be "SEQ Nr \n", sequel following the first tree number.Don't know if that is possible with vba...

  8. #8
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,272
    Location
    Paul, I'm missing something. When I use your code to insert say four photos, the captions read Foto 1, Exemplar No0 Foto 2, Exemplar No0 Foto 3, Exemplar No0 Foto 4, Exemplar No0

    and it appears you Seq field {SEQ Nr \c} would display the number of the nearest of the Seq field.
    Greg

    Visit my website: http://gregmaxey.com

  9. #9
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,293
    Location
    Quote Originally Posted by belmartin View Post
    But I didn't understand how this field is going to work, since they all have the same code.

    The 1st caption has to be "SEQ Nr \r #", being # the number of the first tree.
    The 2nd caption, as every other captions in right column, "SEQ Nr \c".

    Now the 3rd, and all of the following left column captions, gotta be "SEQ Nr \n", sequel following the first tree number.Don't know if that is possible with vba...
    I previously asked:
    Quote Originally Posted by macropod View Post
    So where would the macro get the tree number from?
    to which you replied:
    Quote Originally Posted by belmartin View Post
    I could number the first one, others would be sequel
    Your reply suggested that you would simply edit the SEQ fields to supply whatever number is appropriate for the tree for any given series of photos, which the SEQ would repeat until you edit another SEQ field to supply another tree number. Naturally, you would need to refresh the field display after doing this.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  10. #10
    Sorry, guess I wasn't clear.

    OK, thank you anyway! Gonna try to make the changes I need.


Tags for this Thread

Posting Permissions

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