![]() |
#1
|
|||
|
|||
![]()
Hi there,
I have been using the code from https://www.msofficeforums.com/word-...sertReportPics and it has been extremely useful. I am wondering if it is possible to pull the GPS information from the Picture itself and post it in below the picture similar to how the captions are. I am involved in a project now that would require us to label each photo with their coordinates and it has been a nightmare to manually type them all out. Thanks! Last edited by macropod; 12-06-2022 at 08:35 PM. Reason: Split to new thread |
#2
|
||||
|
||||
![]()
Are the GPS data in fact stored in the images? If so, under what file property/properties are they stored. If not, where are they stored?
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
||||
|
||||
![]()
It should be possible. Are you able to work it out looking at this source?
Getting Image Properties (Exif Metadata) Using WIA in VBA
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#4
|
|||
|
|||
![]()
Yup! The location information is in the metadata, under GPS with the Long and Lats.
I have tried looking at some of the other VBA codes to pull this information. However, I have no idea how to incorporate it in this "picture importer". Any help is much appreciated! |
#5
|
||||
|
||||
![]()
The code provided by omegastripes on this stackoverflow thread works when the image has the GPS data on it
Excel VBA open folder and get GPS info (Exif) of each files in it (2) - Stack Overflow The code was using late binding to make use of a library called 'Microsoft Windows Image Acquisition Library' Code:
Sub Test() With CreateObject("WIA.ImageFile") .LoadFile "C:\Test\image.jpg" With .Properties("GpsLatitude").Value Debug.Print .Item(1).Value + .Item(2).Value / 60 + .Item(3).Value / 3600 End With With .Properties("GpsLongitude").Value Debug.Print .Item(1).Value + .Item(2).Value / 60 + .Item(3).Value / 3600 End With End With End Sub
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#6
|
||||
|
||||
![]()
Fuzzyants: Do you want the output in degrees, minutes, seconds format, or as decimal degrees?
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#7
|
||||
|
||||
![]()
The following code will extract the GPS co-ordinates, where available in the image file and insert them in the same cell as the caption, but below it. Note the changes to the original code in red.
Code:
Sub AddPics() Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String Dim StrRpt As String, StrDocPath As String, StrPicPath As String, xlFList As String, xlCList As String Dim iDataRow As Long, c As Long, r As Long, i As Long, j As Long, k As Long, NumCols As Long Dim iShp As InlineShape, oTbl As Table, TblWdth As Single, RwHght As Single, ColWdth As Single StrWkBkNm = "Workbook path & name" StrDocPath = ActiveDocument.Path StrRpt = Right(StrDocPath, Len(StrDocPath) - InStrRev(StrDocPath, "\")) StrWkSht = StrRpt & " Observations" StrPicPath = StrDocPath & "\" & StrRpt & " Report Photos\" If Dir(StrWkBkNm) = "" Then MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation Exit Sub End If On Error GoTo ErrExit NumCols = CLng(InputBox("How Many Columns per Row?")) RwHght = CentimetersToPoints(CSng(InputBox("What max height for the pictures, in centimeters (e.g. 5)?"))) On Error GoTo 0: On Error Resume Next 'Start Excel Set xlApp = CreateObject("Excel.Application") If xlApp Is Nothing Then MsgBox "Can't start Excel.", vbExclamation Exit Sub End If On Error GoTo 0 With xlApp 'Hide our Excel session .Visible = False ' The file is available, so open it. Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=True, AddToMru:=False) If xlWkBk Is Nothing Then MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation .Quit: Exit Sub End If ' Process the workbook. With xlWkBk 'Ensure the worksheet exists If SheetExists(xlWkBk, StrWkSht) = True Then With .Worksheets(StrWkSht) ' Find the last-used row in column A. iDataRow = .Cells(.Rows.Count, 14).End(-4162).Row ' -4162 = xlUp ' Capture the F/R data. For i = 2 To iDataRow ' Skip over empty fields to preserve the underlying cell contents. If Trim(.Range("N" & i)) <> vbNullString Then xlFList = xlFList & "|" & Trim(.Range("N" & i)) xlCList = xlCList & "|" & Trim(.Range("Q" & i)) End If Next End With Else MsgBox "Cannot find the designated worksheet: " & StrWkSht, vbExclamation End If .Close False End With .Quit End With ' Release Excel object memory Set xlWkBk = Nothing: Set xlApp = Nothing 'Exit if there are no data If xlFList = "" Then Exit Sub 'Initialise the 'Microsoft Windows Image Acquisition' library Dim WIAFile As Object, WIAProp As Object: Set WIAFile = CreateObject("WIA.ImageFile") Dim StrNm As String, StrLon As String, EW As String, StrLat As String, NS As String With ActiveDocument For i = 1 To .Styles.Count With .Styles(i) If .Name = "TblPic" Then bFnd = False: Exit For End With Next If bFnd = False Then .Styles.Add Name:="TblPic", Type:=wdStyleTypeParagraph With .Styles("TblPic").ParagraphFormat .Alignment = wdAlignParagraphCenter .KeepWithNext = True .SpaceAfter = 0 .SpaceBefore = 0 End With With .Styles("Caption") .ParagraphFormat.SpaceAfter = 6 With .Font .Name = "Times New Roman" .Size = 10 .Bold = False End With .ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(2.5), Alignment:=wdAlignTabLeft End With With .Styles("Table") .ParagraphFormat.Alignment = wdAlignParagraphCenter .ParagraphFormat.SpaceAfter = 6 With .Font .Name = "Times New Roman" .Size = 10 .Bold = True 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 .PageSetup TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter ColWdth = TblWdth / NumCols End With With oTbl .AutoFitBehavior (wdAutoFitFixed) .Columns.Width = ColWdth End With CaptionLabels.Add Name:="Photograph" 'Process each file from the F/R List k = UBound(Split(xlFList, "|")) For i = 1 To k Step NumCols r = ((i - 1) / NumCols + 1) * 2 - 1 'Format the rows Call FormatRows(oTbl, r, RwHght) For c = 1 To NumCols j = j + 1 'Insert the Picture Set iShp = .InlineShapes.AddPicture( _ FileName:=StrPicPath & Split(xlFList, "|")(j) & ".jpg", 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 GPS Data StrLat = "N/A": NS = "": StrLon = "N/A": EW = "" WIAFile.LoadFile StrPicPath & StrNm & ".jpg" With WIAFile If .Properties.Exists("GpsLongitudeRef") Then NS = .Properties("GpsLongitudeRef").Value If .Properties.Exists("GpsLongitude") Then With .Properties("GpsLongitude") StrLon = NS & .Value(1) & Chr(186) & .Value(2) & Chr(39) & .Value(3) & Chr(34) 'StrLon = 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") StrLat = EW & .Value(1) & Chr(186) & .Value(2) & Chr(39) & .Value(3) & Chr(34) 'StrLat = EW & .Value(1) + .Value(2) / 60 + .Value(3) / 3600 End With End If End With 'Insert the Caption & GPS Co-ordinates on the row below the picture With oTbl.Cell(r + 1, c).Range .InsertBefore vbCr .Characters.First.InsertCaption _ Label:="Photograph", Title:=vbTab & Split(xlCList, "|")(j), _ Position:=wdCaptionPositionBelow, ExcludeLabel:=False .Characters.First = vbNullString '.Characters.Last.Previous = vbNullString With .Characters.Last .Text = "GPS: " & StrLon & "; " & StrLat .Style = "Table" End With End With 'Exit when we're done If j = k Then Exit For Next 'Add extra rows as needed If j < k Then oTbl.Rows.Add oTbl.Rows.Add End If Next End With ErrExit: Application.ScreenUpdating = True End Sub Function SheetExists(xlWkBk As Object, SheetName As String) As Boolean Dim i As Long: SheetExists = False For i = 1 To xlWkBk.Sheets.Count If xlWkBk.Sheets(i).Name = SheetName Then SheetExists = True: Exit For End If Next End Function Sub FormatRows(oTbl As Table, x As Long, RwHght As Single) With oTbl With .Rows(x) .Height = RwHght .HeightRule = wdRowHeightExactly .Range.Style = "TblPic" .Cells.VerticalAlignment = wdCellAlignVerticalCenter End With With .Rows(x + 1) .Height = CentimetersToPoints(1.25) .HeightRule = wdRowHeightExactly .Range.Style = "Caption" End With End With End Sub Code:
StrLon = NS & .Value(1) & Chr(186) & .Value(2) & Chr(39) & .Value(3) & Chr(34) 'StrLon = NS & .Value(1) + .Value(2) / 60 + .Value(3) / 3600 ... StrLat = EW & .Value(1) & Chr(186) & .Value(2) & Chr(39) & .Value(3) & Chr(34) 'StrLat = EW & .Value(1) + .Value(2) / 60 + .Value(3) / 3600 GPS: E150º15'30.780679"; S45º30'15.50928" The commented-out lines output the same data as decimal degrees.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#8
|
|||
|
|||
![]()
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 |
![]() |
Thread Tools | |
Display Modes | |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
![]() |
ahw | Word VBA | 43 | 02-28-2020 08:11 PM |
![]() |
Peace Freak | Excel | 3 | 04-08-2017 06:15 PM |
![]() |
celias | Word VBA | 3 | 07-11-2016 11:40 PM |
Populate Word Drop-down list with Excel column then auto fill form fields with Excel data | Faldinio | Word VBA | 7 | 10-19-2014 06:03 AM |
Polar Co-ordinates | NWR | PowerPoint | 0 | 02-18-2013 09:48 PM |