|
|
Sub Main()
'惊喜发现，DeepSeek帮忙修改代码成功！2025年3月8日
Dim strFile As String, strNewDate As String
Set wk = Worksheets("批量更正")
strPath = ThisWorkbook.Path
arr = wk.Range("C4:F6")
For i = 1 To 3
'strFile = "FILE0634.JPG"
'strNewDate = "2024/2/3 14:36"
strFile = arr(i, 1) & "." & arr(i, 2)
strNewDate = arr(i, 4)
Call ModiPhotoDate(strPath, strFile, strNewDate)
Next
End Sub
Function ModiPhotoDate(strPath As Variant, strFile As String, strNewDate As String)
'... [其他声明保持不变] ......DeepSeek修改
'strPath:文件所在文件夹名,必须是Variant类型
'strFile:文件名（不包括路径）
'strNewDate:要显示的日期时间，yyyy-mm-dd hh:nn格式,时间不写的话用原照片时间
Dim objShell As Object
Dim objFolder As Object
Dim objFolderItem As Object
Dim strOldDate As String
Dim arrOldDate() As Byte
Dim arrNewDate() As Byte
Dim arrByte() As Byte
Dim strNewFile As String
Dim i As Long
Dim j As Long
'照片复件文件名
strNewFile = Left(strFile, InStrRev(strFile, ".") - 1) & "复件." & Mid(strFile, InStrRev(strFile, ".") + 1)
'********************
'获取照片的拍摄日期时间
Set objShell = CreateObject("Shell.application")
Set objFolder = objShell.Namespace(strPath)
Set objFolderItem = objFolder.ParseName(strFile)
strOldDate = objFolder.getdetailsof(objFolderItem, 12)
'********************
'... [清理对象保持不变] ...DeepSeek修改提示
Set objFolderItem = Nothing
Set objFolder = Nothing
Set objShell = Nothing
'********************
' 新增：解析原始日期字符串为日期对象 ...DeepSeek新增
Dim arrDateTime() As String
Dim oldDatePart() As String, oldTimePart() As String
Dim oldDateTime As Date
' 分离日期和时间部分（假设格式为"yyyy/mm/dd hh:mm"）
arrDateTime = Split(strOldDate, " ")
If UBound(arrDateTime) >= 0 Then
oldDatePart = Split(arrDateTime(0), "/")
If UBound(arrDateTime) >= 1 Then
oldTimePart = Split(arrDateTime(1), ":")
Else
ReDim oldTimePart(0 To 1)
oldTimePart(0) = "00"
oldTimePart(1) = "00"
End If
End If
oldYear = Mid(oldDatePart(0), 2, 4)
oldMonth = Mid(oldDatePart(1), 2, 2)
oldDay = Mid(oldDatePart(2), 2, 2)
oldHour = Mid(oldTimePart(0), 3, 2)
oldMinute = oldTimePart(1)
' 构建日期对象
oldDateTime = DateSerial(oldYear, oldMonth, oldDay) + _
TimeSerial(oldHour, oldMinute, 0)
' 合并新日期和时间
If Len(strNewDate) <= 11 Then
strNewDate = Trim(strNewDate) & Format(oldDateTime, " hh:nn")
End If
' 确保新日期格式正确
Dim newDateTime As Date
newDateTime = CDate(strNewDate)
' 更新字节转换格式（保持原格式）
arrOldDate = StrConv(Format(oldDateTime, "yyyy:mm:dd hh:nn"), vbFromUnicode)
arrNewDate = StrConv(Format(newDateTime, "yyyy:mm:dd hh:nn"), vbFromUnicode)
'********************
'... [剩余代码保持不变] ... ..DeepSeek修改提示
'读入照片的二进制数据
With CreateObject("Adodb.Stream")
.Open
.Type = 1 'adTypeBinary
.LoadFromFile strPath & "\" & strFile
arrByte = .read
.Close
End With
'修改日期时间
For i = 0 To UBound(arrByte)
If arrByte(i) = arrOldDate(0) Then
For j = 1 To UBound(arrOldDate)
If arrByte(i + j) <> arrOldDate(j) Then Exit For
Next
If j > UBound(arrOldDate) Then
For j = 0 To UBound(arrOldDate)
arrByte(i + j) = arrNewDate(j)
Next
End If
End If
Next
'二进制数据写入文件，创建日期和修改日期等是当前日期
With CreateObject("Adodb.Stream")
.Type = 1 'adTypeBinary
.Open
.Write arrByte
.SaveToFile strPath & "\" & strNewFile, 2 'adSaveCreateOverWrite
.Close
End With
End Function
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2025-3-8 16:44
发表于 2025-3-9 00:52
楼主