如何用VBA设置图片的System.GPS.Latitude与Longitude属性？

结论 #

可以用VBA设置System.GPS.Latitude和System.GPS.Longitude属性，核心问题在于数据格式必须匹配系统要求的结构，且需要配合设置半球参考属性。

正确的数据格式 #

1. GPS纬度/经度核心数据：
   必须是一个包含3个双精度（Double）元素的数组，元素顺序依次为：

   • 第1个元素：纬度/经度的度（支持小数，比如39.5度直接写39.5）
   • 第2个元素：分（支持小数，比如30.5分写30.5）
   • 第3个元素：秒（同理支持小数）

2. 必须配合设置半球参考属性：

   • 设置纬度时，需同时设置System.GPS.LatitudeRef，值为字符串"N"（北纬）或"S"（南纬）
   • 设置经度时，需同时设置System.GPS.LongitudeRef，值为字符串"E"（东经）或"W"（西经）
     缺少半球参考的话，GPS坐标不会被系统正确识别。

VBA实现示例 #

1. 基础类型与API声明（单独模块中定义，避免类型冲突） #

Private Type PROPERTYKEY
  fmtid As GUID
  pid As Long
End Type

Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type

Private Declare PtrSafe Function SHGetPropertyStoreFromParsingName Lib "shell32.dll" ( _
  ByVal pszPath As String, _
  ByVal pbc As LongPtr, _
  ByVal grfFlags As Long, _
  ByRef riid As GUID, _
  ByRef ppv As Object) As Long

Private Declare PtrSafe Function IPropertyStore_SetValue Lib "propsys.dll" ( _
  ByVal pps As Object, _
  ByRef key As PROPERTYKEY, _
  ByRef propVar As Variant) As Long

Private Declare PtrSafe Function IPropertyStore_Commit Lib "propsys.dll" ( _
  ByVal pps As Object) As Long

2. 定义GPS属性对应的PropertyKey #

' 获取System.GPS.Latitude的PropertyKey
Private Function GetGPSLatitudeKey() As PROPERTYKEY
  With GetGPSLatitudeKey.fmtid
    .Data1 = &H26D4155D
    .Data2 = &HE6D9
    .Data3 = &H4C44
    .Data4(0) = &HAD: .Data4(1) = &HA6
    .Data4(2) = &H2A: .Data4(3) = &H8C
    .Data4(4) = &H5E: .Data4(5) = &HA1
    .Data4(6) = &H9B: .Data4(7) = &H47
  End With
  GetGPSLatitudeKey.pid = 100
End Function

' 获取System.GPS.LatitudeRef的PropertyKey
Private Function GetGPSLatitudeRefKey() As PROPERTYKEY
  With GetGPSLatitudeRefKey.fmtid
    .Data1 = &H26D4155D
    .Data2 = &HE6D9
    .Data3 = &H4C44
    .Data4(0) = &HAD: .Data4(1) = &HA6
    .Data4(2) = &H2A: .Data4(3) = &H8C
    .Data4(4) = &H5E: .Data4(5) = &HA1
    .Data4(6) = &H9B: .Data4(7) = &H47
  End With
  GetGPSLatitudeRefKey.pid = 99
End Function

' 获取System.GPS.Longitude的PropertyKey
Private Function GetGPSLongitudeKey() As PROPERTYKEY
  With GetGPSLongitudeKey.fmtid
    .Data1 = &H26D4155D
    .Data2 = &HE6D9
    .Data3 = &H4C44
    .Data4(0) = &HAD: .Data4(1) = &HA6
    .Data4(2) = &H2A: .Data4(3) = &H8C
    .Data4(4) = &H5E: .Data4(5) = &HA1
    .Data4(6) = &H9B: .Data4(7) = &H47
  End With
  GetGPSLongitudeKey.pid = 101
End Function

' 获取System.GPS.LongitudeRef的PropertyKey
Private Function GetGPSLongitudeRefKey() As PROPERTYKEY
  With GetGPSLongitudeRefKey.fmtid
    .Data1 = &H26D4155D
    .Data2 = &HE6D9
    .Data3 = &H4C44
    .Data4(0) = &HAD: .Data4(1) = &HA6
    .Data4(2) = &H2A: .Data4(3) = &H8C
    .Data4(4) = &H5E: .Data4(5) = &HA1
    .Data4(6) = &H9B: .Data4(7) = &H47
  End With
  GetGPSLongitudeRefKey.pid = 102
End Function

3. 设置GPS坐标的公共方法 #

Public Sub SetImageGPSCoord(ByVal imgFullPath As String, _
                            ByVal latDeg As Double, ByVal latMin As Double, ByVal latSec As Double, ByVal latRef As String, _
                            ByVal lonDeg As Double, ByVal lonMin As Double, ByVal lonSec As Double, ByVal lonRef As String)
  Dim ps As Object
  Dim propVar As Variant
  Dim iidPropertyStore As GUID
  Dim hr As Long

  ' 初始化IID_IPropertyStore
  With iidPropertyStore
    .Data1 = &H886D8EEB
    .Data2 = &H8CF2
    .Data3 = &H4446
    .Data4(0) = &H8D: .Data4(1) = &H8A
    .Data4(2) = &H6D: .Data4(3) = &HBC
    .Data4(4) = &H74: .Data4(5) = &H48
    .Data4(6) = &H2E: .Data4(7) = &H37
  End With

  ' 获取图片文件的PropertyStore对象
  hr = SHGetPropertyStoreFromParsingName(imgFullPath, 0, 0, iidPropertyStore, ps)
  If hr <> 0 Then
    MsgBox "无法获取文件属性存储对象", vbExclamation
    Exit Sub
  End If

  ' 设置纬度半球与度分秒
  propVar = latRef
  hr = IPropertyStore_SetValue(ps, GetGPSLatitudeRefKey(), propVar)
  propVar = Array(latDeg, latMin, latSec)
  hr = IPropertyStore_SetValue(ps, GetGPSLatitudeKey(), propVar)

  ' 设置经度半球与度分秒
  propVar = lonRef
  hr = IPropertyStore_SetValue(ps, GetGPSLongitudeRefKey(), propVar)
  propVar = Array(lonDeg, lonMin, lonSec)
  hr = IPropertyStore_SetValue(ps, GetGPSLongitudeKey(), propVar)

  ' 提交更改到文件
  hr = IPropertyStore_Commit(ps)
  If hr = 0 Then
    MsgBox "GPS坐标设置成功", vbInformation
  Else
    MsgBox "GPS坐标设置失败", vbCritical
  End If
End Sub

调用示例 #

' 设置北纬39度54分30秒，东经116度23分15秒
SetImageGPSCoord "C:\test.jpg", 39, 54, 30, "N", 116, 23, 15, "E"

注意事项 #

• 确保操作的图片文件未被其他程序占用，否则提交更改会失败
• 度分秒数值支持小数（例如39.5度、30.25分），无需转换为整数
• 模块冲突问题：将所有类型声明、API声明和PropertyKey定义放在一个单独的标准模块中，其他模块仅调用公共方法SetImageGPSCoord即可避免类型重复声明的问题

内容的提问来源于stack exchange，提问作者Greg Maxey