如何使用VBA获取相片拍照日期?

作者：绿色风分类：时间：2022-08-17 浏览：130

楼主 wise	Q:如何使用VBA获取相片拍照日期? A:ALT+F11→插入模块→输入以下代码： Option Explicit Private Function FindPicDate(PicFile As String) As String Dim bytes() As Byte Dim sLine() As String Dim fSize As Long, ExifDate As Long Dim i As Long, d As Long Dim ff As Integer Dim Found As Boolean ff = FreeFile fSize = FileLen(PicFile) If fSize > 1024 Then fSize = 1024 ReDim bytes(1 To fSize) 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) ExifDate = InStr(1, sLine(i), "xif") If ExifDate > 0 Then Found = True Exit For End If Next i If Found = False Then Exit Function For d = i + 1 To UBound(sLine) ExifDate = InStr(1, sLine(d), ":") If ExifDate > 0 Then FindPicDate = sLine(d) Exit For End If Next d End Function Sub test() MsgBox "照片创建日期为：" & FindPicDate(ThisWorkbook.Path & "\IMG_0118.JPG") End Sub VBA获取拍照日期.rar
2楼 wise	xyh9999后来追加的解法： 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 End If End If Set reg = Nothing End Function
3楼 Idiot	这个代友怎么用啊
4楼 Idiot	如何实现在EXCEL A列显示指定文件夹中所有图片文件名，B列中显示所有图片的拍摄时间啊

免责声明

有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素，经与ExcelTip.Net站长Apolloh商议并征得其同意，现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示，供有需要的人士查询使用，也慰缅曾经的论坛时代。所示各个帖子的原作者如对版权有异议，可与本人沟通提出，或于本站点留言，我们会尽快处理。在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一

评论列表