Удаление файлов и папок созданных в 2012 году - VB

Option Explicit
 
' Задайте папку для удаления из нее файлов за указанный год
Const SrcFolder As String = "c:\temp"
 
Private Const MAX_PATH As Long = 260&
 
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    lpszFileName(MAX_PATH) As Integer
    lpszAlternate(14) As Integer
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 "CreateFileW" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function GetFileTime Lib "kernel32.dll" (ByVal hFile As Long, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileW" (ByVal lpFileName As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileW" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileW" (ByVal lpFileName As Long) As Long
Private Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesW" (ByVal lpFileName As Long, ByVal dwFileAttributes As Long) As Long
 
Private Const INVALID_HANDLE_VALUE      As Long = -1
Private Const FILE_ATTRIBUTE_NORMAL     As Long = &H80&
Dim lWatchYear As Long
 
Private Sub Form_Load()
    Dim sWatchYear As String
    sWatchYear = InputBox("Введите искомый год создания файлов для их удаления из папки: " & SrcFolder)
    If StrPtr(sWatchYear) <> 0 Then
        lWatchYear = CLng(sWatchYear)
        ScanFolder SrcFolder
    End If
End Sub
 
Sub ScanFolder(Path As String)
    On Error Resume Next
    Dim SubPathName     As String
    Dim PathName        As String
    Dim hFind           As Long
    Dim L               As Long
    Dim lRet            As Long
    Dim lpStr           As Long
    Dim fd              As WIN32_FIND_DATA
    
    Do
        If hFind <> 0 Then
            If FindNextFile(hFind, fd) = 0 Then FindClose hFind: hFind = 0: Exit Sub
        Else
            hFind = FindFirstFile(StrPtr(Path & "\*"), fd)
            If hFind = INVALID_HANDLE_VALUE Then Exit Sub
        End If
        
        L = fd.dwFileAttributes And &H600 ' мимо симлинков
        Do While L
            If FindNextFile(hFind, fd) = 0 Then FindClose hFind: hFind = 0: Exit Sub
            L = fd.dwFileAttributes And &H600
        Loop
    
        If hFind <> 0 Then
            lpStr = VarPtr(fd.dwReserved1) + 4
            L = lstrlen(lpStr)
            PathName = String$(L, vbNullChar)
            lRet = StrPtr(PathName)
            lstrcpy lRet, lpStr
            SubPathName = Path & "\" & PathName
        
            If fd.dwFileAttributes And vbDirectory Then
                If PathName <> "." Then
                    If PathName <> ".." Then
                        DoEvents
                        ScanFolder SubPathName
                    End If
                End If
            Else
                If lWatchYear = Year(GetFileCreationDate(SubPathName)) Then
                    SetFileAttributes StrPtr(SubPathName), FILE_ATTRIBUTE_NORMAL  'Файл не удалится, пока не снимешь ReadOnly
                    If DeleteFile(StrPtr(SubPathName)) Then
                        Debug.Print "[ OK ] Delete Success: " & SubPathName
                    Else
                        Debug.Print "[FAIL] Delete Failed: " & SubPathName & ". Code = " & Err.LastDllError
                    End If
                End If
            End If
        End If
        
    Loop While hFind
End Sub
 
Function GetFileCreationDate(file As String) As Date
    Const FILE_FLAG_SEQUENTIAL_SCAN As Long = &H8000000
    Const FILE_FLAG_NO_BUFFERING    As Long = &H20000000
    Const FILE_SHARE_READ           As Long = &H1&
    Const FILE_SHARE_WRITE          As Long = &H2&
    Const OPEN_EXISTING             As Long = 3&
 
    Dim hFile       As Long
    Dim ctime       As FILETIME
    Dim atime       As FILETIME
    Dim wtime       As FILETIME
    Dim ftime       As SYSTEMTIME
    
    hFile = CreateFile(StrPtr(file), ByVal 0&, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, _
        FILE_FLAG_NO_BUFFERING Or FILE_FLAG_SEQUENTIAL_SCAN, ByVal 0&)
            
    If hFile <> INVALID_HANDLE_VALUE Then
        GetFileTime hFile, ctime, atime, wtime
        FileTimeToLocalFileTime ctime, ctime
        FileTimeToSystemTime ctime, ftime
        GetFileCreationDate = DateSerial(ftime.wYear, ftime.wMonth, ftime.wDay) + TimeSerial(ftime.wHour, ftime.wMinute, ftime.wSecond)
        CloseHandle hFile
    End If
End Function