View Single Post
 
Old 11-11-2024, 12:27 PM
gmaxey gmaxey is offline Windows 10 Office 2019
Expert
 
Join Date: May 2010
Location: Brasstown, NC
Posts: 1,598
gmaxey is just really nicegmaxey is just really nicegmaxey is just really nicegmaxey is just really nicegmaxey is just really nice
Default

Belinda,


Paul has provided a less complicated method of extracting the GPS data. I have tried to tailor his code more to your specific requirements:


Code:
Option Explicit
Sub AddPicsWithGPSCoordinates()
Dim 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. Suited for landscape oriented photos. Modify here or use the original input box method.
  sngColWdth = 320
  sngRowHght = 200
  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
      Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=1, NumColumns:=2)
      With oTbl
        .AutoFitBehavior wdAutoFitFixed
        .TopPadding = 2
        .BottomPadding = 2
        .LeftPadding = 0
        .RightPadding = 0
        .Spacing = 0
        .Columns(2).Width = sngTblWidth - sngColWdth
        .Columns(1).Width = sngColWdth
        .Borders.Enable = True
        With .Rows(1)
          .Cells(2).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
          .Height = sngRowHght
          .HeightRule = wdRowHeightExactly
          .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 GPS data
        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
  fcnGetGPSInfo = "Not" & vbCr & "Defined"
  strLat = "": NS = "": strLong = "": 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
  If strLat <> vbNullString Then fcnGetGPSInfo = strLat & vbCr & strLong
  Set WIAFile = Nothing
lbl_Exit:
  Exit Function
End Function
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote