使用照片或者录像的拍摄日期命名文件

最新推荐文章于 2020-08-14 05:19:52 发布

stuyou

最新推荐文章于 2020-08-14 05:19:52 发布

阅读量342

点赞数

分类专栏： Windows

本文链接：https://blog.csdn.net/stuyou/article/details/105713849

版权

Windows 专栏收录该内容

24 篇文章 0 订阅

订阅专栏

该程序使用自定义GetPhotoDate（）函数获取照片或者录像的“拍摄日期”，作为该照片的文件名。有的照片或者录像没有”拍摄日期“，就不能使用该程序，应该用FileDateTime( )函数获取”创建日期“。

Dim Index As Integer
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
Suppres***ternalCodecs As Long
End Type
Private Type PropertyItem
propId As Long ' ID of this property
Length As Long ' Length of the property value, in bytes
Type As Long ' Type of the value, as one of TAG_TYPE_XXX defined above
Value As Long ' property value
End Type
Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal filename As Long, hImage As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
Private Declare Function GdipGetPropertyCount Lib "gdiplus" (ByVal Image As Long, numOfProperty As Long) As Long
Private Declare Function GdipGetPropertyIdList Lib "gdiplus" (ByVal Image As Long, ByVal numOfProperty As Long, list As Long) As Long
Private Declare Function GdipGetPropertyItemSize Lib "gdiplus" (ByVal Image As Long, ByVal propId As Long, Size As Long) As Long
Private Declare Function GdipGetPropertyItem Lib "gdiplus" (ByVal Image As Long, ByVal propId As Long, ByVal propSize As Long, Buffer As Long) As Long
Private Declare Function GdipGetPropertySize Lib "gdiplus" (ByVal Image As Long, totalBufferSize As Long, numProperties As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long)
Private Function GetPhotoDate(ImagePath As String) As String
Dim Bitmap As Long
Dim Token As Long
Dim Index As Long
Dim PropertyCount As Long
Dim ItemSize As Long
Dim Prop As PropertyItem
Dim GdipInput As GdiplusStartupInput
Const PropertyTagExifDTOrig As Long = &H9003& ' Date & time of original
GdipInput.GdiplusVersion = 1
GdiplusStartup Token, GdipInput
GdipLoadImageFromFile StrPtr(ImagePath), Bitmap
GdipGetPropertyCount Bitmap, PropertyCount
ReDim PropertyList(PropertyCount - 1) As Long
GdipGetPropertyIdList Bitmap, PropertyCount, PropertyList(0)
For Index = 0 To PropertyCount - 1
GdipGetPropertyItemSize Bitmap, PropertyList(Index), ItemSize
ReDim Buffer(ItemSize - 1) As Byte
GdipGetPropertyItem Bitmap, PropertyList(Index), ItemSize, ByVal VarPtr(Buffer(0))
CopyMemory Prop, ByVal VarPtr(Buffer(0)), Len(Prop)
ReDim Data(ItemSize - 16) As Byte
CopyMemory Data(0), ByVal Prop.Value, ItemSize - 16
Select Case PropertyList(Index)
Case PropertyTagExifDTOrig
GetPhotoDate = StrConv(Data, vbUnicode)
End Select
Next
GdipDisposeImage Bitmap
GdiplusShutdown Token
End Function
Private Sub Command1_Click()
Dim filename, newfilename$, newfilenameback$, newfilenamekz$, filedt$, exname$
Dim i%, indexphoto%
Dim ii%, aa$, cc$
Dim photoname$(), attachnum%()
ReDim photoname(1 To File1.ListCount)
ReDim attachnum(1 To File1.ListCount)
For i = 1 To File1.ListCount
attachnum(i) = 1
photoname(i) = ""
Next i
indexphoto = 1
For i = 0 To File1.ListCount - 1
aa = ""
cc = ""
File1.ListIndex = i
filename = CStr(File1.filename)
exname = Right(filename, 4)
filedt = GetPhotoDate("e:\photo\" & filename)
filedt = Trim(filedt)
'MsgBox filedt
newfilename = getdtname(filedt)
For ii = 1 To Len(newfilename)
cc = Mid(newfilename, ii, 1)
If IsNumeric(cc) = True Then
aa = aa & cc
End If
Next ii
newfilename = aa
newfilenamekz = newfilename & exname
newfilenameback = newfilenamekz
'如果有重名的文件，就在文件名后增加一个数字，和重名文件区别开
If ifsamename(photoname(), newfilenamekz) = True Then
newfilenamekz = (newfilename & attachnum(Index)) & exname
attachnum(Index) = attachnum(Index) + 1
Else
photoname(indexphoto) = newfilenameback
indexphoto = indexphoto + 1
End If
Name "e:\photo\" & filename As "e:\photo\" & newfilenamekz
Next i
MsgBox "OK!"
End Sub
Private Sub Form_Load()
File1.Path = "e:\photo\"
End Sub
Private Function getdtname(dt As String) As String
'文件的创建时间格式为2010-05-13 19:30:23，即为形参dt。
'通过getdtname函数得到以文件创建时间为名字的文件名，格式为20100513193023
Dim dtarray() As String, darray() As String, tarray() As String
If Len(dt) > 0 Then
dtarray() = Split(dt)
'MsgBox dtarray(0)
'MsgBox dtarray(1)
darray() = Split(dtarray(0), ":")
'MsgBox darray(0)
'MsgBox darray(1)
'MsgBox darray(2)
tarray() = Split(dtarray(1), ":")
'MsgBox tarray(0)
'MsgBox tarray(1)
'MsgBox tarray(2)
If Len(darray(1)) = 1 Then darray(1) = 0 & darray(1)
If Len(darray(2)) = 1 Then darray(2) = 0 & darray(2)
If Len(tarray(0)) = 1 Then tarray(0) = 0 & tarray(0)
If Len(tarray(1)) = 1 Then tarray(1) = 0 & tarray(1)
If Len(tarray(2)) = 1 Then tarray(2) = 0 & tarray(2)
getdtname = darray(0) & darray(1) & darray(2) & tarray(0) & tarray(1) & tarray(2)
End If
End Function
Private Function ifsamename(name$(), destname As String) As Boolean
'判断和destname是否有重名的文件
Dim Length As Integer, name_index%
'length = UBound(name()) - LBound(name()) + 1
For name_index = LBound(name()) To UBound(name())
If destname = name(name_index) Then
ifsamename = True
Index = name_index
Exit For
Else
ifsamename = False
End If
Next name_index
End Function