VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   8010
   ClientLeft      =   60
   ClientTop       =   405
   ClientWidth     =   9735
   LinkTopic       =   "Form1"
   ScaleHeight     =   8010
   ScaleWidth      =   9735
   StartUpPosition =   3  'Windows Default
   Begin VB.TextBox Text1 
      Height          =   285
      Left            =   90
      TabIndex        =   2
      Text            =   "C:\Users\dzzie\Desktop\exfoil3_test"
      Top             =   225
      Width           =   8070
   End
   Begin VB.ListBox List1 
      Height          =   6690
      Left            =   45
      TabIndex        =   1
      Top             =   855
      Width           =   9555
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   510
      Left            =   8325
      TabIndex        =   0
      Top             =   180
      Width           =   1185
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Const GENERIC_READ As Long = &H80000000
Private Const FILE_SHARE_READ As Long = &H1
Private Const FILE_SHARE_WRITE As Long = &H2
Private Const FILE_SHARE_DELETE As Long = &H4
Private Const OPEN_EXISTING As Long = 3
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Private Const INVALID_HANDLE_VALUE As Long = -1

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Private Declare Function CreateFile Lib "kernel32" _
    Alias "CreateFileA" ( _
    ByVal lpFileName As String, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    ByVal lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long) As Long

Private Declare Function GetFileTime Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpCreationTime As FILETIME, _
    lpLastAccessTime As FILETIME, _
    lpLastWriteTime As FILETIME) As Long

Private Declare Function FileTimeToLocalFileTime Lib "kernel32" ( _
    lpFileTime As FILETIME, _
    lpLocalFileTime As FILETIME) As Long

Private Declare Function FileTimeToSystemTime Lib "kernel32" ( _
    lpFileTime As FILETIME, _
    lpSystemTime As SYSTEMTIME) As Long

Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long) As Long


Private Sub Command1_Click()

    Dim files As New Collection
    Dim f As String
    Dim v As Variant
    
    Dim src As String
    Dim dst As String
    Dim ext As String
    
    Dim st As SYSTEMTIME
    
    Dim renamed As Long
    Dim failed As Long

    '-------------------------------------
    ' Collect files BEFORE renaming
    '-------------------------------------
    
    f = Dir$(Text1 & "\*.jpg")
    
    Do While Len(f)
        files.Add f
        f = Dir$
    Loop

    f = Dir$(Text1 & "\*.jpeg")
    
    Do While Len(f)
        files.Add f
        f = Dir$
    Loop

    '-------------------------------------
    ' Rename
    '-------------------------------------
    
    For Each v In files

        src = Text1 & "\" & CStr(v)

        If GetLastWriteSystemTime(src, st) Then

            ext = GetExtension(src)

            dst = Text1 & "\" & _
                  FormatSystemTime(st) & ext

            dst = MakeUniqueName(dst)

            If StrComp(src, dst, vbTextCompare) <> 0 Then

                List1.AddItem CStr(v) & _
                            "  ->  " & _
                            GetFileName(dst)

                Name src As dst

                renamed = renamed + 1

            End If

        Else

            Debug.Print "FAILED: " & CStr(v)
            failed = failed + 1

        End If

    Next

    MsgBox CStr(renamed) & " files renamed." & vbCrLf & _
           CStr(failed) & " failures.", _
           vbInformation, _
           "NTFS Date Renamer"

End Sub


Private Function GetLastWriteSystemTime( _
    ByVal FileName As String, _
    ByRef st As SYSTEMTIME) As Boolean

    Dim hFile As Long

    Dim ftCreate As FILETIME
    Dim ftAccess As FILETIME
    Dim ftWrite As FILETIME

    Dim ftLocal As FILETIME

    hFile = CreateFile( _
                FileName, _
                GENERIC_READ, _
                FILE_SHARE_READ Or _
                FILE_SHARE_WRITE Or _
                FILE_SHARE_DELETE, _
                0, _
                OPEN_EXISTING, _
                FILE_ATTRIBUTE_NORMAL, _
                0)

    If hFile = INVALID_HANDLE_VALUE Then
        Exit Function
    End If

    If GetFileTime( _
            hFile, _
            ftCreate, _
            ftAccess, _
            ftWrite) = 0 Then

        CloseHandle hFile
        Exit Function

    End If

    CloseHandle hFile

    ' FILETIME is UTC.
    ' Convert it to local time, matching Explorer.

    If FileTimeToLocalFileTime( _
            ftWrite, _
            ftLocal) = 0 Then

        Exit Function
    End If

    If FileTimeToSystemTime( _
            ftLocal, _
            st) = 0 Then

        Exit Function
    End If

    GetLastWriteSystemTime = True

End Function


Private Function FormatSystemTime( _
    ByRef st As SYSTEMTIME) As String

    FormatSystemTime = _
        Format$(st.wYear, "0000") & "-" & _
        Format$(st.wMonth, "00") & "-" & _
        Format$(st.wDay, "00") & "-" & _
        Format$(st.wHour, "00") & "-" & _
        Format$(st.wMinute, "00") & "-" & _
        Format$(st.wSecond, "00") & "-" & _
        Format$(st.wMilliseconds, "000")

End Function


Private Function MakeUniqueName( _
    ByVal FileName As String) As String

    Dim p As Long
    Dim base As String
    Dim ext As String
    Dim test As String
    Dim i As Long

    If Not FileExists(FileName) Then
        MakeUniqueName = FileName
        Exit Function
    End If

    p = InStrRev(FileName, ".")

    If p Then
        base = Left$(FileName, p - 1)
        ext = Mid$(FileName, p)
    Else
        base = FileName
        ext = ""
    End If

    For i = 1 To 9999

        test = base & "_" & _
               Format$(i, "000") & _
               ext

        If Not FileExists(test) Then
            MakeUniqueName = test
            Exit Function
        End If

    Next

End Function


Private Function FileExists( _
    ByVal FileName As String) As Boolean

    Dim attr As Long

    On Error Resume Next

    attr = GetAttr(FileName)

    FileExists = (Err.Number = 0)

    Err.Clear

End Function


Private Function GetExtension( _
    ByVal FileName As String) As String

    Dim p As Long

    p = InStrRev(FileName, ".")

    If p Then
        GetExtension = Mid$(FileName, p)
    Else
        GetExtension = ".JPG"
    End If

End Function


Private Function GetFileName( _
    ByVal FileName As String) As String

    Dim p As Long

    p = InStrRev(FileName, "\")

    If p Then
        GetFileName = Mid$(FileName, p + 1)
    Else
        GetFileName = FileName
    End If

End Function