Paul,
Thanks for posting the alternate Windows Image Acquisition Library method. I did not look or realize the original code was yours. I tried to adapt it to fit the requirement of the user (without having to choose columns count and image size each time). Here is my first attempt modified with your better method of extracting the coordinates:
Code:
Option Explicit
Sub AddPicsWithGPSCoordinates()
Dim oStyle As Style, lngIndex As Long, oShp As InlineShape
Dim oTbl As Table, sngTblWidth As Single, strGPS As String, sngRowHght As Single, sngColWdth As Single
Application.ScreenUpdating = False
With ActiveDocument.PageSetup
sngTblWidth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
End With
'These are fixed values in points. You can modify here or use the original input box method.
sngColWdth = 300
sngRowHght = 180
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
With ActiveDocument
On Error Resume Next
Set oStyle = .Styles("TblPic")
If oStyle Is Nothing Then Set oStyle = .Styles.Add(Name:="TblPic", Type:=wdStyleTypeParagraph)
On Error GoTo 0
With oStyle.ParagraphFormat
.Alignment = wdAlignParagraphCenter
.KeepWithNext = True
.SpaceAfter = 0
.SpaceBefore = 0
End With
End With
Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=1, NumColumns:=2)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.TopPadding = 0
.BottomPadding = 0
.LeftPadding = 0
.RightPadding = 0
.Spacing = 0
.Columns(1).Width = sngColWdth
.Columns(2).Width = sngTblWidth - sngColWdth
.Borders.Enable = True
With .Rows(1)
.Height = sngRowHght
.HeightRule = wdRowHeightExactly
.Range.Style = "TblPic"
.Cells.VerticalAlignment = wdCellAlignVerticalCenter
End With
End With
For lngIndex = 1 To .SelectedItems.Count
'Insert the Picture
Set oShp = ActiveDocument.InlineShapes.AddPicture( _
FileName:=.SelectedItems(lngIndex), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oTbl.Cell(lngIndex, 1).Range)
With oShp
.LockAspectRatio = True
If (.Width < sngColWdth) And (.Height < sngRowHght) Then
.Width = sngColWdth
If .Height > sngRowHght Then .Height = sngRowHght
End If
End With
'Get the Image name for the Caption
strGPS = fcnGetGPSInfo(.SelectedItems(lngIndex))
oTbl.Cell(lngIndex, 2).Range.Text = "Location" & vbCr & strGPS
oTbl.Rows.Add
Next lngIndex
oTbl.Rows.Last.Delete
End If
End With
ErrExit:
Application.ScreenUpdating = True
End Sub
Function fcnGetGPSInfo(strPath) As String
'You will need to set a reeference to Microsoft Windows Image Acquisition library
Dim WIAFile As Object, WIAProp As Object
Dim strLat As String, NS As String, strLong As String, EW As String
strLat = "N/A": NS = "": strLong = "N/A": EW = ""
Set WIAFile = CreateObject("WIA.ImageFile")
WIAFile.LoadFile strPath
With WIAFile
If .Properties.Exists("GpsLongitudeRef") Then NS = .Properties("GpsLongitudeRef").Value
If .Properties.Exists("GpsLongitude") Then
With .Properties("GpsLongitude")
'Seconds rounded to four decimal places
strLong = NS & .Value(1) & Chr(186) & .Value(2) & Chr(39) & Format(.Value(3), "0.0000") & Chr(34)
'strLong = NS & .Value(1) + .Value(2) / 60 + .Value(3) / 3600
End With
End If
If .Properties.Exists("GpsLatitudeRef") Then EW = .Properties("GpsLatitudeRef").Value
If .Properties.Exists("GpsLatitude") Then
With .Properties("GpsLatitude")
'Seconds rounded to four decimal places
strLat = EW & .Value(1) & Chr(186) & .Value(2) & Chr(39) & Format(.Value(3), "0.0000") & Chr(34)
'StrLat = EW & .Value(1) + .Value(2) / 60 + .Value(3) / 3600
End With
End If
End With
fcnGetGPSInfo = strLat & vbCr & strLong
Set WIAFile = Nothing
lbl_Exit:
Exit Function
End Function