VB版 NTFS文件系统USN日志读取

NTFS文件系统USN日志读取，这东西不新鲜，但是好像找不到VB 版本的，发一个。

获取文件的名字比较简单，获取路径麻烦点，可以采用：1、Api函数OpenFileById获取；2、也可以通过USN信息重建完整路径。
Private Declare Function OpenFileById Lib "kernel32" (ByVal hVoluemHint As Long, lpFileID As FILE_ID_DESCRIPTOR, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwFlagsAndAttributes As Long) As Long
通过测试在VB下应用OpenFileById 与USN信息重建速度差不多。

这段代码是采用的第2种方法取得全路径。

对于非NTFS文件系统，采用非递归法遍历。

以下是获取所有盘中文件名及全路径代码。

在form1中添加三个控件：text1，command1和drive1。获取的数据在app目录下的file.txt文件中。

Option Explicit

Private Const MAX_PATH = 260
Private Const MAXDWORD = &HFFFF
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100

Private Type LargeLong
    A As Long
    b As Long

End Type
Private Type CREATE_USN_JOURNAL_DATA
    MaximumSize As Double
    AllocationDelta As Double
End Type
Private Type SECURITY_ATTRIBUTES
        nLength As Long
        bInheritHandle As Long
        lpSecurityDescriptor As Long
End Type
Private Type OVERLAPPED
        ternal As Long
        hEvent As Long
        offset As Long
        OffsetHigh As Long
        ternalHigh As Long
End Type
Private Type USN_JOURNAL_DATA
    UsnJournalID As Double
    FirstUsn As Double
    NextUsn As Double
    LowestValidUsn As Double
    MaxUsn As Double
    MaximumSize As Double
    AllocationDelta As Double
End Type
Private Type MFT_ENUM_DATA
    StartFileReferenceNumber As Double
    LowUsn As Double
    HighUsn As Double
End Type
Private Type USN
    RecordLength As Long ': Cardinal;
    MajorVersion As Integer ': Word;
    MinorVersion As Integer ': Word;
    FileReferenceNumber As Double ': UInt64;       // Int64Rec;
    ParentFileReferenceNumber As Double ': UInt64; // Int64Rec;
    USN As Double ': Int64;
    TimeStamp As LargeLong ': LARGE_INTEGER;
    Reason As Long ': Cardinal;
    SourceInfo As Long ': Cardinal;
    SecurityId As Long ': Cardinal;
    FileAttributes As Long ': Cardinal;
    FileNameLength As Integer ': Word;
    FileNameOffset As Integer ': Word;
    'FileName(512) As Byte ': PWideChar;'VB里面没有指针，在后面使用时再动态声明
End Type
Private Type TypeFolderInfo         '所有目录信息
    folderNumber As Double
    parentFolderNumber As Double
    parentID As Long                '直接定位到ID
    folderName As String
End Type
Private Type TypeFileAllInfo        '所有文件
    fileNumber As Double
    parentFileNumber As Double
    FileName As String
    fPath As String
End Type
Private Type TypeFolderIndex            '目录的索引
    folderNumber As Double
    myID As Long
End Type
Private Type DELETE_USN_JOURNAL_DATA
    UsnJournalID As Double
    DeleteFlags As Integer
End Type


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
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type

Private Const BUF_LEN = 2000 * 1034& ' 500 * 1024&
Private Const FSCTL_ENUM_USN_DATA = 590003
Private Const FSCTL_CREATE_USN_JOURNAL = 590055
Private Const FSCTL_QUERY_USN_JOURNAL = 590068
Private Const FSCTL_DELETE_USN_JOURNAL = 590072
Private Const USN_DELETE_FLAG_DELETE = 1&
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const OPEN_EXISTING = 3&
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function DeviceIoControl2 Lib "kernel32" Alias "DeviceIoControl" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, ByVal lpOutBuffer As Long, ByVal nOutBufferSize As Long, lpBytesReturned As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Sub CopyMemory2 Lib "kernel32" Alias "RtlMoveMemory" (ByVal pDest As Long, ByVal pSrc As Long, ByVal ByteLen As Long)
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long

Dim hVol As Long
Dim folderList() As TypeFolderInfo
Dim fileList() As TypeFileAllInfo
Dim folderIndex() As TypeFolderIndex    '目录索引
Dim countFile As Long
Dim curF As Integer
Private Sub Command1_Click()
Dim T As Long, lastT As Long, ct As Long
Dim n As Long
'Dim dr As DriveListBox
Dim driveCha As String
Dim inf As String, lastCountF As Long
countFile = 0
curF = FreeFile
    Dim fs As String
    fs = App.Path & "\file.txt"
    If Len(Dir(fs)) > 0 Then Kill fs
    T = GetTickCount
    lastT = T
    'Set dr = Me.Controls.Add("VB.DriveListBox", "DR")
    Open fs For Output As #curF
    'SearchFiles ("h")
    'GoTo ex
    Dim fss As String
    For n = 0 To Drive1.ListCount - 1 ' dr.ListCount - 1
        driveCha = Left(Drive1.List(n), 1) 'Left(dr.List(n), 1)
        If IsNTFS(driveCha) Then
            'If LCase(driveCha) = "c" Then
            Call GetNtfsDriveFile(driveCha)     '调试检查错误
            fss = "NTFS"
            'End If
        Else
            Call SearchFiles(driveCha, 100000)
            fss = "FAT32"
        End If
        ct = timeGetTime
        If ct > lastT Then
            inf = inf & driveCha & "盘 " & fss & "系统，共有 " & countFile - lastCountF & " 个文件,用时 " & ct - lastT & " ms,平均" & Format((countFile - lastCountF) / (ct - lastT), "0.00") & "/ms" & vbCrLf
        End If
        lastCountF = countFile
        lastT = ct
    Next
'ex:
    Close #curF
    'Me.Controls.Remove dr
Text1.Text = inf & vbCrLf & "共找到 " & countFile & " 个文件！耗时 " & GetTickCount - T & " 毫秒"
MsgBox "数据已写入到：   " & fs
End Sub
Private Sub GetNtfsDriveFile(driveCha As String)
Dim lp As SECURITY_ATTRIBUTES
Dim lpO As OVERLAPPED
Dim res As Long
Dim qujd As CREATE_USN_JOURNAL_DATA
Dim br As Long
Dim cujd As CREATE_USN_JOURNAL_DATA
Dim ujd As USN_JOURNAL_DATA
Dim dwRet As Long
Dim hi As Long, lo As Long
Dim disk As String

disk = driveCha & ":"
    hVol = CreateFile("\\.\" & disk, GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, lp, OPEN_EXISTING, 0, 0)
    res = DeviceIoControl(hVol, FSCTL_CREATE_USN_JOURNAL, cujd, Len(cujd), Null, 0, br, lpO)
    res = DeviceIoControl(hVol, FSCTL_QUERY_USN_JOURNAL, lpO, 0, ujd, Len(ujd), dwRet, lpO)
    
    Dim la As LargeLong
    CopyMemory la, ujd.NextUsn, 8
    
Dim BufferIn As MFT_ENUM_DATA
Dim BufferOut() As Byte
ReDim BufferOut(BUF_LEN)
Dim UsnInfo As USN
Dim count As Long, countLoop As Long

ReDim folderList(10000)
ReDim fileList(1000000)
Dim curAddFolder As Long, curAddFile As Long, cc As Long
    'int64Size                         := SizeOf(Int64);
    BufferIn.StartFileReferenceNumber = 0
    BufferIn.LowUsn = 0
    BufferIn.HighUsn = ujd.NextUsn ' CDblEx(la.a)
    dwRet = 0

    'res = DeviceIoControl2(hVol, FSCTL_ENUM_USN_DATA, BufferIn, Len(BufferIn), StrPtr(BufferOut), BUF_LEN, dwRet, lpO)
    Do While DeviceIoControl2(hVol, FSCTL_ENUM_USN_DATA, BufferIn, Len(BufferIn), VarPtr(BufferOut(0)), BUF_LEN, dwRet, lpO) <> 0
        'Debug.Print BufferOut ' Left(BufferOut, 1000)
        Dim seat As Long
        Dim tmpF() As Byte
        count = count + 1
        seat = VarPtr(BufferOut(0)) + 8
        
        'If count = 2 Then Exit Do ''''''debug
        Do While seat <= VarPtr(BufferOut(UBound(BufferOut))) - Len(UsnInfo)
            
            CopyMemory2 VarPtr(UsnInfo), seat, Len(UsnInfo)
            If UsnInfo.RecordLength + seat > VarPtr(BufferOut(UBound(BufferOut))) Then Exit Do
            If UsnInfo.RecordLength <= 0 Then Exit Do
            If UsnInfo.FileNameLength <= 0 Then Exit Do
            'Debug.Print Left(UsnInfo.FileName, UsnInfo.FileNameLength)
            ReDim tmpF(UsnInfo.FileNameLength - 1)
            'CopyMemory2 VarPtr(tmpF(0)), VarPtr(UsnInfo.FileName(0)), UsnInfo.FileNameLength
            CopyMemory2 VarPtr(tmpF(0)), seat + Len(UsnInfo), UsnInfo.FileNameLength
            If UsnInfo.FileAttributes And vbDirectory Then      '新增目录结构
                curAddFolder = curAddFolder + 1         '0不用
                If curAddFolder > UBound(folderList) Then ReDim Preserve folderList(curAddFolder + 10000)
                folderList(curAddFolder).folderName = tmpF
                folderList(curAddFolder).folderNumber = UsnInfo.FileReferenceNumber
                folderList(curAddFolder).parentFolderNumber = UsnInfo.ParentFileReferenceNumber
            End If

            curAddFile = curAddFile + 1
            If curAddFile > UBound(fileList) Then ReDim Preserve fileList(curAddFile + 100000)
            fileList(curAddFile).FileName = tmpF
            fileList(curAddFile).fileNumber = UsnInfo.FileReferenceNumber
            fileList(curAddFile).parentFileNumber = UsnInfo.ParentFileReferenceNumber
            'If InStr(folderList(curAddFolder).folderName, "神话（连续剧）") > 0 Or InStr(folderList(curAddFolder).folderName, "人工智能") > 0 Then                  '调试
                'Print #curF, fileList(curAddFile).FileName, DoubleToHex(fileList(curAddFile).fileNumber), DoubleToHex(fileList(curAddFile).parentFileNumber)
            'End If
            countFile = countFile + 1
            seat = seat + UsnInfo.RecordLength
        Loop
        CopyMemory2 VarPtr(BufferIn), VarPtr(BufferOut(0)), 8
    Loop
    Dim djd As DELETE_USN_JOURNAL_DATA
    djd.UsnJournalID = ujd.UsnJournalID
    djd.DeleteFlags = USN_DELETE_FLAG_DELETE
    res = DeviceIoControl(hVol, FSCTL_DELETE_USN_JOURNAL, djd, Len(djd), Null, 0, dwRet, lpO)
    CloseHandle hVol
    
'Exit Sub
    'Debug.Print curAddFile, countLoop
    
    
    ReDim folderIndex(1 To curAddFolder)       '创建目录索引
    Dim ct As Long
    ct = timeGetTime
    For cc = 1 To curAddFolder
        folderIndex(cc).folderNumber = folderList(cc).folderNumber
        folderIndex(cc).myID = cc
    Next
    '''''''索引排序
    SortFolderIndex 1, curAddFolder
    '''''''''''填入父ID
    Debug.Print "time", disk, timeGetTime - ct
    Dim fIndex As Long
    For cc = 1 To curAddFolder
        If folderList(cc - 1).parentID <> 0 And folderList(cc).parentFolderNumber = folderList(cc - 1).parentFolderNumber Then
            folderList(cc).parentID = folderList(cc - 1).parentID
        Else
            fIndex = NumFind(folderList(cc).parentFolderNumber)
            'If cc = 91635 Then Stop
            If fIndex > 0 Then
                If cc <> folderIndex(fIndex).myID Then
                    folderList(cc).parentID = folderIndex(fIndex).myID
                End If
            End If
        End If
    Next

    
    Dim allPath As String, curParent As Double, nextParentID As Long
    Dim lastParent As Double
    For cc = 1 To curAddFile
        'If fileList(cc).FileName = "神话（连续剧）" Or fileList(cc).FileName = "人工智能" Then
            'Debug.Print fileList(cc).parentFileNumber
        '    Stop
        'End If
        
        If lastParent = fileList(cc).parentFileNumber Then  ' UsnInfo.ParentFileReferenceNumber Then
            fileList(cc).fPath = fileList(cc - 1).fPath ' disk & "\" & allPath
        Else
            allPath = ""
            curParent = fileList(cc).parentFileNumber 'UsnInfo.ParentFileReferenceNumber
            fIndex = NumFind(curParent)
            If fIndex > 0 Then
                allPath = folderList(folderIndex(fIndex).myID).folderName & "\"
                nextParentID = folderList(folderIndex(fIndex).myID).parentID
            End If

            Do While nextParentID > 0
                allPath = folderList(nextParentID).folderName & "\" & allPath
                nextParentID = folderList(nextParentID).parentID
            Loop
            fileList(cc).fPath = disk & "\" & allPath
        End If
        lastParent = fileList(cc).parentFileNumber ' UsnInfo.ParentFileReferenceNumber
    Next
    Erase folderList
    Erase folderIndex
    
Exit Sub
    For cc = 1 To curAddFile
        Print #curF, fileList(cc).FileName, fileList(cc).fPath ' DoubleToHex(fileList(cc).fileNumber)
    Next

End Sub
Private Function NumFind(FNumber As Double) As Long
    Dim K As Long, i As Long
    Dim L1 As Long, R1 As Long
    Dim l As Long, R As Long
    
    l = LBound(folderIndex): R = UBound(folderIndex)
    
NextLoop:
    K = (l + R) Mod 2
    If K = 1 Then '中点
       i = (l + R + 1) / 2
    Else
       i = (l + R) / 2
    End If
    If folderIndex(i).folderNumber <> FNumber Then
       If folderIndex(i).folderNumber > FNumber Then
          L1 = l: R1 = i
       Else
          L1 = i: R1 = R
       End If
       If (R1 - L1) = 1 Then '第一个和最后一个
          If folderIndex(L1).folderNumber = FNumber Then
             NumFind = L1
          ElseIf folderIndex(R1).folderNumber = FNumber Then
             NumFind = R1
          Else
             NumFind = -1 '没有发现
          End If
       Else
          l = L1: R = R1
          GoTo NextLoop
       End If
    Else
       NumFind = i
    End If
End Function

Private Sub SortFolderIndex(l As Long, R As Long)
    Dim i As Long, J As Long, A As Long
    Dim TmpX As TypeFolderIndex, TmpA As TypeFolderIndex
    i = l: J = R: TmpX = folderIndex((l + R) / 2)
    While (i <= J)
        While (folderIndex(i).folderNumber < TmpX.folderNumber And i < R)
            i = i + 1
        Wend
        While (TmpX.folderNumber < folderIndex(J).folderNumber And J > l)
            J = J - 1
        Wend
        If (i <= J) Then
            TmpA = folderIndex(i)
            folderIndex(i) = folderIndex(J)
            folderIndex(J) = TmpA
            i = i + 1: J = J - 1
        End If
    Wend
    If (l < J) Then Call SortFolderIndex(l, J) ' Call NumSortAZ(folderIndex, l, J)
    If (i < R) Then Call SortFolderIndex(i, R) 'Call NumSortAZ(folderIndex, I, R)
End Sub

Private Function DoubleToHex(ByVal Dbl As Double) As String
Dim lo As Long
Dim hi As Long
Dim n() As Long
ReDim n(1)
CopyMemory n(0), Dbl, 8
'lo = DoubleToLongs(Dbl, hi)
DoubleToHex = CStr(Hex(n(1))) & CStr(Hex(n(0)))
End Function

Private Function DoubleToLongs(ByVal Dbl As Double, ByRef SizeHigh As Long) As Long
    Dim SizeLowDbl As Double
    SizeHigh = Fix(Dbl / 4294967296#)
    SizeLowDbl = Dbl - SizeHigh * 4294967296#
    If SizeLowDbl > 2147483647 Then
        DoubleToLongs = CLng(SizeLowDbl - 2147483648#) Xor &H80000000
    Else
        DoubleToLongs = SizeLowDbl
    End If
End Function

Public Function CDblEx(ByVal l As Long) As Double   'LongToDouble
    CDblEx = -CDbl(l And &H80000000) + (l And &H7FFFFFFF)
End Function
Private Function IsNTFS(driveCha As String) As Boolean
Dim res As Long, ts As String, intLen As Long, sysFlags As Long
Dim strNTFS As String
    strNTFS = Space(256)
    If GetVolumeInformation(driveCha & ":\", ts, 0, 0, intLen, sysFlags, strNTFS, 256) Then
        strNTFS = Left(strNTFS, InStr(strNTFS, Chr(0)) - 1)
        If UCase(strNTFS) = "NTFS" Then IsNTFS = True
    End If
End Function

Private Function StripNulls(OriginalStr As String) As String
    If (InStr(OriginalStr, Chr(0)) > 0) Then
        OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
    End If
    StripNulls = OriginalStr
End Function

'非递归法遍历目录
Public Function SearchFiles(driveCha As String, Optional uboundJump As Long = 10000) As Long ', GetFilePathName() As String) As Long
    Dim hSearch As Long
    Dim WFD As WIN32_FIND_DATA
    Dim cF As Long
    Dim curPath As String
    Dim CountAll As Long, curUbound As Long
    Dim NextSearch As Long
    Dim FileName As String
    Dim GetFilePathName() As String
    curUbound = uboundJump
    ReDim GetFilePathName(curUbound)
    GetFilePathName(0) = driveCha & ":" ', Left(driveCha, Len(driveCha) - 1), driveCha)
    Do
        curPath = GetFilePathName(cF)
        If GetFileAttributes(curPath) And FILE_ATTRIBUTE_DIRECTORY Then
            curPath = curPath & "\*"
            hSearch = FindFirstFile(curPath, WFD)
            If hSearch <> INVALID_HANDLE_VALUE Then
                Do
                    FileName = StripNulls(WFD.cFileName)
                    If (FileName <> ".") And (FileName <> "..") Then
                        CountAll = CountAll + 1
                        If CountAll > curUbound Then
                            curUbound = curUbound + 10000
                            ReDim Preserve GetFilePathName(curUbound)
                        End If
                        GetFilePathName(CountAll) = GetFilePathName(cF) & "\" & FileName
                        'Form1.TestFile GetFilePathName(cF), FileName
                        countFile = countFile + 1
                        Print #curF, FileName, GetFilePathName(cF)
                    End If
                    
                    NextSearch = FindNextFile(hSearch, WFD)
                Loop While NextSearch > 0
            End If
            Call FindClose(hSearch)
        End If
    cF = cF + 1
    Loop While cF <= CountAll
    SearchFiles = CountAll
End Function

和其他语言对比，纯VB代码实现USN读取要慢得多，性能大概相差一倍以上。