Consulting

Results 1 to 4 of 4

Thread: Macro Picture Insert Code to include Filename

  1. #1

    Macro Picture Insert Code to include Filename

    Hi all,

    I have a working code that imports selective photos 2 x 3 and provides a caption stating "Picture #" below each imported Photo. I am looking to keep everything the same except change the caption to state the "Filename" without the file extensions. Any help would be greatly appreciated. Thanks much!

    The code is as specified below:

    [VBA] 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 = 2
    RwHght = 2.7
    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 = InchesToPoints(3.51)
    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
    'Insert the Caption on the row below the picture
    With oTbl.Cell(r + 1, c).Range
    .InsertBefore vbCr
    .Characters.First.InsertCaption _
    Label:="Picture", 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.75)
    .HeightRule = wdRowHeightExactly
    .Range.Style = "Caption"
    End With
    End With
    End Sub
    [/VBA]

  2. #2
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    3,888
    Location
    Quote Originally Posted by Brandon.wong View Post
    I have a working code that imports selective photos
    It would be nice if you actually gave some recognition to where you sourced the code. It's also pretty obvious someone's edited the code to delete the part that inserts the filename. See, for example:http://www.vbaexpress.com/forum/show...l-row&p=367931


    Finally, when posting code, please use the code tags (not VBA tags), indicated by the # button on the posting menu. Without them, your posted code loses much of whatever structure it had.
    Cheers
    Paul Edstein
    [MS MVP - Word]

  4. #4
    Quote Originally Posted by macropod View Post
    It would be nice if you actually gave some recognition to where you sourced the code. It's also pretty obvious someone's edited the code to delete the part that inserts the filename.

    Finally, when posting code, please use the code tags (not VBA tags), indicated by the # button on the posting menu. Without them, your posted code loses much of whatever structure it had.
    Macropod - Thank you for providing your assistance. My apologizes for not knowing the originating source. This code was "created" by my co-worker who recently left our company.

    Graham - I am looking for a macro type solution rather than an add-on package. Thank you for your recommendation and input.

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
  •