Abdullah
02-09-2009, 07:12 AM
Hi Guys,
I have a template that prompts the user to walk it to a folder that contains photos.
The program searches the folder with any .jpg or .jpeg file and puts it in a table.
The table is 3 columns (column 1 is photo info [date/time/camera used/file name] column 2 is blank [left for descriptions] and column 3 gets the photo and hyperlink to the file)
Its been working, but now it will sometimes give me a runtime 6 overflow error.
I thought it was due to a large number of .jpg files, but when the folder has only a few, or even just 1 it gives the overflow error.
The code in its entirety is below, you have to start with an empty row of 3 columns for it to properly run.
Sub phot()
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
The line causing the overflow is
objExif.Load pic.Path
I'm not sure how to resolve the error. Any help would be greatly appreciated.
I have a template that prompts the user to walk it to a folder that contains photos.
The program searches the folder with any .jpg or .jpeg file and puts it in a table.
The table is 3 columns (column 1 is photo info [date/time/camera used/file name] column 2 is blank [left for descriptions] and column 3 gets the photo and hyperlink to the file)
Its been working, but now it will sometimes give me a runtime 6 overflow error.
I thought it was due to a large number of .jpg files, but when the folder has only a few, or even just 1 it gives the overflow error.
The code in its entirety is below, you have to start with an empty row of 3 columns for it to properly run.
Sub phot()
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
The line causing the overflow is
objExif.Load pic.Path
I'm not sure how to resolve the error. Any help would be greatly appreciated.