|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
以前收藏的,找不到原文了。
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
|
评分
-
1
查看全部评分
-
|