Sub threePPg()
'
' threePPg Macro
' Macro recorded 3/14/2008
'
    Selection.MoveDown Unit:=wdLine, Count:=1
    Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.Rows.Delete
    Selection.TypeBackspace
    Application.DisplayAutoCompleteTips = True
    ActiveDocument.AttachedTemplate.AutoTextEntries("3Ppg").Insert Where:= _
        Selection.Range, RichText:=True
    Selection.TypeBackspace
    ActiveDocument.AttachedTemplate.AutoTextEntries("addmore").Insert Where:= _
        Selection.Range, RichText:=True
    Selection.TypeBackspace
    
    'Variables

Dim FSO As FileSystemObject
   Dim fol As Folder
    Dim pic As File
    Dim tbl As Table
    Dim roe As Row
    Dim cel As Cell
    Dim ish As InlineShape
    Dim pth As New MSComDlg.CommonDialog
    Dim r As Integer
    Dim t As Integer
    Dim objExif As New ExifReader
    Dim txtExifInfo As String
    
        
entry = 0
'Browse to folder
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    If .Show = -1 Then
        pname = .SelectedItems(1)
    Else
        MsgBox "You pressed Cancel"
        Exit Sub
    End If
End With

'file path for pictures
    Set FSO = New FileSystemObject
    Set fol = FSO.GetFolder(pname)

'set row 1 as header for each page
    Set tbl = ActiveDocument.Range.Tables(1)
          ActiveDocument.Tables(1).Rows(1).HeadingFormat = True

'FILLING IN TABLE
    For Each pic In fol.Files
        If LCase(Right(pic.Path, 4)) = ".jpg" Or LCase(Right(pic.Path, 5)) = ".jpeg" Then
            'add row and give reference to it
            Set roe = ActiveDocument.Tables(1).Rows.Add
            'ActiveDocument.Tables(1).Rows(entry).Select
            'entry = entry + 1
            'gives reference to cell 1 then adds text
            Set cel = roe.Cells(1)
            cel.Range.Text = pic.Name
            entry = entry + 1
            
            objExif.Load pic.Path
            '
            'FILL IN THE CELL INFORMATION
            '
            'Selection.MoveDown Unit:=wdLine, Count:=4, Extend:=wdExtend
            'Selection.Delete Unit:=wdCharacter, Count:=1
cel.Range.Text = pic.Name & vbCr & objExif.Tag(Model) & vbCr & pic.DateLastModified & vbCr & pic.Size & " Bytes"
             'gives reference to cell 3 then adds pic
              Set cel = roe.Cells(3)
             'add photo
             Set ish = cel.Range.InlineShapes.AddPicture(FileName:=pic.Path, LinkToFile:=False, SaveWithDocument:=True)
             'add hyperlink..."text" would place text as the hyperlink
             Set MyLink = ActiveDocument.Range.Hyperlinks.Add(ish, pic.Name, , , "")
        End If
    Next
    ActiveDocument.Tables(1).Rows(2).Delete

End Sub