View Single Post
 
Old 11-11-2024, 07:12 AM
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

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
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote