Insert photo gps information in column next to photo

[Belinda Burton]

Hello,



I'm looking for a way to insert multiple pictures into a two column table that sets each photos width to a specified size and locks the aspect ratio for the height allowing one picture per row and adding rows as needed. I then need to insert the information about the gps location of the picture into the second column for each picture. I have this information in the file detail area of each photo when I go into properties. I have found an amazing macro on here that works well for inserting the photos into a table below. I'm completely new to macros and not sure how to change captioning the picture so that it includes the gps data instead and how to put this information in the column next to the picture instead of the row below. Any help or suggestions would be immensely appreciated.

Sub AddPicsWithCaption()
'Sourced from: https://www.msofficeforums.com/drawi...-document.html
Application.ScreenUpdating = False
Dim Stl As Style, i As Long, j As Long, c As Long, r As Long, NumCols As Long, iShp As InlineShape
Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single, ColWdth As Single
With ActiveDocument.PageSetup
  TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
End With
On Error GoTo ErrExit
NumCols = CLng(InputBox("How Many Columns per Row?"))
ColWdth = PointsToCentimeters(TblWdth / NumCols)
ColWdth = CentimetersToPoints(CSng(InputBox("What max width for the pictures, in Centimeters (e.g. " & Format(ColWdth, "0.00") & ")?")))
RwHght = CentimetersToPoints(CSng(InputBox("What max height for the pictures, in Centimeters (e.g. 5)?")))
On Error GoTo 0
'Select and insert the Pics
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
    'Create a paragraph Style with 0 space before/after & centre-aligned
    With ActiveDocument
      On Error Resume Next
      Set Stl = .Styles("TblPic")
     If Stl Is Nothing Then Set Stl = .Styles.Add(Name:="TblPic", Type:=wdStyleTypeParagraph)
      On Error GoTo 0
      With .Styles("TblPic").ParagraphFormat
        .Alignment = wdAlignParagraphCenter
        .KeepWithNext = True
        .SpaceAfter = 0
        .SpaceBefore = 0
      End With
    End With
    'Add a 2-row by NumCols-column table to take the images
    Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=2, NumColumns:=NumCols)
    With oTbl
      .AutoFitBehavior (wdAutoFitFixed)
      .TopPadding = 0
      .BottomPadding = 0
      .LeftPadding = 0
      .RightPadding = 0
      .Spacing = 0
      .Columns.Width = ColWdth
      .Borders.Enable = True
    End With
    CaptionLabels.Add Name:="Picture"
    For i = 1 To .SelectedItems.Count Step NumCols
      r = oTbl.Rows.Count - 1
      'Format the rows
      Call FormatRows(oTbl, r, RwHght)
      For c = 1 To NumCols
        j = j + 1
        'Insert the Picture
        Set iShp = ActiveDocument.InlineShapes.AddPicture( _
          FileName:=.SelectedItems(j), LinkToFile:=False, _
          SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range)
        With iShp
          .LockAspectRatio = True
          If (.Width < ColWdth) And (.Height < RwHght) Then
            .Width = ColWdth
            If .Height > RwHght Then .Height = RwHght
          End If
        End With
        'Get the Image name for the Caption
        StrTxt = Split(.SelectedItems(j), "")(UBound(Split(.SelectedItems(j), "")))
        StrTxt = ": " & Split(StrTxt, ".")(0)
        'Insert the Caption on the row below the picture
        With oTbl.Cell(r + 1, c).Range
          .InsertBefore vbCr
          .Characters.First.InsertCaption _
          Label:="Picture", Title:=StrTxt, _
          Position:=wdCaptionPositionBelow, ExcludeLabel:=False
          .Characters.First = vbNullString
          .Characters.Last.Previous = vbNullString
        End With
        'Exit when we're done
        If j = .SelectedItems.Count Then Exit For
      Next
      'Add extra rows as needed
      If j < .SelectedItems.Count Then
        oTbl.Rows.Add
        oTbl.Rows.Add
      End If
    Next
  Else
  End If
End With
ErrExit:
Application.ScreenUpdating = True
End Sub

Sub FormatRows(oTbl As Table, x As Long, Hght As Single)
With oTbl
  With .Rows(x)
    .Height = Hght
    .HeightRule = wdRowHeightExactly
    .Range.Style = "TblPic"
    .Cells.VerticalAlignment = wdCellAlignVerticalCenter
  End With
  With .Rows(x + 1)
    .Height = CentimetersToPoints(0.5)
    .HeightRule = wdRowHeightExactly
    .Range.Style = "Caption"
  End With
End With
End Sub

[gmaxey]

You will need to add the reference indicated:

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
  sngColWdth = 340
  sngRowHght = 140
  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 stet a reeference to Microsoft Shell Controls and Automation
Dim objShell As New Shell
Dim oFSO As Object, oFile As Object, oFolder As Object
Dim varLat, varLng, strLat, strLong
Dim strFolder As String, strFile As String
  Set oFSO = CreateObject("Scripting.FileSystemObject")
  Set oFile = oFSO.GetFile(strPath)
  strFile = oFile.Name
  strFolder = oFile.ParentFolder.Path
  Select Case oFile.Type
    Case "JPEG File", "PNG File", "GIF File", "JPG File", "BMP File"
      Set oFolder = objShell.Namespace(strFolder)
      Set oFile = oFolder.ParseName(strFile)
      varLat = oFile.ExtendedProperty("{8727CFFF-4868-4EC6-AD5B-81B98521D1AB}100")
      varLng = oFile.ExtendedProperty("{C4C4DBB2-B593-466B-BBDA-D03D27D5E43A}100")
      If Not IsEmpty(varLat) Then
        strLat = varLat(0) & Chr(176) & varLat(1) & "'" & Format(varLat(2), "0.00") & """"
      Else
        strLat = 0
      End If
      If Not IsEmpty(varLng) Then
        strLong = varLng(0) & Chr(176) & varLng(1) & "'" & Format(varLng(2), "0.00") & """"
      Else
        strLong = 0
      End If
      fcnGetGPSInfo = "Lat: " & strLat & vbCr & "Long: " & strLong
      Set oFile = Nothing
      Set oFolder = Nothing
  End Select
lbl_Exit:
  Exit Function
End Function

[gmaxey]

Note: In the function fcnGetGPSInfo,


varLat and varLng return arrays with 1) Degrees, 2) Minutes and 3) Seconds and fractional seconds. You may need or want to change the format returned.

[macropod]

See: https://www.msofficeforums.com/word-...ordinates.html
The code there assumes that the file list is in an Excel workbook, but the code in red can easily be added to the generic code in:
https://www.msofficeforums.com/drawi...-document.html

[gmaxey]

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:

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