VB 极速自动备份文件助手 涉及可识别 Unicode 编码文件名

‘模块名 CopyUnicodeFileEx

Option Explicit
Private Const KEY_SHIFT = &H10
Private Const KEY_CTRL = &H11
Private Const vbAllFiles = "*.*"
Private Const MAXDWORD As Long = &HFFFFFFFF
Private Const MAX_PATH As Long = 260
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10

'Define possible return codes from the CopyFileEx callback routine
Private Const PROGRESS_CONTINUE As Long = 0
Private Const PROGRESS_CANCEL As Long = 1
Private Const PROGRESS_STOP As Long = 2
Private Const PROGRESS_QUIET As Long = 3

'CopyFileEx callback routine state change values
Private Const CALLBACK_CHUNK_FINISHED As Long = &H0
Private Const CALLBACK_STREAM_SWITCH As Long = &H1

'CopyFileEx option flags
Private Const COPY_FILE_FAIL_IF_EXISTS As Long = &H1            '如果目标存在则失败返回
Private Const COPY_FILE_RESTARTABLE As Long = &H2               '若失败则重新开始
Private Const COPY_FILE_OPEN_SOURCE_FOR_WRITE As Long = &H4

Private Type FILETIME
    LowDate As Long
    HighDate 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 * 1024  '防止崩溃
End Type

Private Type SECURITY_ATTRIBUTES
   nLength As Long
   lpSecurityDescriptor As Long
   bInheritHandle As Long
End Type
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function FindClose Lib "kernel32" _
  (ByVal hFindFile As Long) As Long
   
Private Declare Function CopyFileExW Lib "kernel32" ( _
   ByVal lpExistingFileName As Long, _
   ByVal lpNewFileName As Long, _
   ByVal lpProgressRoutine As Long, _
   lpData As Any, _
   pbCancel As Long, _
   ByVal dwCopyFlags As Long) As Long

Private Declare Function FindFirstFileW Lib "kernel32" ( _
    ByVal lpFileName As Long, _
    ByVal lpFindFileData As Long) As Long
Private Declare Function GetFileSizeEx Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpFileSize As Currency) As Boolean
Private Declare Function GetFileType Lib "kernel32" (ByVal hFile As Long) As Long
Private Declare Function GetFinalPathNameByHandleW Lib "kernel32" ( _
    ByVal hFile As Long, _
    cchFilePathBuffer As Any, _
    ByVal FilePathLength As Long, _
    ByVal dwFlags As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Public bCancelBackup As Long, TmpL As Single
Public FrmM As Object
                                                    
Private Function FARPROC(ByVal pfn As Long) As Long
'接收和返回的伪过程 'AddressOf运算符的值。
 FARPROC = pfn: End Function

Private Function CopyProgressCallback(ByVal TotalFileSize As Currency, _
                                     ByVal TotalBytesTransferred As Currency, _
                                     ByVal StreamSize As Currency, _
                                     ByVal StreamBytesTransferred As Currency, _
                                     ByVal dwStreamNumber As Long, _
                                     ByVal dwCallbackReason As Long, _
                                     ByVal hSourceFile As Long, _
                                     ByVal hDestinationFile As Long, _
                                     lpData As Long) As Long
   Select Case dwCallbackReason
      Case CALLBACK_STREAM_SWITCH  ' { 准备开始}
        FrmM.picFill.Move 0, 0, 0
        TmpL = FrmM.picProgress.Width / (TotalFileSize)
        'FrmM.picProgress.Refresh
        CopyProgressCallback = PROGRESS_CONTINUE
      Case CALLBACK_CHUNK_FINISHED          '复制进行中
         FrmM.picFill.Move 0, 0, TotalBytesTransferred * TmpL
         FrmM.lblLabelProgress.Caption = "已完成: " & FormatPercent(FrmM.picFill.Width / FrmM.picProgress.Width, 0)
         DoEvents
         CopyProgressCallback = PROGRESS_CONTINUE
   End Select
   If FrmM.Visible = False Then
   If GetCTRLSHIFTState(8) Then FrmM.Visible = True: FrmM.ComD(2).Enabled = True
    End If
End Function
'用法Call FileCopyWProgress(sSourceFile, sTargetFile, True, 0, Me.ProgressBar1, Me.lblLabelProgress)
Public Function FileCopyWProgress( _
                sSourceFile As String, _
                sTargetFile As String, _
    Optional ByRef Form As Object) As Boolean
    Dim IsCallback As Long
   'Me.picProgress, Me.picFill, Me.lblLabelProgress
   If VarType(Form) = 9 Then
        IsCallback = FARPROC(AddressOf CopyProgressCallback)
    Set FrmM = Form: End If
    bCancelBackup = 0: MkFolderTree sTargetFile
    FileCopyWProgress = CopyFileExW(StrPtr(sSourceFile), _
                                 StrPtr(sTargetFile), _
                                 IsCallback, _
                                 0&, _
                                 bCancelBackup, _
                                 COPY_FILE_RESTARTABLE) = 1
End Function

'从句柄中获取文件的全路径
Private Function CloseFileByHandle(FinalPathName As String) As Boolean
    Dim i As Long, UnicodeFileFullPath As String
    For i = 1 To 10000
    If GetFinalPathNameByHandleX(i, UnicodeFileFullPath) > 0 Then
    If InStr(UnicodeFileFullPath, FinalPathName) > 0 Then
    'If Right(UnicodeFileFullPath, Len(FinalPathName)) = FinalPathName Then
    CloseFileByHandle = CloseHandle(i): Exit Function
    End If: End If: Next
End Function
'从句柄中获取文件的全路径
Private Function GetFinalPathNameByHandleX(hFile As Long, FinalPathName As String) As Long
    Dim Buf() As Byte
    GetFinalPathNameByHandleX = GetFinalPathNameByHandleW(hFile, 0, 0, 0)
    If GetFinalPathNameByHandleX = 0 Then Exit Function
    ReDim Buf(1 To GetFinalPathNameByHandleX * 2) As Byte
    Call GetFinalPathNameByHandleW(hFile, Buf(1), GetFinalPathNameByHandleX * 2, 0)  '务必保留两个 NULL 即 0 0
FinalPathName = Buf: End Function
'判断文件是否存在 支持 Unicode 文件名 返回值 1 是 文件夹 2 文件 其中 Attributes 属性值
Private Function FileExistsW(SourcePath As String, Optional Attributes As Long) As Long
    On Error GoTo ErrorHandler
    If Len(SourcePath) < 3 Then Exit Function
    Attributes = GetAttr(SourcePath)
    If (Attributes And vbDirectory) Then
        If Right(SourcePath, 1) <> "\" Then SourcePath = SourcePath & "\"
        FileExistsW = 1
    Else: FileExistsW = 2: End If
    If Attributes = 0 Then Stop
    Exit Function
    '发现超大文件不能得到有效值
ErrorHandler:
    Dim iWFD  As WIN32_FIND_DATA
    If Right(SourcePath, 1) = "\" Then
        While Right(SourcePath, 2) = "\\": SourcePath = Left(SourcePath, Len(SourcePath) - 1): Wend
        FileExistsW = FindFirstFileW(StrPtr(SourcePath & vbAllFiles), VarPtr(iWFD))
    Else: FileExistsW = FindFirstFileW(StrPtr(SourcePath), VarPtr(iWFD))
    End If: Call FindClose(FileExistsW)
    If FileExistsW < 1 Then FileExistsW = 0: Exit Function
    If (iWFD.dwFileAttributes And vbDirectory) Then
        SourcePath = SourcePath & "\"  '是文件夹补 "\"
        FileExistsW = 1
    Else: FileExistsW = 2: End If
End Function
Private Sub MkFolderTree(ByVal SourcePath As String, Optional ByVal tPath As String = "XYZ")
    Dim i As Integer: On Error GoTo Er
    If tPath = "XYZ" Then
        If FileExistsW(SourcePath) > 0 Then Exit Sub
        SourcePath = Left(SourcePath, InStrRev(SourcePath, "\"))
        If FileExistsW(SourcePath) Then Exit Sub
    End If
    i = InStr(Len(tPath) + 1, SourcePath, "\")
    If i > 0 Then
        tPath = Left(SourcePath, i)
        If FileExistsW(tPath) = 0 Then MkDir tPath
        MkFolderTree SourcePath, tPath     '递归
    ElseIf FileExistsW(SourcePath) = 0 Then
        MkDir SourcePath
    End If
Er:: End Sub
Public Sub RegWrite(ByVal KeyFullName As String, KeyValue, Optional KeyType)
'使用方法
'regWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName, App.Path & "\" & App.EXEName & ".exe"
'regWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName, 1, "REG_DWORD"
CreateObject("WScript.Shell").RegWrite KeyFullName, KeyValue, KeyType
End Sub
Public Sub RegDelete(ByVal KeyFullName As String)
'使用方法
'RegRead "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName, App.Path & "\" & App.EXEName & ".exe"
On Error GoTo Er
Call CreateObject("WScript.Shell").RegDelete(KeyFullName)
Er:: End Sub
Function RegRead(KeyFullName As String) As String
    On Error GoTo Er
    '使用方法
    'RegRead "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName, App.Path & "\" & App.EXEName & ".exe"
    RegRead = CreateObject("WScript.Shell").RegRead(KeyFullName)
Er:: KeyFullName = vbNullString
End Function
Function GetCTRLSHIFTState(sKEY As String) As Boolean
Dim AR(2) As Integer
AR(0) = GetAsyncKeyState(Asc(sKEY))
AR(1) = GetAsyncKeyState(KEY_CTRL)
AR(2) = GetAsyncKeyState(KEY_SHIFT)
GetCTRLSHIFTState = AR(0) And AR(1) And AR(2)
'Debug.Print Ar(0), Ar(1), Ar(2), GetCTRLSHIFTState
End Function

‘模块名 PreventRepStart 功能时防止APP重复开启

Option Explicit
Type MEMORYSTATUS
dwLength As Long
dwMemoryLoad As Long
dwTotalPhys As Long
dwAvailPhys As Long
dwTotalPageFile As Long
dwAvailPageFile As Long
dwTotalVirtual As Long
dwAvailVirtual As Long
End Type
'功能是设置App只能用心一个在进程中
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
                          ByVal hWnd As Long, _
                          ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" ( _
                          ByVal hWnd As Long, _
                          ByVal nIndex As Long, _
                          ByVal dwNewLong As Long _
                          ) As Long
Private Const GW_HWNDNEXT = 2
Private Const GW_CHILD = 5
Public Function ThisAppIsOpened(MehWnd As Long) As Boolean: Dim ihWnd As Long
    ihWnd = GetWindow(GetDesktopWindow(), GW_CHILD)
    Do While ihWnd <> 0
    If MehWnd <> ihWnd Then If ihWnd = GetWindowLong(ihWnd, -21) Then _
    ThisAppIsOpened = True: Exit Function
    ihWnd = GetWindow(ihWnd, GW_HWNDNEXT): DoEvents: Loop
End Function
Public Function SetAppMD5(MehWnd As Long) As Long
    Dim T As Long
    While SetAppMD5 <> MehWnd And T < 1000
    SetAppMD5 = SetWindowLong(MehWnd, -21, MehWnd)
T = T + 1: Wend: End Function

‘模块名 BackedUp 功能遍历文件夹等功能

Option Explicit
Private Declare Function GetDiskFreeSpaceEx2 Lib "kernel32" Alias _
  "GetDiskFreeSpaceExA" (ByVal lpDirectoryName As String, _
  lpFreeBytesAvailableToCaller As Currency, lpTotalNumberOfBytes As Currency, _
  lpTotalNumberOfFreeBytes As Currency) As Long

Private Declare Function QueryPerformanceCounter Lib "kernel32 " (lpPerformanceCount As Any) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32 " (lpFrequency As Any) As Long
Public Declare Function timeGetTime Lib "winmm.dll" () As Long      '该声明得到系统开机到现在的时间(单位：毫秒)

Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const CREATE_NEW = 1
Private Const CREATE_ALWAYS = 2
Private Const OPEN_EXISTING = 3
Private Declare Function SetFilePointer Lib "kernel32" ( _
    ByVal hFile As Long, _
    ByVal lDistanceToMove As Long, _
    lpDistanceToMoveHigh As Long, _
    ByVal dwMoveMethod As Long) As Long
Private Declare Function ReadFile Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpBuffer As Any, _
    ByVal nNumberOfBytesToRead As Long, _
    lpNumberOfBytesRead As Long, _
    ByVal lpOverlapped As Any) As Long
Private Declare Function CreateFileW Lib "kernel32" ( _
    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 CloseHandle Lib "kernel32.dll" ( _
    ByVal hObject As Long) As Long


Private Declare Sub GetSystemTimeAsFileTime Lib "kernel32.dll" ( _
    ByRef lpSystemTimeAsFileTime As Currency)
    
    
'变量定义
Private Const vbAllFiles = "*.*"
Private Const vbKeyDot = 46
Private Const vbBackslash = "\"
Private WFD As WIN32_FIND_DATA

Private Type FILETIME
    LowDate As Long
    HighDate As Long
End Type

Private Type SYSTEMTIME ' 16 Bytes
    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 Type WIN32_FIND_DATA
    dwFileAttributes    As Long
    ftCreationTime      As Currency
    ftLastAccessTime    As Currency
    ftLastWriteTime     As Currency
    FileSize            As Currency
    dwReserved0         As Long
    dwReserved1         As Long
    FileName            As String * 260     '260 否则得不到正确的 ShortFileName
    ShortFileName       As String * 1024    '写1024 是为了程序不出 APPCRASH 错误 含有 260
End Type
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Private Declare Function FindFirstFileW Lib "kernel32" (ByVal lpFileName As Long, ByVal lpFindFileData As Long) As Long
Private Declare Function FindNextFileW Lib "kernel32" (ByVal hFindFile As Long, ByVal lpFindFileData As Long) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Type FileAtt
    dwFileAttributes    As Integer
    ftCreationTime      As Currency
    ftLastAccessTime    As Currency
    ftLastWriteTime     As Currency
    FileSize            As Currency '包含文件名 属性 和 大小
    Name                As String
    'ShortName           As String
    Path                As String
End Type
Private Declare Function GetFileTime Lib "kernel32.dll" ( _
    ByVal hFile As Long, _
    ByRef lpCreationTime As FILETIME, _
    ByRef lpLastAccessTime As FILETIME, _
    ByRef lpLastWriteTime As FILETIME) As Long
Private Declare Function SetFileTime Lib "kernel32.dll" ( _
    ByVal hFile As Long, _
    ByRef lpCreationTime As Currency, _
    ByRef lpLastAccessTime As Currency, _
    ByRef lpLastWriteTime As Currency) As Long
Private TotalFiles As Long, TotalNFiles As Long
Public FA() As FileAtt, nFA() As String
Public ReBackup As Boolean    '重新备份文件
  '是否為正確的文件路徑
Private Function EvalName(ByVal sName As String) As Boolean
    If Len(sName) < 3 Then Exit Function
    If InStrRev("'.- _", Left(sName, 1)) Then Exit Function
    If InStrRev("'.- _", Right(sName, 1)) Then Exit Function
    If InStrRev(sName, vbBackslash) < 3 Then Exit Function
    If InStr(sName, ":") <> 2 Or Len(sName) < 2 Then Exit Function
    Dim AR, i As Byte, Br() As Byte
    i = Len(sName) - InStrRev(sName, "\")
    If i Then
    Br = StrConv(Right(sName, i), vbFromUnicode)
    If UBound(Br) > 179 Then Exit Function
    End If
    AR = Array("""", "*", "<", ">", "?", "/", "|", ":")
    For i = LBound(AR) To UBound(AR)
        If InStr(sName, AR(i)) > 2 Then Exit Function
    Next:
    For i = 0 To 31
    If InStr(sName, Chr(i)) Then Exit Function
    Next: AR = Split(sName, "\")
    For i = LBound(AR) To UBound(AR)
        If Len(AR(i)) > 2 Then _
        If InStr("CON PRN AUX NUL COM1 COM2 COM3 COM4 COM5 COM6 COM7 COM8 COM9 LPT1 LPT2 LPT3 LPT4 LPT5 LPT6 LPT7 LPT8 LPT9", AR(i)) Then Exit Function
    Next
EvalName = True: End Function
'给文件设置是否修改的标记
Public Function FileSetMark(ID As Long) As Boolean
    Dim lngHandle As Long, i As Integer, FSize As Currency, Cur As Currency
    On Error GoTo Er
    If FA(ID).dwFileAttributes <> 32 Then SetAttr FA(ID).Path & FA(ID).Name, vbNormal
    lngHandle = CreateFileW(StrPtr(FA(ID).Path & FA(ID).Name), GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
    If lngHandle <= 0 Then Exit Function
    'Dim CreateTime As FILETIME, LastAccessTime As FILETIME, ModifyTime As FILETIME
    'CopyMemory ByVal VarPtr(CreateTime.LowDate), ByVal VarPtr(FA(ID).ftCreationTime), 8
    'CopyMemory ByVal VarPtr(LastAccessTime.LowDate), ByVal VarPtr(FA(ID).ftLastAccessTime), 8
    'CopyMemory ByVal VarPtr(ModifyTime.LowDate), ByVal VarPtr(FA(ID).ftLastWriteTime), 8
    'FileSetMark = SetFileTime(lngHandle, CreateTime, LastAccessTime, ModifyTime)
    FileSetMark = SetFileTime(lngHandle, FA(ID).ftCreationTime, FA(ID).ftLastAccessTime, FA(ID).ftLastWriteTime)
    Call CloseHandle(lngHandle)
Er:: End Function
'获取文件大小 高效率 '注意 WFD的 高低 位 已经交换 方便与 FILETIME 高地位一致   2022?年?10?月?23?日，??3:35:09  2022?年?11?月?16?日，??12:18:25
Private Function WFDGetFileSize() As Currency: Dim Ret As Long
    '交换高低位
    CopyMemory ByVal VarPtr(Ret), ByVal VarPtr(WFD.FileSize) + 4, 4
    CopyMemory ByVal VarPtr(WFD.FileSize) + 4, ByVal VarPtr(WFD.FileSize), 4
    CopyMemory ByVal VarPtr(WFD.FileSize), ByVal VarPtr(Ret), 4
    '取大小
    WFDGetFileSize = WFD.FileSize * 10000
End Function

'获取单个文件的 WFD 值
Public Function GetFilesFA(ByVal FileFullPath As String) As Long
    GetFilesFA = FindFirstFileW(StrPtr(FileFullPath), VarPtr(WFD))
    If GetFilesFA < 1 Then GetFilesFA = 0: Exit Function
    Call FindClose(GetFilesFA)
    CopyMemory ByVal VarPtr(WFD.dwReserved1), ByVal VarPtr(WFD.FileSize) + 4, 4
    CopyMemory ByVal VarPtr(WFD.FileSize) + 4, ByVal VarPtr(WFD.FileSize), 4
    CopyMemory ByVal VarPtr(WFD.FileSize), ByVal VarPtr(WFD.dwReserved1), 4
End Function
Public Function rNewFileFull(ByVal FileFullPath As String, ByVal BackUpDisk As String) As String
    rNewFileFull = BackUpDisk & "$" & Replace(FileFullPath, ":\", "\")
    'rNewFileFull = Replace(FileFullPath, Left(FileFullPath, 3), BackUpDisk)
End Function

 '比较两个文件是否内容相同
Public Function CompareFileToFA(ByVal ID As Long, ByVal BackUpDisk As String) As Boolean
    Dim rB() As Byte, wB() As Byte, sPath As String, rRet As Long, wRet As Long
    Dim hOrgFile As Long, hNewFile As Long, PointerPosition As Currency
    sPath = rNewFileFull(FA(ID).Path, BackUpDisk) & FA(ID).Name
    If GetFilesFA(sPath) < 1 Then Exit Function
    If FA(ID).ftLastWriteTime <> WFD.ftLastWriteTime Then Exit Function          '可以说明是由 ID 复制到 BackUpDisk 吧
    If (FA(ID).FileSize <> (WFD.FileSize * 10000)) Then Exit Function
    CompareFileToFA = True: Exit Function
    '以下检索文件能容
    hOrgFile = CreateFileW(StrPtr(FA(ID).Path & FA(ID).Name), GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
    If hOrgFile <= 0 Then Exit Function
    hNewFile = CreateFileW(StrPtr(sPath), GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
    If hNewFile <= 0 Then Exit Function
    If FA(ID).FileSize < 2 ^ 20 Then
        ReDim rB(1 To FA(ID).FileSize) As Byte, wB(1 To FA(ID).FileSize) As Byte
        Call ReadFile(hOrgFile, rB(1), UBound(rB), rRet, ByVal 0&)
        Call ReadFile(hNewFile, wB(1), UBound(wB), wRet, ByVal 0&)
    Else: rRet = 1048576: wRet = 1048576: ReDim rB(1 To wRet) As Byte, wB(1 To wRet) As Byte
        Call ReadFile(hOrgFile, rB(1), UBound(rB), rRet, ByVal 0&)
        Call ReadFile(hNewFile, wB(1), UBound(wB), wRet, ByVal 0&)
        If (InStrB(rB, wB) <> 1) Then GoTo Er
        PointerPosition = UBound(wB)
        If FA(ID).FileSize < 3145729 Then
            While PointerPosition < FA(ID).FileSize And (rRet = wRet) And wRet > 0
                Call ReadFile(hOrgFile, rB(1), UBound(rB), rRet, ByVal 0&)
                Call ReadFile(hNewFile, wB(1), UBound(wB), wRet, ByVal 0&)
                If (InStrB(rB, wB) <> 1) Then GoTo Er
            PointerPosition = PointerPosition + UBound(wB): Wend
        Else
            PointerPosition = (FA(ID).FileSize - UBound(wB)) / 20000  '中间值
            Call FxSetFilePointer(hOrgFile, PointerPosition, 0)
            Call FxSetFilePointer(hNewFile, PointerPosition, 0)
            Call ReadFile(hOrgFile, rB(1), UBound(rB), rRet, ByVal 0&)
            Call ReadFile(hNewFile, wB(1), UBound(wB), wRet, ByVal 0&)
            If (InStrB(rB, wB) <> 1) Then GoTo Er

            PointerPosition = (FA(ID).FileSize - UBound(wB)) / 20000  '最后的值
            Call FxSetFilePointer(hOrgFile, -104.8576, 2)
            Call FxSetFilePointer(hNewFile, -104.8576, 2)
            Call ReadFile(hOrgFile, rB(1), UBound(rB), rRet, ByVal 0&)
            Call ReadFile(hNewFile, wB(1), UBound(wB), wRet, ByVal 0&)
            If (InStrB(rB, wB) <> 1) Then GoTo Er
    End If: End If: CompareFileToFA = True
Er:: Call CloseHandle(hOrgFile): Call CloseHandle(hNewFile)
End Function
'设定文件指针位置
'例如：Call FxSetFilePointer(hOrgFile, L / 10000, FILE_BEGIN)
'      Call FxSetFilePointer(hOrgFile, -0.0016, FILE_END)
Private Function FxSetFilePointer(ByVal hFile As Long, ByVal lDistanceToMove As Currency, _
    Optional ByVal dwMoveMethod As Long) As Currency
    Dim SeekHL As FILETIME: CopyMemory SeekHL, lDistanceToMove, 8
    FxSetFilePointer = SetFilePointer(hFile, SeekHL.LowDate, SeekHL.HighDate, dwMoveMethod)
End Function
'从文件或者文件夹获取未备份文件 建议尾部不要 \
Public Function GetFilesNotBackedUp(SourcePath As String) As Long
    If FileExistsW(SourcePath) < 1 Then
        SourcePath = "请选择正确的需要备份的文件夹"
    Exit Function: End If: ReDim FA(0): ReDim nFA(0)
    TotalFiles = 0: TotalNFiles = 0
    If Right(SourcePath, 1) = "\" Then
        Call GetFilesNotBackedUpA(SourcePath)
    ElseIf GetFilesFA(SourcePath) Then
        ReDim FA(1): TotalFiles = 1
        FA(1).Path = Left$(SourcePath, InStrRev(SourcePath, "\"))
      '  FA(1).Name = Left$(WFD.FileName, InStr(WFD.FileName, vbNullChar) - 1)
       ' CopyMemory ByVal VarPtr(FA(1).dwFileAttributes), ByVal VarPtr(WFD.dwFileAttributes), 28
      '  FA(1).FileSize = WFD.FileSize * 10000
    End If
    If TotalFiles > 0 Then If UBound(FA) > TotalFiles Then ReDim Preserve FA(LBound(FA) To TotalFiles)
    If TotalNFiles > 0 Then If UBound(nFA) > TotalNFiles Then ReDim Preserve nFA(LBound(nFA) To TotalNFiles)
    GetFilesNotBackedUp = TotalFiles
    'Erase FA
    Erase nFA
End Function
Private Sub GetFilesNotBackedUpA(ByVal SourcePath As String)
    Dim i As Long, k As Long, hFile As Long, FileSize As Currency
    Dim mName As String, Dirbuf() As String, OutDos As String
    'If SourcePath = "G:\word\VisualStudio\" Then Stop
    hFile = FindFirstFileW(StrPtr(SourcePath & vbAllFiles), VarPtr(WFD))
    If hFile <> -1 Then
        Do: DoEvents
        If (WFD.dwFileAttributes And vbDirectory) Then
            If WFD.dwFileAttributes <> 22 Then          '加密文件夹不要
                mName = Left$(WFD.FileName, InStr(WFD.FileName, vbNullChar) - 1)
                If mName <> "." And mName <> ".." Then
                    If (k Mod 10) = 0 Then ReDim Preserve Dirbuf$(1 To k + 10)
            k = k + 1: Dirbuf(k) = mName: End If: End If
        ElseIf WFD.FileSize <> 0 Then
                If (TotalFiles Mod 1000) = 0 Then ReDim Preserve FA(TotalFiles + 1000)
                TotalFiles = TotalFiles + 1: OutFA TotalFiles, SourcePath
        Else
            If (TotalNFiles Mod 1000) = 0 Then ReDim Preserve nFA(TotalNFiles + 1000)
            TotalNFiles = TotalNFiles + 1
            nFA(TotalNFiles) = SourcePath & Left$(WFD.FileName, InStr(WFD.FileName, vbNullChar) - 1)
        End If: Loop While FindNextFileW(hFile, VarPtr(WFD))
    End If: Call FindClose(hFile)
    For i = 1 To k: GetFilesNotBackedUpA SourcePath & Dirbuf$(i) & vbBackslash: Next i '递归
End Sub
Private Function OutFA(ID As Long, ByVal SourcePath As String) As Long
    FA(ID).Path = SourcePath
    FA(ID).Name = Left$(WFD.FileName, InStr(WFD.FileName, vbNullChar) - 1)
   ' FA(ID).ShortName = Left$(WFD.ShortFileName, InStr(WFD.ShortFileName, vbNullChar) - 1)
    'If Len(FA(ID).ShortName) = 0 Then FA(ID).ShortName = FA(ID).Name
    CopyMemory ByVal VarPtr(OutFA), ByVal VarPtr(WFD.FileSize) + 4, 4
    CopyMemory ByVal VarPtr(WFD.FileSize) + 4, ByVal VarPtr(WFD.FileSize), 4
    CopyMemory ByVal VarPtr(WFD.FileSize), ByVal VarPtr(OutFA), 4
    CopyMemory ByVal VarPtr(FA(ID).dwFileAttributes), ByVal VarPtr(WFD.dwFileAttributes), 28
    FA(ID).FileSize = WFD.FileSize * 10000
End Function
'判断文件是否备份过
Public Function IsBackupsFromFA(ID As Long) As Boolean
' If IsBackupsFromFA(FileSize) = False Then   '包含文件名称的信息
    Dim i As Byte, Characteristic  As String, Cur As Currency, LR As Currency
    Characteristic = FA(ID).FileSize + FA(ID).dwFileAttributes + HashLong(FA(ID).Name)
    If InStr(Characteristic, 0) > 0 Then _
    Characteristic = Replace(Characteristic, 0, Left(Characteristic, 1))
    LR = Right(Characteristic, 6) / 10000
    IsBackupsFromFA = Right(FA(ID).ftLastWriteTime, 7) = LR
    If IsBackupsFromFA = False Then _
    FA(ID).ftLastWriteTime = Int(FA(ID).ftLastWriteTime / 100) * 100 + LR
    IsBackupsFromFA = IsBackupsFromFA And ReBackup
End Function
'判断文件是否存在 支持 Unicode 文件名 返回值 1 是 文件夹 2 文件 其中 Attributes 属性值
Public Function FileExistsW(SourcePath As String, Optional Attributes As Long) As Long
    On Error GoTo ErrorHandler
    If Len(SourcePath) < 3 Then Exit Function
    Attributes = GetAttr(SourcePath)
    If (Attributes And vbDirectory) Then
        If Right(SourcePath, 1) <> "\" Then SourcePath = SourcePath & "\"
        FileExistsW = 1
    Else: FileExistsW = 2: End If
    If Attributes = 0 Then Stop
    Exit Function
    '发现超大文件不能得到有效值
ErrorHandler:
    Dim iWFD  As WIN32_FIND_DATA
    If Right(SourcePath, 1) = "\" Then
        While Right(SourcePath, 2) = "\\": SourcePath = Left(SourcePath, Len(SourcePath) - 1): Wend
        FileExistsW = FindFirstFileW(StrPtr(SourcePath & vbAllFiles), VarPtr(iWFD))
    Else: FileExistsW = FindFirstFileW(StrPtr(SourcePath), VarPtr(iWFD))
    End If: Call FindClose(FileExistsW)
    If FileExistsW <> 0 Then
        If (iWFD.dwFileAttributes And vbDirectory) Then
            SourcePath = SourcePath & "\"  '是文件夹补 "\"
            FileExistsW = 1
    Else: FileExistsW = 2: End If: End If
End Function
'Hash一个字符为一个不超过 2 ^ 30 的值
Public Function HashLong(ByVal PostSData As String) As Long
    Dim i As Long, tByte() As Byte, k As Currency
    tByte = StrConv(PostSData, 128)
    k = 2 + UBound(tByte) + tByte(LBound(tByte)) & tByte(UBound(tByte) / 2) & tByte(UBound(tByte))
    For i = LBound(tByte) To UBound(tByte): k = k + tByte(i)
    If k > &H7FFFFF00 Then k = k Mod 2 ^ 30
    Next: i = Right(k, 1) & Left(k, 1)
    k = k / i: While k < 2 ^ 29: k = k * 2: Wend
HashLong = k: End Function
 Sub FASort()
    Dim AR() As Currency, Br() As Long, i As Long, tFA() As FileAtt
    ReDim AR(LBound(FA) To UBound(FA))
    ReDim Br(LBound(FA) To UBound(FA))
    ReDim tFA(LBound(FA) To UBound(FA))
    For i = 1 To UBound(FA)
    AR(i) = FA(i).FileSize: Br(i) = i: Next
    QuickSort AR, Br, LBound(FA), UBound(FA)
    For i = 1 To UBound(FA)
    tFA(i).Name = FA(i).Name: tFA(i).Path = FA(i).Path
    CopyMemory ByVal VarPtr(tFA(i).dwFileAttributes), ByVal VarPtr(FA(i).dwFileAttributes), 36
    Next: For i = 1 To UBound(FA)
    FA(i).Name = tFA(Br(i)).Name: FA(i).Path = tFA(Br(i)).Path
    CopyMemory ByVal VarPtr(FA(i).dwFileAttributes), ByVal VarPtr(tFA(Br(i)).dwFileAttributes), 36
Next: End Sub

Public Sub QuickSort(qAr() As Currency, qID() As Long, LB As Long, UB As Long)
'快速排序法 ,其中 qID 返回原 Index
    Dim l As Long, H As Long
    Dim Povit As Currency, Temp As Currency
    l = LB: H = UB: Povit = qAr(LB)
    While l < H
        While (l < H And qAr(H) >= Povit): H = H - 1: Wend
        If l < H Then
            Temp = qAr(H): qAr(H) = qAr(l): qAr(l) = Temp
            Temp = qID(H): qID(H) = qID(l): qID(l) = Temp
        l = l + 1: End If
        While (l < H And qAr(l) <= Povit): l = l + 1: Wend
        If l < H Then
            Temp = qAr(H): qAr(H) = qAr(l): qAr(l) = Temp
            Temp = qID(H): qID(H) = qID(l): qID(l) = Temp
        H = H - 1: End If
    Wend
    If l > LB Then QuickSort qAr, qID, LB, l - 1
    If H < UB Then QuickSort qAr, qID, l + 1, UB
End Sub

‘模块名 BrowseFolder 功能选择文件夹功能

'''''''''''''''''''''''''''''BrowseForFolder
Public Enum BROWSETYPE
    NONE = 0
    PATHTEXT = 16
    NewFolder = 64
End Enum
Private Type BROWSEINFOTYPE
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
Private Const WM_USER = &H400
Private Const lPtr = (&H0 Or &H40)
Private Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Private Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
'Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBROWSEINFOTYPE As BROWSEINFOTYPE) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" (ByVal sRootPath _
  As String, ByVal InputPathName As String, ByVal OutputPathBuffer As String) _
  As Boolean
'''''''''''''''''''''''''''''BrowseForFolder
Private Sub BrowseCallbackProcStr(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long)
    If uMsg = 1 Then
    Call SendMessage(hWnd, BFFM_SETSELECTIONA, True, ByVal lpData)
    End If
End Sub
Private Function FunctionPointer(FunctionAddress As Long) As Long
    FunctionPointer = FunctionAddress
End Function
Public Function BrowseForFolder(ByVal hWnd As Long, ByVal strTitle As String, Optional selectedPath As String, Optional ByVal Flag As BROWSETYPE = 0) As String
    Dim Browse_for_folder As BROWSEINFOTYPE
    Dim itemID As Long
    Dim selectedPathPointer As Long
    Dim tmpPath As String * 256
    If selectedPath = "" Then selectedPath = "" '避免selectedPath未初始化而出错
    If Not Right(selectedPath, 1) <> "\" Then
    selectedPath = Left(selectedPath, Len(selectedPath) - 1) '如果用户加了 "\" 则删除
    End If
    With Browse_for_folder
        .hOwner = hWnd '所有都窗口之句柄
        .lpszTitle = strTitle '对话框的标题
        .ulFlags = Flag
        .lpfn = FunctionPointer(AddressOf BrowseCallbackProcStr) '用于设置预设文件夹的回调函数
        selectedPathPointer = LocalAlloc(lPtr, Len(selectedPath) + 1) '分配一个字符串内存
        Call CopyMemory(ByVal selectedPathPointer, ByVal selectedPath, Len(selectedPath) + 1) ' 拷贝那个路径到内存
        .lParam = selectedPathPointer ' 预设的文件夹
    End With
    itemID = SHBrowseForFolder(Browse_for_folder) '执行API函数：BrowseForFolder
    If itemID Then
        If SHGetPathFromIDList(itemID, tmpPath) Then '取得选定的文件夹
        BrowseForFolder = Left(tmpPath, InStr(tmpPath, vbNullChar) - 1) '去掉多余的 null 字符
        End If
        Call CoTaskMemFree(itemID) '释放内存
    End If
    Call LocalFree(selectedPathPointer) '释放内存
End Function
'''''''''''''''''''''''''''''BrowseForFolder

**‘窗体名 FrmMain

Option Explicit
Private Declare Function SetWindowPos Lib "user32.dll" (ByVal hWnd As Long, _
    ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, _
    ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Dim FormLoad As Boolean
Private Sub Form_Unload(Cancel As Integer): Close: Unload Me: End: End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer): Close: Unload Me: End: End Sub
Private Sub Form_Load()
    '防止重复启动
    If ThisAppIsOpened(Me.hWnd) Then
    MsgBox "程序已经启动,不能重复启动本程序！！！", , "微信:860013112 请关注抖音号:GGMPC    "
    Unload Me: End: End If
    Call SetAppMD5(Me.hWnd)
    '防止重复启动
    Dim i As Long, KeyValue
    On Error GoTo Er: FormLoad = True
    FrmMain.Caption = "备份大师永久免费，微信:860013112 请关注抖音号:GGMPC    "
    KeyValue = RegRead("HKEY_CURRENT_USER\Software\BackupMaster\" & App.EXEName)
    If InStrRev(KeyValue, "|") > 6 Then
    KeyValue = Split(KeyValue, "|")
    If UBound(KeyValue) = 6 Then
        For i = 3 To 5: Te(i).Text = KeyValue(i): Next: Che.Value = KeyValue(i)
        If Che.Value = 1 Then Me.Visible = False
    Else: RegDelete "HKEY_CURRENT_USER\Software\BackupMaster\": End If: End If
Er: FormLoad = False: tmrShow.Enabled = True
End Sub
Private Sub ComD_Click(Index As Integer)
    Dim i As Long, Str As String
    Str = Te(4).Text
    If FileExistsW(Str) < 1 Then
    Label4.Caption = "请选择正确的需要备份的文件夹"
    Te(4).Text = Label4.Caption: Exit Sub: End If
    Te(4).Text = Str
    Select Case Index
        Case 0, 1: Enabled0: ReBackup = Index: tmrShow.Enabled = False
            If GetFilesNotBackedUp(Trim(Te(4).Text)) > 0 Then BackedUpFiles Trim(Te(5).Text)    '获取所有文件信息放在 FA 并备
            Call Enabled1: tmrShow.Enabled = True
        Case 2: tmrShow.Enabled = True: Me.Visible = False
        Case 3: Call RegWrite("HKEY_CURRENT_USER\Software\BackupMaster\" & _
            App.EXEName, "1|2|3|" & Te(3).Text & "|" & Te(4).Text & "|" & Te(5).Text & "|" & Che.Value)
        Case 4, 5: Te(Index).Text = BrowseForFolder(Me.hWnd, "请选择文件夹", Te(Index).Text, PATHTEXT)
                If Index = 5 Then Te(Index).Text = Left(Te(Index).Text, 3)
        Case 6: bCancelBackup = True '停止复制 Te
        End Select
        'SetWindowPos Me.hwnd, -2, 0, 0, 0, 0, &H1 Or &H2       '取消最顶端
End Sub
Private Sub Enabled0(): Dim i As Byte
    For i = 0 To 5: ComD(i).Enabled = False: Next: ComD(i).Enabled = True
    For i = 3 To 5: Te(i).Enabled = False: Next: Che.Enabled = False
End Sub
Private Sub Enabled1(): Dim i As Byte
    For i = 0 To 5: ComD(i).Enabled = True: Next: ComD(i).Enabled = False
    For i = 3 To 5: Te(i).Enabled = True: Next: Che.Enabled = True
End Sub
Private Sub Che_Click()
    If FormLoad Then Exit Sub
    If Che.Value = 1 Then
        RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName, App.Path & "\" & App.EXEName & ".exe"
    Else: RegDelete "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName: End If
    Call RegWrite("HKEY_CURRENT_USER\Software\BackupMaster\" & App.EXEName, "1|2|3|" & Te(3).Text & "|" & Te(4).Text & "|" & Te(5).Text & "|" & Che.Value)
End Sub
Private Sub SetTimer(iTimer As Timer, ByVal Interval As Long)
    iTimer.Enabled = False: iTimer.Interval = Interval: iTimer.Enabled = True
End Sub
Private Sub List1_Click()
Clipboard.Clear
Clipboard.SetText List1.List(List1.ListIndex)
End Sub
Sub BackedUpFiles(ByVal BackUpDisk As String)
    Dim i As Long, k As Long, tFSize As Double
    Dim sPath As String ': Call FASort
    Dim picP As Single: bCancelBackup = 0
    'If FileExistsW(FA(i).Path & FA(i).Name) < 0 Then Stop
    Dim T As Long, FileSize As Double
    T = timeGetTime
    picP = picProgress.Width / UBound(FA)
    picFill.Move 0, 0, 0 '进度条初始状态
    For i = 1 To UBound(FA)
    If FA(i).FileSize > 1048576 Then
    Label4.Caption = FA(i).Path & FA(i).Name
    picFill.Move 0, 0, picP * i: End If
    'picFill.Move 0, 0, picP * i
    'If FA(i).Name = "SYSTEM.GHO" Then Stop
    If IsBackupsFromFA(i) = False Then                  '检查文件是否备份过 比 说 快 6~7 倍左右
        k = k + 1
        FA(k).Path = FA(i).Path: FA(k).Name = FA(i).Name
        CopyMemory ByVal VarPtr(FA(k)), ByVal VarPtr(FA(i)), 34
    ElseIf CompareFileToFA(i, BackUpDisk) = False Then  '比对文件是否和源文件一致
        k = k + 1
        FA(k).Path = FA(i).Path: FA(k).Name = FA(i).Name
        CopyMemory ByVal VarPtr(FA(k)), ByVal VarPtr(FA(i)), 34
    End If:
    DoEvents: Next
    'Debug.Print timeGetTime - T
    If k + 1 < i Then ReDim Preserve FA(k)
    List1.Clear: tFSize = k: If k > 10 Then tFSize = 10
    For i = 1 To tFSize
        List1.AddItem " " & FA(i).Path & FA(i).Name
    Next
    If k > 10 Then List1.AddItem " " & k & " 个文件需要备份,正在努力备份中......"
    '复制文件
    Set FrmM = Me
    For i = 1 To UBound(FA)
        If FA(i).FileSize > 10048576 Or i Mod 100 = 1 Then
            Label3.Caption = UBound(FA) & "\" & i
            Label4.Caption = "  " & FA(i).Path & FA(i).Name
            If FA(i).FileSize > 1048576 Then Label5.Caption = Int(tFSize / (timeGetTime - T)) & " M/s"
        End If: If bCancelBackup Then Exit For
        If FileSetMark(i) Then
            tFSize = tFSize + FA(i).FileSize / 1048.576
            If FileCopyWProgress(FA(i).Path & FA(i).Name, rNewFileFull(FA(i).Path & FA(i).Name, _
                BackUpDisk), Me) = False Then List2.AddItem " 备份失败 " & FA(i).Name
        Else: List2.AddItem " 备份失败 " & FA(i).Name: End If
            'ListW.ListItems(ListW.ListItems.Count).ToolTipText = FA(i).Path & FA(i).Name
        If Err.LastDllError = 112 Then MsgBox "磁盘已满！！！": Exit For
        If GetCTRLSHIFTState(8) Then Me.Visible = True
    DoEvents: Next
    If i = 1 Then
        Label4.Caption = " 没有新文件备份! 用时: " & (timeGetTime - T) \ 1000 & " 秒"
    ElseIf i > UBound(FA) Then
        Label4.Caption = UBound(FA) & " \ " & UBound(FA) & "    备份结束! 用时: " & (timeGetTime - T) \ 1000 & " 秒"
    Else: Label4.Caption = UBound(FA) & " \ " & i & "    备份被中断! 用时: " & (timeGetTime - T) \ 1000 & " 秒": End If
    Label3.Caption = "": Erase FA
End Sub
Private Sub Te_Click(Index As Integer)
    If Index = 2 Then Te(3).Text = Left(Trim(Te(2).Text), 1)
End Sub
Private Sub tmrShow_Timer(): Static Interval As Long
    If tmrShow.Interval < 1000 Then tmrShow.Interval = 1000
    If Me.Visible = True Then Label4.Caption = Now: Exit Sub
    If timeGetTime - Interval > Te(3) * 60000 Then
        tmrShow.Enabled = False
        Interval = timeGetTime
        Call ComD_Click(1)
        tmrShow.Enabled = True
    End If
    If GetCTRLSHIFTState(8) Then _
    Me.Visible = True: Interval = timeGetTime
End Sub