none
Wish to print FILENAMES of each graphic file underneath its thumbail image RRS feed

  • Question

  • Hello, my friends. I use the following macro to create a table of thumbnail images (same size) in a table.

    However, it would be perfect I can have it print the corresponding filenames under each thumbnail image.

    Could anyone please teach me how to modify the macro to do that?

    The source of this macro: https://wordribbon.tips.net/T008023_Printing_Graphic_Thumbnails.html

    I appreciate wordribbon.tips.net.

    --------------

    Sub Thumbnails() Dim Directory As String Dim FType As String Dim FName As String Dim ColCount As Integer Directory = "d:\temp" FType = "*.jpg" ChDir Directory FName = Dir(FType) If FName <> "" Then Documents.Add ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=1, _ NumColumns:=5 Selection.Tables(1).Select Selection.Cells.HeightRule = wdRowHeightAuto With Selection.Rows .Alignment = wdAlignRowCenter .AllowBreakAcrossPages = False .SetLeftIndent LeftIndent:=InchesToPoints(0), RulerStyle:= _ wdAdjustNone End With Selection.HomeKey Unit:=wdLine ColCount = 1 End If Do While FName <> "" Selection.InlineShapes.AddPicture FileName:=FName, _ LinkToFile:=False, SaveWithDocument:=True Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter Selection.TypeParagraph With Selection.Font .Name = "Arial" .Size = 10 .Bold = True End With Selection.TypeText Text:=Mid$(FName, Len(Directory) + 2) Selection.MoveRight Unit:=wdCharacter, Count:=1 ColCount = ColCount + 1 If ColCount = 6 Then Selection.InsertRows 1 Selection.EndKey Unit:=wdLine Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.InsertRows 1 Selection.HomeKey Unit:=wdLine ColCount = 1 End If FName = Dir Loop End Sub

    Saturday, May 12, 2018 2:09 PM

All replies

  • You could simply use http://www.gmayor.com/photo_gallery_template.html  which would do the job or to modify your macro

    Option Explicit
    
    Sub Thumbnails()
    Dim Directory As String
    Dim FType As String
    Dim FName As String
    Dim oCell As Range
    Dim ColCount As Integer, RowCount As Integer
    
        Directory = "D:\Temp\"
        FType = "*.jpg"
    
        ChDir Directory
        FName = Dir(FType)
        If FName <> "" Then
            Documents.Add
            ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=1, _
                                      NumColumns:=5
            Selection.Tables(1).Select
            Selection.Cells.HeightRule = wdRowHeightAuto
            With Selection.Rows
                .Alignment = wdAlignRowCenter
                .AllowBreakAcrossPages = False
                .SetLeftIndent LeftIndent:=InchesToPoints(0), RulerStyle:= _
                               wdAdjustNone
            End With
            Selection.HomeKey Unit:=wdLine
            ColCount = 1: RowCount = 1
        End If
    
        Do While FName <> ""
            Set oCell = ActiveDocument.Tables(1).Cell(RowCount, ColCount).Range
            oCell.End = oCell.End - 1
            oCell.InlineShapes.AddPicture _
                    FileName:=FName, _
                    LinkToFile:=False, _
                    SaveWithDocument:=True
            oCell.End = ActiveDocument.Tables(1).Cell(RowCount, ColCount).Range.End - 1
            oCell.Collapse 0
            With oCell
                .Text = vbCr & FName
                .ParagraphFormat.Alignment = wdAlignParagraphCenter
                With .Font
                    .Name = "Arial"
                    .Size = 10
                    .Bold = True
                End With
            End With
            ColCount = ColCount + 1
            If ColCount = 6 Then
                ActiveDocument.Tables(1).Rows.Add
                ColCount = 1: RowCount = RowCount + 1
            End If
            FName = Dir
        Loop
    End Sub
    
    


    Graham Mayor - Word MVP
    www.gmayor.com

    Sunday, May 13, 2018 5:04 AM
  • Wow, it is Graham Mayor! Such an honor, Sir. I got to know you in 1997 when I joined your email discussion group - Wordtip. I got a large word document titled Word Find & Replace, which I believe was written by you. I lost contact with that discussion group as my email address kept changing. Now I am glad to find it back. 

    I just tested your modified macro, and it works like a charm! You saved my life, Graham. thank you so much.

    I also downloaded that template you suggested. I am gonna test it soon. 

    Thanks again, sir. You've made my day

    Bluebird

    Chengdu, Sichuan, china


    Sunday, May 13, 2018 12:37 PM