Code:
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