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

该程序使用自定义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

 用照片的拍照日期命名.rar