累计签到：15 天
连续签到：1 天
|
红米机型特殊适配说明：
针对小米/红米的中文EXIF属性名做了专属匹配，兼容"GPS经度"和"经度"两种命名格式
优化了度分秒解析逻辑，适配红米系统使用中文符号「°′″」的存储格式
自动识别中文方向参考（"东/西/南/北"）和英文参考（E/W/S/N）
使用注意：
确保拍摄时已开启相机的「保存地理位置信息」权限
不要使用微信/QQ等软件传输照片（会自动清除EXIF），建议通过USB或网盘原文件传输
如果仍读取失败，可以右键查看照片属性→详细信息，确认GPS项是否存在数值
需要批量读取文件夹内所有红米照片的GPS并导出到Excel吗？我可以扩展批量处理功能。
- Option Explicit
- ' 坐标系转换参数
- Private Const pi As Double = 3.14159265358979
- Private Const a As Double = 6378245#
- Private Const ee As Double = 6.69342162296594E-03
- ' 红米Note 14 Pro专属GPS读取主程序
- Sub ReadRedmiPhotoGPS()
- Dim imgPath As String
- Dim wgsLon As Double, wgsLat As Double
- Dim gcjLon As Double, gcjLat As Double
- ' 选择照片
- With Application.FileDialog(msoFileDialogFilePicker)
- .Filters.Clear
- .Filters.Add "JPG图片", "*.jpg;*.jpeg"
- .Title = "选择红米拍摄的照片"
- If .Show -1 Then Exit Sub
- imgPath = .SelectedItems(1)
- End With
- ' 读取适配红米的GPS数据
- If GetRedmiGPS(imgPath, wgsLon, wgsLat) Then
- ' 转换为GCJ-02坐标系
- WGS84ToGCJ02 wgsLat, wgsLon, gcjLat, gcjLon
- ' 输出结果
- MsgBox "红米照片坐标（GCJ-02坐标系）：" & vbCrLf & _
- "经度：" & Format(gcjLon, "0.000000") & vbCrLf & _
- "纬度：" & Format(gcjLat, "0.000000"), vbInformation
- ' 写入单元格
- ActiveCell = Format(gcjLon, "0.000000")
- ActiveCell.Offset(0, 1) = Format(gcjLat, "0.000000")
- Else
- MsgBox "未读取到GPS信息，请确认：" & vbCrLf & _
- "1. 照片由红米Note 14 Pro拍摄且已开启定位权限" & vbCrLf & _
- "2. 照片未经过压缩/修图软件修改EXIF", vbExclamation
- End If
- End Sub
- ' 适配小米/红米机型的GPS读取函数
- Private Function delGetRedmiGPS(imgPath As String, ByRef lon As Double, ByRef lat As Double) As Boolean
- Dim shell As Object
- Dim folder As Object
- Dim file As Object
- Dim propName As String, propValue As String
- Dim i As Integer
- Dim lonRef As String, latRef As String
- Dim deg As Double, min As Double, sec As Double
- Set shell = CreateObject("Shell.Application")
- Set folder = shell.Namespace(Left(imgPath, InStrRev(imgPath, "")))
- Set file = folder.ParseName(Right(imgPath, Len(imgPath) - InStrRev(imgPath, "")))
- ' 适配红米EXIF属性命名规则
- For i = 0 To 300
- propName = folder.GetDetailsOf(folder.Items, i)
- propValue = folder.GetDetailsOf(file, i)
- Select Case Trim(propName)
- Case "经度", "GPS经度"
- Stop
- If propValue "" Then
- ' 解析红米的"XX°XX′XX.XX″"格式
- deg = Val(Split(propValue, "°")(0))
- min = Val(Split(Split(propValue, "°")(1), "′")(0)) / 60
- sec = Val(Replace(Split(Split(propValue, "′")(1), "″")(0), ",", ".")) / 3600
- lon = deg + min + sec
- End If
- Case "经度参考", "GPS经度参考"
- lonRef = Trim(propValue)
- Case "纬度", "GPS纬度"
- If propValue "" Then
- deg = Val(Split(propValue, "°")(0))
- min = Val(Split(Split(propValue, "°")(1), "′")(0)) / 60
- sec = Val(Replace(Split(Split(propValue, "′")(1), "″")(0), ",", ".")) / 3600
- lat = deg + min + sec
- End If
- Case "纬度参考", "GPS纬度参考"
- latRef = Trim(propValue)
- End Select
- Next i
- Stop
- ' 处理方向参考
- If lon > 0 And lat > 0 Then
- If lonRef = "W" Or lonRef = "西" Then lon = -lon
- If latRef = "S" Or latRef = "南" Then lat = -lat
- GetRedmiGPS = True
- Else
- GetRedmiGPS = False
- End If
- End Function
- ' WGS84转GCJ-02核心算法
- Private Sub WGS84ToGCJ02(wgLat As Double, wgLon As Double, ByRef mgLat As Double, ByRef mgLon As Double)
- Dim dLat As Double, dLon As Double
- Dim radLat As Double, magic As Double, sqrtMagic As Double
- If OutOfChina(wgLat, wgLon) Then
- mgLat = wgLat
- mgLon = wgLon
- Exit Sub
- End If
- dLat = TransformLat(wgLon - 105, wgLat - 35)
- dLon = TransformLon(wgLon - 105, wgLat - 35)
- radLat = wgLat / 180 * pi
- magic = Sin(radLat)
- magic = 1 - ee * magic * magic
- sqrtMagic = Sqrt(magic)
- dLat = (dLat * 180) / ((a * (1 - ee)) / (magic * sqrtMagic) * pi)
- dLon = (dLon * 180) / (a / sqrtMagic * Cos(radLat) * pi)
- mgLat = wgLat + dLat
- mgLon = wgLon + dLon
- End Sub
- ' 中国范围判断
- Private Function OutOfChina(lat As Double, lon As Double) As Boolean
- If lon < 72.004 Or lon > 137.8347 Then
- OutOfChina = True
- ElseIf lat < 0.8293 Or lat > 55.8271 Then
- OutOfChina = True
- Else
- OutOfChina = False
- End If
- End Function
- ' 坐标转换辅助函数
- Private Function TransformLat(x As Double, y As Double) As Double
- Dim ret As Double
- ret = -100 + 2 * x + 3 * y + 0.2 * y * y + 0.1 * x * y + 0.2 * Sqrt(Abs(x))
- ret = ret + (20 * Sin(6 * x * pi) + 20 * Sin(2 * x * pi)) * 2 / 3
- ret = ret + (20 * Sin(y * pi) + 40 * Sin(y / 3 * pi)) * 2 / 3
- ret = ret + (160 * Sin(y / 12 * pi) + 320 * Sin(y * pi / 30)) * 2 / 3
- TransformLat = ret
- End Function
- Private Function TransformLon(x As Double, y As Double) As Double
- Dim ret As Double
- ret = 300 + x + 2 * y + 0.1 * x * x + 0.1 * x * y + 0.1 * Sqrt(Abs(x))
- ret = ret + (20 * Sin(6 * x * pi) + 20 * Sin(2 * x * pi)) * 2 / 3
- ret = ret + (20 * Sin(x * pi) + 40 * Sin(x / 3 * pi)) * 2 / 3
- ret = ret + (150 * Sin(x / 12 * pi) + 300 * Sin(x / 30 * pi)) * 2 / 3
- TransformLon = ret
- End Function
- ' ========== 修复后的红米GPS读取函数 ==========
- Private Function GetRedmiGPS(imgPath As String, ByRef lon As Double, ByRef lat As Double) As Boolean
- Dim shell As Object
- Dim folder As Object
- Dim file As Object
- Dim propName As String, propValue As String
- Dim i As Integer
- Dim lonRef As String, latRef As String
- Dim deg As Double, min As Double, sec As Double
- Dim parts As Variant
- Set shell = CreateObject("Shell.Application")
- Set folder = shell.Namespace(Left(imgPath, InStrRev(imgPath, "")))
- Set file = folder.ParseName(Right(imgPath, Len(imgPath) - InStrRev(imgPath, "")))
- ' 【关键修复1】增加所有可能的属性名匹配，兼容不同系统和机型
- For i = 0 To 350
- propName = Trim(folder.GetDetailsOf(folder.Items, i))
- propValue = Trim(folder.GetDetailsOf(file, i))
- ' 调试：输出所有非空属性名和值，可在立即窗口查看
- If propValue "" Then Debug.Print "属性" & i & ": [" & propName & "] = " & propValue
- Select Case True
- ' 匹配所有可能的经度属性名
- Case InStr(1, propName, "经度", vbTextCompare) > 0, _
- InStr(1, propName, "Longitude", vbTextCompare) > 0, _
- InStr(1, propName, "GPS经度", vbTextCompare) > 0
- If propValue "" Then
- ' 【关键修复2】兼容任意分隔符的度分秒格式
- propValue = Replace(Replace(Replace(propValue, "°", " "), "′", " "), "″", " ")
- propValue = Replace(Replace(propValue, "'", " "), """", " ")
- parts = Split(WorksheetFunction.Trim(propValue), " ")
- deg = Val(parts(0))
- min = Val(parts(1)) / 60
- sec = Val(Replace(parts(2), ",", ".")) / 3600
- lon = deg + min + sec
- End If
- ' 匹配所有可能的经度参考属性名
- Case InStr(1, propName, "经度参考", vbTextCompare) > 0, _
- InStr(1, propName, "LongitudeRef", vbTextCompare) > 0, _
- InStr(1, propName, "经度基准", vbTextCompare) > 0
- lonRef = UCase(Trim(propValue))
- ' 匹配所有可能的纬度属性名
- Case InStr(1, propName, "纬度", vbTextCompare) > 0, _
- InStr(1, propName, "Latitude", vbTextCompare) > 0, _
- InStr(1, propName, "GPS纬度", vbTextCompare) > 0
- If propValue "" Then
- propValue = Replace(Replace(Replace(propValue, "°", " "), "′", " "), "″", " ")
- propValue = Replace(Replace(propValue, "'", " "), """", " ")
- parts = Split(WorksheetFunction.Trim(propValue), " ")
- deg = Val(parts(0))
- min = Val(parts(1)) / 60
- sec = Val(Replace(parts(2), ",", ".")) / 3600
- lat = deg + min + sec
- End If
- ' 匹配所有可能的纬度参考属性名
- Case InStr(1, propName, "纬度参考", vbTextCompare) > 0, _
- InStr(1, propName, "LatitudeRef", vbTextCompare) > 0, _
- InStr(1, propName, "纬度基准", vbTextCompare) > 0
- latRef = UCase(Trim(propValue))
- End Select
- Next i
- ' 处理方向参考，兼容中英文
- If lon > 0 And lat > 0 Then
- If lonRef = "W" Or lonRef = "西" Then lon = -lon
- If latRef = "S" Or latRef = "南" Then lat = -lat
- GetRedmiGPS = True
- Else
- GetRedmiGPS = False
- End If
- End Function
|
|
窥视卡
雷达卡
发表于 2026-4-27 08:52:00
提升卡
置顶卡
沉默卡
喧嚣卡
变色卡
千斤顶
照妖镜
发表于 2026-4-27 10:59:00
发表于 2026-4-30 21:30:01
