1

I have a VBA Project in a Word document with all of the code required to read the following properties from an image file: Title, Comments, TagsKeyWords, Subject, GPS Latitude and GPS Longitude

... The project also contains a procedure to set the properties Title, Comments, TagsKeyWords and Subject.

I have tried add to that procedure code to set the Latitude and Longitude properties, however the code is returning the statement that the property can't be set.

I am sure that I am trying to write to the correct PropetyKey as it is the same PropertyKey that I am reading from.

I sense the problem is the format of the data that I am passing as the update value. I have tried passing is in the same format as the output is returned and as an array of 3 doubles 1) for degrees, 2) for minutes and 3 for seconds.

My code is contained in two modules. Module A contains some enumerations and the VBA procedures to read the properties and set the properties. Module B contains all the APIs and related code. They can not be combined because of conflicting Type declarations.

Questions. Can the System.GPS.Latitude and System.GPS.Longitude properties be set with VBA? Is yes, what is the proper format of the data to set?

Module A:

Option Explicit
'Procedures in this project are modifications from shared code provied at:
'https://www.mrexcel.com/board/threads/reading-and-editing-metadata-file-properties.1254596/
Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type
Private Type PROPERTYKEY
  fmtid As GUID
  pid As Long
End Type
Public Enum Property_Name
  Comments°
  TagsKeyWords°
  Subject°
  Title°
  GPS_Latitude°
  GPS_Longitude°
End Enum
Const strFilepath = "D:\Test Image.jpg"
Sub ReadProperties()
  MsgBox GetPropertyValue(strFilepath, Title°)
  MsgBox GetPropertyValue(strFilepath, Comments°)
  MsgBox GetPropertyValue(strFilepath, TagsKeyWords°)
  MsgBox GetPropertyValue(strFilepath, Subject°)
  'I originally set GEO coordinates with using Google
  MsgBox GetPropertyValue(strFilepath, GPS_Latitude°)
  MsgBox GetPropertyValue(strFilepath, GPS_Longitude°)
lbl_Exit:
  Exit Sub
End Sub
Sub SetEditProperty()
  'Set\edit.
  Dim varA(2) As Double
  varA(0) = 13
  varA(1) = 45
  varA(2) = 7
  If Len(Dir(strFilepath)) Then
     Debug.Print SetPropertyValue(strFilepath, Title°, "Test of Set Title")
     Debug.Print SetPropertyValue(strFilepath, Comments°, "Test of Set Comments")
     Debug.Print SetPropertyValue(strFilepath, TagsKeyWords°, "Test of Set Tags and Keywords")
     Debug.Print SetPropertyValue(strFilepath, Subject°, "Test of Set Subject")
     'These two fail? I don't know if is because of how I am passing the new value or if the property simply can't be set using VBA
     Debug.Print SetPropertyValue(strFilepath, GPS_Latitude°, "18; 09; .234") 'Tried passing like it is returned
     Debug.Print SetPropertyValue(strFilepath, GPS_Latitude°, varA) 'Tried passing as an array of doubles
  Else
     MsgBox "Invalid filename"
  End If
lbl_Exit:
  Exit Sub
End Sub
Public Function fcnPropertyNameToCanoncalName(ByVal PN As Property_Name) As String
  Select Case PN
    Case Comments°:                                fcnPropertyNameToCanoncalName = "System.Comment"
    Case TagsKeyWords°:                            fcnPropertyNameToCanoncalName = "System.Keywords"
    Case Subject°:                                 fcnPropertyNameToCanoncalName = "System.Subject"
    Case Title°:                                   fcnPropertyNameToCanoncalName = "System.Title"
    Case GPS_Latitude°:                            fcnPropertyNameToCanoncalName = "System.GPS.Latitude"
    Case GPS_Longitude°:                           fcnPropertyNameToCanoncalName = "System.GPS.Longitude"
  End Select
End Function
Private Function DEFINE_PROPERTYKEY(l As Long, w1 As Integer, w2 As Integer, _
                                    B0 As Byte, b1 As Byte, b2 As Byte, B3 As Byte, _
                                    b4 As Byte, b5 As Byte, b6 As Byte, b7 As Byte, _
                                    pid As Long) As PROPERTYKEY
Dim tPk As PROPERTYKEY
  With tPk.fmtid
    .Data1 = l
    .Data2 = w1
    .Data3 = w2
    .Data4(0) = B0
    .Data4(1) = b1
    .Data4(2) = b2
    .Data4(3) = B3
    .Data4(4) = b4
    .Data4(5) = b5
    .Data4(6) = b6
    .Data4(7) = b7
  End With
  tPk.pid = pid
  DEFINE_PROPERTYKEY = tPk
lbl_Exit:
  Exit Function
End Function

Module B:

Option Explicit
#If Win64 Then
  Private Const NULL_PTR = 0^
  Private Const PTR_LEN = 8&
#Else
  Private Const NULL_PTR = 0&
  Private Const PTR_LEN = 4&
#End If
Private Enum Vtble_Ordinals
  'IUnknown
  QueryInterface = 0&
  Release = 2&
  'IPropertyStore
  GetCount = 3&
  GetAt = 4&
  SetValue = 6&
  Commit = 7&
  'IPropertyDescription
  GetCanonicalName = 4&
  GetDisplayName = 6&
  'IPropertySystem
  EnumeratePropertyDescriptions = 6&
  'IPropertyDescriptionList
  GetCount_ = 3&
  GetAt_ = 4&
End Enum
Private Enum PROPDESC_FORMAT_FLAGS
  PDFF_DEFAULT = 0&
  PDFF_PREFIXNAME = 1&
  PDFF_FILENAME = 2&
  PDFF_ALWAYSKB = 4&
  PDFF_RESERVED_RIGHTTOLEFT = 8&
  PDFF_SHORTTIME = &H10
  PDFF_LONGTIME = &H20
  PDFF_HIDETIME = &H40
  PDFF_SHORTDATE = &H80
  PDFF_LONGDATE = &H100
  PDFF_HIDEDATE = &H200
  PDFF_RELATIVEDATE = &H400
  PDFF_USEEDITINVITATION = &H800
  PDFF_READONLY = &H1000
  PDFF_NOAUTOREADINGORDER = &H2000
End Enum
Private Enum GETPROPERTYSTOREFLAGS
  GPS_DEFAULT = 0&
  GPS_HANDLERPROPERTIESONLY = 1&
  GPS_READWRITE = 2&
  GPS_TEMPORARY = 4&
  GPS_FASTPROPERTIESONLY = 8&
  GPS_OPENSLOWITEM = &H10
  GPS_DELAYCREATION = &H20
  GPS_BESTEFFORT = &H40
  GPS_NO_OPLOCK = &H80
  GPS_PREFERQUERYPROPERTIES = &H100
  GPS_EXTRINSICPROPERTIES = &H200
  GPS_EXTRINSICPROPERTIESONLY = &H400
  GPS_VOLATILEPROPERTIES = &H800
  GPS_VOLATILEPROPERTIESONLY = &H1000
  GPS_MASK_VALID = &H1FFF
End Enum
Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type
Private Type PROPERTYKEY
  fmtid As GUID
  pid As Long
End Type
#If VBA7 Then
  Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
  Private Declare PtrSafe Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
  Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As LongPtr)
  Private Declare PtrSafe Function CoInitialize Lib "ole32.dll" (ByVal pvReserved As LongPtr) As Long
  Private Declare PtrSafe Function CoUninitialize Lib "ole32" () As Long
  Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As Any) As Long
  Private Declare PtrSafe Function PSGetPropertyKeyFromName Lib "propsys.dll" (ByVal pszName As LongPtr, ppropkey As PROPERTYKEY) As Long
  Private Declare PtrSafe Function PSFormatPropertyValue Lib "propsys.dll" (ByVal pps As LongPtr, ByVal ppd As LongPtr, ByVal pdff As PROPDESC_FORMAT_FLAGS, ppszDisplay As LongPtr) As Long
  Private Declare PtrSafe Function PSGetPropertyDescription Lib "propsys.dll" (PropKey As PROPERTYKEY, riid As GUID, ppv As Any) As Long
  Private Declare PtrSafe Function PSGetNameFromPropertyKey Lib "propsys.dll" (PropKey As PROPERTYKEY, ppszCanonicalName As LongPtr) As Long
  Private Declare PtrSafe Function SHGetPropertyStoreFromParsingName Lib "shell32" (ByVal pszPath As LongPtr, pbc As Any, ByVal Flags As GETPROPERTYSTOREFLAGS, riid As GUID, ppv As Any) As Long
  Private Declare PtrSafe Function DispCallFunc Lib "OLEAUT32.DLL" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
  Private Declare PtrSafe Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
#Else
  Private Enum LongPtr
    [_]
  End Enum
  Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
  Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
  Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As LongPtr)
  Private Declare Function CoInitialize Lib "ole32.dll" (ByVal pvReserved As LongPtr) As Long
  Private Declare Function CoUninitialize Lib "ole32" () As Long
  Private Declare Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As Any) As Long
  Private Declare Function PSGetPropertyKeyFromName Lib "propsys.dll" (ByVal pszName As LongPtr, ppropkey As PROPERTYKEY) As Long
  Private Declare Function PSFormatPropertyValue Lib "propsys.dll" (ByVal pps As LongPtr, ByVal ppd As LongPtr, ByVal pdff As PROPDESC_FORMAT_FLAGS, ppszDisplay As LongPtr) As Long
  Private Declare Function PSGetPropertyDescription Lib "propsys.dll" (PropKey As PROPERTYKEY, riid As GUID, ppv As Any) As Long
  Private Declare Function PSGetNameFromPropertyKey Lib "propsys.dll" (PropKey As PROPERTYKEY, ppszCanonicalName As LongPtr) As Long
  Private Declare Function SHGetPropertyStoreFromParsingName Lib "shell32" (ByVal pszPath As LongPtr, pbc As Any, ByVal Flags As GETPROPERTYSTOREFLAGS, riid As GUID, ppv As Any) As Long
  Private Declare Function DispCallFunc Lib "OLEAUT32.DLL" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
  Private Declare Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
#End If
Public Function GetPropertyValue(ByVal sPathFile As String, ByVal Prop As Property_Name) As String
Const S_OK = 0&, CC_STDCALL = 4&
Const IID_PropertyStore = "{886D8EEB-8CF2-4446-8D02-CDBA1DBDCF99}"
Const IID_IPropertyDescription = "{6f79d558-3e96-4549-a1d1-7d75d2288814}"
Dim tPk As PROPERTYKEY, tIID As GUID
Dim lpPs As LongPtr, lpPd As LongPtr, lpStr As LongPtr
Dim sDisplayName As String
  If Len(Dir(sPathFile)) = 0& Then MsgBox "Invalid filepath.": Exit Function
  Call CoInitialize(NULL_PTR)
  sDisplayName = fcnPropertyNameToCanoncalName(Prop)
  If Len(sDisplayName) = 0& Then
    Debug.Print "Property not recognized."
    GoTo lbl_Exit
  End If
  If PSGetPropertyKeyFromName(StrPtr(sDisplayName), tPk) <> S_OK Then
    Debug.Print "Unable to get the property key."
    GoTo lbl_Exit
  End If
  Call CLSIDFromString(StrPtr(IID_PropertyStore), tIID)
  If SHGetPropertyStoreFromParsingName(StrPtr(sPathFile), ByVal 0&, GPS_DEFAULT Or GPS_BESTEFFORT Or GPS_OPENSLOWITEM, tIID, lpPs) <> S_OK Then
    Debug.Print "Unable to get the property store for the given file."
    GoTo lbl_Exit
  End If
  Call CLSIDFromString(StrPtr(IID_IPropertyDescription), tIID)
  If PSGetPropertyDescription(tPk, tIID, lpPd) <> S_OK Then
    Debug.Print "Unable to get the property description interface."
    GoTo ReleaseInterface
  End If
  If lpPs And lpPd Then
    If PSFormatPropertyValue(lpPs, lpPd, PDFF_DEFAULT, lpStr) <> S_OK Then
      Debug.Print "Unable to get the string representation of the property value stored in the property store."
      GoTo ReleaseInterface
    End If
    GetPropertyValue = CleanSTring(GetStrFromPtrW(lpStr))
  End If
ReleaseInterface:
  If lpPd Then
    Call vtblCall(lpPd, Release * PTR_LEN, vbLong, CC_STDCALL)
  End If
  If lpPs Then
    Call vtblCall(lpPs, Release * PTR_LEN, vbLong, CC_STDCALL)
  End If
lbl_Exit:
  Call CoUninitialize
End Function
Public Function SetPropertyValue(ByVal sPathFile As String, ByVal Prop As Property_Name, _
                                 ByVal Property_NewValue As Variant) As Boolean
Const IID_PropertyStore = "{886D8EEB-8CF2-4446-8D02-CDBA1DBDCF99}"
Const GPS_READWRITE = 2&, GPS_OPENSLOWITEM = &H10
Const CC_STDCALL = 4&, S_OK = 0&
Dim tIID As GUID, lpPs As LongPtr
Dim sCName As String
  sCName = fcnPropertyNameToCanoncalName(Prop)
  If Len(Dir(sPathFile)) = 0& Then
    MsgBox "Invalid filename."
    Exit Function
  End If
  Call CoInitialize(NULL_PTR)
  If CLSIDFromString(StrPtr(IID_PropertyStore), tIID) <> S_OK Then
     Debug.Print "unable to get the IID_PropertyStore interface."
     GoTo lbl_Exit
  End If
  If SHGetPropertyStoreFromParsingName(StrPtr(sPathFile), ByVal NULL_PTR, GPS_READWRITE Or GPS_OPENSLOWITEM, tIID, lpPs) <> S_OK Then
    Debug.Print "unable to get the property store from the file."
    GoTo lbl_Exit
 End If
  'IPropertyStore::SetValue
  If vtblCall(lpPs, SetValue * PTR_LEN, vbLong, CC_STDCALL, VarPtr(CNameToPropertyKey(sCName)), VarPtr(CVar(Property_NewValue))) <> S_OK Then
    Debug.Print "unable to set the property value."
    GoTo ReleaseInterface
  End If
  'IPropertyStore::Commit
  If vtblCall(lpPs, Commit * PTR_LEN, vbLong, CC_STDCALL) <> S_OK Then
    Debug.Print "unable to commit the property value."
    GoTo ReleaseInterface
  End If
  SetPropertyValue = True
ReleaseInterface:
  If lpPs Then
    'IPropertyStore::Release
    Call vtblCall(lpPs, Release * PTR_LEN, vbLong, CC_STDCALL)
  End If
lbl_Exit:
  Call CoUninitialize
  Exit Function
End Function
' _____________________________________________ Private Routines _________________________________________
Private Function vtblCall(ByVal InterfacePointer As LongPtr, ByVal VTableOffset As Long, _
                          ByVal FunctionReturnType As Long, ByVal CallConvention As Long, _
                          ParamArray FunctionParameters() As Variant) As Variant
Dim vParamPtr() As LongPtr
Dim pIndex As Long, pCount As Long
Dim vParamType() As Integer
Dim vRtn As Variant, vParams() As Variant
  If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
  If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function
    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
      ReDim vParamPtr(0 To 0)
      ReDim vParamType(0 To 0)
    Else
      ReDim vParamPtr(0 To pCount - 1&)
      ReDim vParamType(0 To pCount - 1&)
      For pIndex = 0& To pCount - 1&
        vParamPtr(pIndex) = VarPtr(vParams(pIndex))
        vParamType(pIndex) = VarType(vParams(pIndex))
      Next
  End If
  pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, _
  vParamType(0), vParamPtr(0), vRtn)
  If pIndex = 0& Then
    vtblCall = vRtn
  Else
    SetLastError pIndex
  End If
lbl_Exit:
  Exit Function
End Function
Private Function GetStrFromPtrW(ByVal lpString As LongPtr) As String
Dim lLength As Long, sBuffer As String
  lLength = lstrlen(lpString)
  sBuffer = Space$(lLength)
  Call CopyMemory(ByVal StrPtr(sBuffer), ByVal lpString, lLength * 2&)
  GetStrFromPtrW = sBuffer
lbl_Exit:
  Exit Function
End Function
Private Function CleanSTring(ByVal sStr As String) As String
  sStr = Replace(sStr, ChrW(&H200E), "")
  sStr = Replace(sStr, ChrW(&H200F), "")
  sStr = Replace(sStr, ChrW(&H202A), "")
  sStr = Replace(sStr, ChrW(&H202C), "")
  CleanSTring = sStr
lbl_Exit:
  Exit Function
End Function
Sub Test()

End Sub
Function CNameToPropertyKey(strName) As PROPERTYKEY
Dim A As PROPERTYKEY
  If PSGetPropertyKeyFromName(StrPtr(strName), A) = 0 Then
    CNameToPropertyKey = A
  End If
End Function
Improve this question
0

2 Answers 2

Reset to default
1

You say: "I am sure that I am trying to write to the correct PropetyKey as it is the same PropertyKey that I am reading from."

But those are the wrong properties for writing! I recommend to always read the docs, when available. In this case: https://learn.microsoft.com/en-us/windows/win32/wic/system-gps and specifically "Conflict resolution policy":

  • For Latitude: This value can be written by writing to System.GPS.LatitudeNumerator

  • For Longitude: This value can be written by writing to System.GPS.LongitudeNumerator

Improve this answer
Sign up to request clarification or add additional context in comments.

1 Comment

Tom, you are correct. I didn't know what I thought I knew and I was unaware of the document you referenced. Thank you.
0

With the knowledge gained by Tom Burnberg's reply (Answer), I was able to add the additional enumerations and modify my code as follows:

The answer to my questions is "Yes" System.GPS.Latitude and System.GPS.Longitude can be set\Edit using VBA but not directly. To update GPS.Latitude, you must update the LatitudeNumerator, LatitudeDenominator, or LatitudeReference properties.


Sub ChangeProps()
Dim bSat As Boolean
  bSat = fcnSetEditProperty(Title°, "Test set Title")
  If Not bSat Then Debug.Print "Write failed"
  bSat = fcnSetEditProperty(GPS_Latitude°, , 31, 52, 1900, "N")
  If Not bSat Then Debug.Print "Write failed"
  bSat = fcnSetEditProperty(GPS_Longitude°, , 132, 28, 1500, "W")
  If Not bSat Then Debug.Print "Write failed"
End Sub

Function fcnSetEditProperty(Key As Property_Name, Optional varVal, Optional D As Double, Optional M As Double, Optional S As Double, Optional Ref As String) As Boolean
'Set\edit.
Dim varNum(2) As Double, varDen(2) As Double
Dim b1 As Boolean, b2 As Boolean, b3 As Boolean
  varNum(0) = D
  varNum(1) = M
  varNum(2) = S
  'These are fix values
  varDen(0) = 1
  varDen(1) = 1
  varDen(2) = 100
  If Len(Dir(strFilepath)) Then
    Select Case True
      Case Not IsMissing(varVal)
        fcnSetEditProperty = SetPropertyValue(strFilepath, Key, varVal)
      Case Key = GPS_Latitude°
        fcnSetEditProperty = SetPropertyValue(strFilepath, GPS_LatNum°, varNum) + _
                             SetPropertyValue(strFilepath, GPS_LatDen°, varDen) + _
                             SetPropertyValue(strFilepath, GPS_LatRef°, Ref)
      Case Key = GPS_Longitude°
        fcnSetEditProperty = SetPropertyValue(strFilepath, GPS_LongNum°, varNum) + _
                             SetPropertyValue(strFilepath, GPS_LongDen°, varDen) + _
                             SetPropertyValue(strFilepath, GPS_LongRef°, Ref)
    End Select
  Else
    MsgBox "Invalid filename"
  End If
lbl_Exit:
  Exit Function
End Function
Improve this answer

1 Comment

As it’s currently written, your answer is unclear. Please edit to add additional details that will help others understand how this addresses the question asked. You can find more information on how to write good answers in the help center.

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.