怎么提取照片拍摄时间

bxm78

以前收藏的，找不到原文了。
Function Lqc_GetPicDate(PicFile As String) '提取照片拍摄日期，如果提取不到则返回""字符串
'例如：? Lqc_GetPicDate("c:\J002.jpg")
    On Error Resume Next
    Dim bytes() As Byte, sLine() As String, fSize As Long, ExifDate As Long, i As Long, d As Long, ff  As Integer, Found As Boolean, TmpCC As String, reg As Object
    ff = FreeFile: fSize = FileLen(PicFile)
    If fSize > 1024 Then fSize = 1024 ' get 1st 1K of file.
    ReDim bytes(1 To fSize)
    Set reg = CreateObject("VBScript.RegExp")
    reg.Global = True
    reg.Pattern = "\d{4}:\d{2}:\d{2}\s{1,3}\d{2}:\d{2}:\d{2}"
    Open PicFile For Binary As #ff
        Get #ff, 1, bytes
    Close ff
      
    sLine = Split(StrConv(bytes(), vbUnicode), Chr$(0))
   
    For i = 0 To UBound(sLine) ' does "Exif" exsist?
        ExifDate = InStr(1, sLine(i), "xif")    '这里本来应该是Exif
        If ExifDate > 0 Then
            Found = True
            Exit For
        End If
    Next i
        
    If Found = False Then Exit Function ' return nothing, "Exif" not found!
   
    TmpCC = ""
    For d = i + 1 To UBound(sLine) ' find first ":" in file
        ExifDate = InStr(1, sLine(d), ":")
        If ExifDate > 0 Then
            TmpCC = TmpCC & "|" & sLine(d) ' return date string
        End If
    Next d
   
    Set cArr = reg.Execute(TmpCC)
    If cArr Is Nothing Then Exit Function
    If cArr.Count >= 2 Then
       Lqc_GetPicDate = cArr(1).Value '取第2个日期
    Else
       If cArr.Count = 1 Then
            Lqc_GetPicDate = cArr(0).Value '取第1个日期
       Else
            Lqc_GetPicDate = ""   '否则返回值为空
       End If
    End If
    If Lqc_GetPicDate <> "" Then
        Mid(Lqc_GetPicDate, 8, 1) = "-"    '把日期中的":"替换为"-"
        Mid(Lqc_GetPicDate, 5, 1) = "-"
        Mid(Lqc_GetPicDate, 14, 1) = " "   '把时间中的":"替换为" "
        Mid(Lqc_GetPicDate, 17, 1) = " "
    End If
    Set reg = Nothing
End Function

liangdinghu

bxm78 发表于 2022-5-11 11:25
以前收藏的，找不到原文了。
Function Lqc_GetPicDate(PicFile As String) '提取照片拍摄日期，如果提取不 ...

这个提取到的是真正的拍摄时间，棒

10307951261

留个脚印学习