当前位置: 开源爱好者 » 编程教程 » VB教程 » 正文

VB6.0 文件较对备份

VB6.0 文件较对备份,包含目录子目录,详细代码如下:

'取消时将终止拷贝进程
Dim bCancelBackup As Long
Dim bSort As Boolean  '排序
Public sPath As String '全局路径
'比较文件日期
Private Function FileCompareFileDates(WFDSource As WIN32_FIND_DATA, _
                                      WFDTarget As WIN32_FIND_DATA) As Long
   Dim CTSource As FILETIME
   Dim CTTarget As FILETIME
   CTSource.dwHighDateTime = WFDSource.ftLastWriteTime.dwHighDateTime
   CTSource.dwLowDateTime = WFDSource.ftLastWriteTime.dwLowDateTime
   CTTarget.dwHighDateTime = WFDTarget.ftLastWriteTime.dwHighDateTime
   CTTarget.dwLowDateTime = WFDTarget.ftLastWriteTime.dwLowDateTime
   FileCompareFileDates = CompareFileTime(CTSource, CTTarget)
End Function
Private Function UnQualifyPath(ByVal sFolder As String) As String
  '移去多余空格
   sFolder = Trim$(sFolder)
   If Right$(sFolder, 1) = "\" Then
         UnQualifyPath = Left$(sFolder, Len(sFolder) - 1)
   Else: UnQualifyPath = sFolder
   End If
End Function
'备份源文件夹
Private Function BackupSourceFolder(ByVal sSourceFolder As String, _
                                    WFDSource As WIN32_FIND_DATA, _
                                    ByVal sTargetFolder As String, _
                                    bUseCallback As Boolean) As Long
   On Error GoTo DIRERR
   Dim sPath As String
   Dim sRootSource As String
   Dim sTmp As String
   Dim sTargetMsg As String
   Dim backupMsg As String
   Dim Diff As Long
   Dim backupSuccess As Boolean
   Dim hFileTarget As Long
   Dim hFileSource  As Long
   Dim itmX As ListItem
  '有效使用在源文件名与源文件夹变量
   Dim dwSourceFileSize As Long
  '有效使用在目标文件与目标文件夹
   Dim WFDTarget As WIN32_FIND_DATA
   Dim hTargetFile As Long
   Dim dwTargetFileSize As Long
   '============
     '确认源文件与目标文件
   sSourceFolder = QualifyPath(sSourceFolder)
   sTargetFolder = QualifyPath(sTargetFolder)
   hFileSource = FileGetFileHandle(sSourceFolder, WFDSource)
  '如果源文件夹不存在,显示错误等信息。
   If hFileSource = INVALID_HANDLE_VALUE Then
      MsgBox "备份源文件夹 " & sSourceFolder & " 没有找到,或没有文件。  ", vbExclamation
      Exit Function
   End If
  '检测如果目录文件夹存在时,给出句柄
   hFileTarget = FileGetFileHandle(sTargetFolder, WFDTarget)
   If hFileTarget = INVALID_HANDLE_VALUE Then
     '如果目标文件夹无效时。建立一个新文件夹
     'MsgBox "备份文件夹 " & sTargetFolder & " 没有找到,建立一个备份文件夹。  ", vbExclamation
      hFileTarget = CreateNestedFolders(sTargetFolder)
   End If
   '=======
   sRootSource = QualifyPath(sSourceFolder)
   sPath = sRootSource & "*.*"
   If hFileSource <> INVALID_HANDLE_VALUE Then
      Do
        '移去多余的空格
          sTmp = TrimNull(WFDSource.cFileName)
          If WFDSource.dwFileAttributes = 16 Then '文件夹
             If TrimNull(WFDSource.cFileName) <> "." And TrimNull(WFDSource.cFileName) <> ".." And chkSub.Value = vbChecked Then '当前文件夹或向上文件夹
               '递归目录  执行备份
               '添加到List
                Set itmX = ListView1.ListItems.Add(, , "")
                    itmX.SmallIcon = 1
                   '文件名称
                    itmX.SubItems(1) = sTmp
                    '描述
                    itmX.SubItems(2) = " 目录已经建立"
                    '大小
                    itmX.SubItems(3) = ""
                    '属性
                    itmX.SubItems(4) = "DIR"
                    itmX.SubItems(5) = "目录已经建立"
                   '清除取消备份标记
                    bCancelBackup = False
                    '------------------------------
                    Call BackupSourceFolder(sSourceFolder & sTmp, _
                                        WFDSource, sTargetFolder & sTmp, bUseCallback)
               End If
         Else   '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
        '如果对象不是文件夹时
         If (WFDSource.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> _
             FILE_ATTRIBUTE_DIRECTORY Then
           '给出目标文件
            hTargetFile = FindFirstFile(sTargetFolder & sTmp, WFDTarget)
           '如果该文件不在目标文件夹时
            If hTargetFile <> INVALID_HANDLE_VALUE Then
              '给出文件大小
               dwSourceFileSize = FileGetFileSize(WFDSource)
               dwTargetFileSize = FileGetFileSize(WFDTarget)
              '校对文件日期
              'If diff = 0 源与目标一致
              'If diff = 1 源比目标新
              'If diff = -1 源比目标旧
               Diff = FileCompareFileDates(WFDSource, WFDTarget)
              '如果日期/时间/属性一致时
               If (dwSourceFileSize = dwTargetFileSize) And _
                  WFDSource.dwFileAttributes = WFDTarget.dwFileAttributes And _
                  Diff = 0 Then
                 '添加到List
                  Set itmX = ListView1.ListItems.Add(, , "")
                      itmX.SmallIcon = 3
                      '文件名称
                      itmX.SubItems(1) = sTmp
                      '描述
                      itmX.SubItems(2) = " 已经存在"
                      '大小
                      itmX.SubItems(3) = dwTargetFileSize \ 1024
                      '属性
                      itmX.SubItems(4) = GetAttribute(WFDTarget.dwFileAttributes)
                      itmX.SubItems(5) = "日期相同,不备份"
               Else:
                 '如果不一致时
                  If Diff = 1 Then  '源比旧的新时
                    '拷贝文件
                    backupSuccess = FileCopyProgress(sSourceFolder & sTmp, _
                                                      sTargetFolder & sTmp, _
                                                      bUseCallback)
                     sTargetMsg = " 源文件是新的"
                     If (bCancelBackup = False) Then
                        If backupSuccess = True Then
                              backupMsg = "文件拷贝完成"
                        Else: backupMsg = "没有拷贝"
                        End If
                     Else: backupMsg = "用户取消"
                     End If
                  ElseIf Diff = -1 Then
                    '源是旧的
                     sTargetMsg = " 源文件是旧的"
                     backupMsg = "不覆盖目标文件"
                  ElseIf Diff = 0 Then
                    '文件相同,属性不同时
                     sTargetMsg = " 两文件属性不同"
                     backupMsg = "不能覆盖目标文件"
                     'backupSuccess = FileCopyProgress(...)
                  End If
                  '添加信息到列表框
                  Set itmX = ListView1.ListItems.Add(, , "")
                      itmX.SmallIcon = 2
                      '文件名称
                      itmX.SubItems(1) = sTmp
                      '描述
                      itmX.SubItems(2) = sTargetMsg
                      '大小
                      itmX.SubItems(3) = dwTargetFileSize \ 1024
                      '属性
                      itmX.SubItems(4) = GetAttribute(WFDTarget.dwFileAttributes)
                      itmX.SubItems(5) = backupMsg
               End If  'If dwSourceFileSize
              '关闭目标文件句柄
              Call FindClose(hTargetFile)
            Else:
              '目标文件没有找到
              '拷贝文件到目标文件夹
               Label2.Caption = "备份 " & sSourceFolder & sTmp
               Label2.Refresh
               backupSuccess = FileCopyProgress(sSourceFolder & sTmp, _
                                                sTargetFolder & sTmp, _
                                                bUseCallback)
               If (bCancelBackup = False) Then
                  If backupSuccess = True Then
                        backupMsg = "文件拷贝完成"
                  Else: backupMsg = "拷贝文件OK!"
                  End If
               Else: backupMsg = "用户取消"
               End If
                  Set itmX = ListView1.ListItems.Add(, , "")
                      itmX.SmallIcon = 1
                      '文件名称
                      itmX.SubItems(1) = sTmp
                      '描述
                      itmX.SubItems(2) = " 已经拷贝"
                      '大小
                      itmX.SubItems(3) = dwTargetFileSize \ 1024
                      '属性
                      itmX.SubItems(4) = GetAttribute(WFDTarget.dwFileAttributes)
                      itmX.SubItems(5) = backupMsg
            End If  'If hTargetFile
         End If  'If WFDSource.dwFileAttributes
        End If  '结束
         dwSourceFileSize = 0
         dwTargetFileSize = 0
         WFDSource.cFileName = ""
         DoEvents
      Loop While FindNextFile(hFileSource, WFDSource)
   End If
     '关闭源文件夹句柄
   Call FindClose(hFileSource)
   Call FindClose(hFileTarget)
   Exit Function
DIRERR:
   MsgBox "目录列表错误:" & Err.Description, vbCritical
   Exit Function
End Function
Private Function FileGetFileSize(WFD As WIN32_FIND_DATA) As Long
   FileGetFileSize = (WFD.nFileSizeHigh * (MAXDWORD + 1)) + WFD.nFileSizeLow
End Function
'查找当前目录下第一个文件,并且给出句柄
Private Function FileGetFileHandle(sPathToFiles As String, WFD As WIN32_FIND_DATA) As Long
   Dim sPath As String
   Dim sRoot As String
   sRoot = QualifyPath(sPathToFiles)
   sPath = sRoot & "*.*"
  '找到第一个文件,并给出句柄
   FileGetFileHandle = FindFirstFile(sPath, WFD)
End Function
'所有目录后都加反斜杠
Private Function QualifyPath(sPath As String) As String
   If Right$(sPath, 1) <> "\" Then
         QualifyPath = sPath & "\"
   Else: QualifyPath = sPath
   End If
End Function
Public Function TrimNull(StartStr As String) As String
  '删除末尾空字符
   Dim Pos As Integer
   Dim sTmp As String
   Pos = InStr(1, StartStr, vbNullChar, vbBinaryCompare)
   'Do
   '  pos=instr(startstr,vbnullchar
   'Loop Until Pos = 0
   'TrimNull = StartStr
   If Pos Then
      TrimNull = Left$(StartStr, Pos - 1)
      Exit Function
   End If
   TrimNull = StartStr
End Function
Private Sub cmdSource_Click()
  Form2.Show 1
  If sPath <> "" Then
     Text1 = sPath
     Text2.SetFocus
    Else
     Text1.SetFocus
  End If
End Sub
Private Sub cmdTarget_Click()
  Form2.Show 1
  If sPath <> "" Then
     Text2 = sPath
     Command1.SetFocus
    Else
     Text2.SetFocus
  End If
End Sub
Private Sub Command1_Click()
   Dim bUseCallback As Boolean
   ListView1.ListItems.Clear
   'bUseCallback = Check1.Value = 1
   Command1.Enabled = False
   'BackupBegin bUseCallback
   Dim WFDSource As WIN32_FIND_DATA
   BackupSourceFolder Text1.Text, WFDSource, Text2.Text, False
   Command1.Enabled = True
End Sub
Private Function CreateNestedFolders(ByVal sCompletePath As String) As Long
  '建立一个新的文件夹
   Dim SA As SECURITY_ATTRIBUTES
   Dim WFD As WIN32_FIND_DATA
   Dim drivePart As String
   Dim newDirectory  As String
   Dim item As String
   Dim Pos As Long
   Dim cnt As Long
   Dim hPath As Long
   sCompletePath = QualifyPath(sCompletePath)
   Pos = InStr(sCompletePath, ":\")
   If Pos Then
         drivePart = StripDelimitedItem(sCompletePath, "\")
   Else: drivePart = StripDelimitedItem(CurDir(), "\")
   End If
   Do
      cnt = cnt + 1
      item = StripDelimitedItem(sCompletePath, "\")
      If cnt = 1 Then
            newDirectory = drivePart & item
      Else: newDirectory = newDirectory & item
      End If
      SA.nLength = LenB(SA)
      Call CreateDirectory(newDirectory, SA)
   Loop Until sCompletePath = ""
   hPath = FileGetFileHandle(sCompletePath, WFD)
   CreateNestedFolders = hPath
   Call FindClose(hPath)
End Function
Private Function StripDelimitedItem(startStrg As String, delimiter As String) As String
   Dim Pos As Long
   Dim item As String
   Pos = InStr(1, startStrg, delimiter)
   If Pos Then
      StripDelimitedItem = Mid$(startStrg, 1, Pos)
      startStrg = Mid$(startStrg, Pos + 1, Len(startStrg))
   End If
End Function
Private Sub Command2_Click()
  '终止备份
  ' bCancelBackup = True
   Unload Me
End Sub
Private Function FileCopyProgress(sSourceFile As String, _
                                  sTargetFile As String, _
                                  bUseCallback As Boolean) As Boolean
   Dim lpCallback As Long
  'ADDressOF不能直接赋值
   If bUseCallback Then
         lpCallback = FARPROC(AddressOf CopyProgressCallback)
   Else: lpCallback = 0&
   End If
  '如果拷贝完成时为1,否则为0
  Dim ret As Long
  FileCopyProgress = CopyFile(sSourceFile, sTargetFile, 0) = 1
  'NT中支持拷贝状态返回
  ' FileCopyProgress = CopyFileEx(sSourceFile, _
                                 sTargetFile, _
                                 lpCallback, _
                                 0&, _
                                 bCancelBackup, _
                                COPY_FILE_RESTARTABLE) = 1
End Function
Private Sub Form_Load()
  '排序
   Dim X As Integer
       For X = 1 To ListView1.ColumnHeaders.Count
           ListView1.ColumnHeaders(X).Icon = Empty
       Next
  '给出设置
  chkSub.Value = Val(GetSetting(App.EXEName, "Option", "SubDIR", 0))
  Text1.Text = GetSetting(App.EXEName, "Option", "Source", "请选择需要备份的目录")
  Text2.Text = GetSetting(App.EXEName, "Option", "Target", "请选择要备份到哪里?")
End Sub
Private Sub Form_Unload(Cancel As Integer)
   SaveSetting App.EXEName, "Option", "SubDIR", chkSub.Value
   SaveSetting App.EXEName, "Option", "Source", Text1.Text
   SaveSetting App.EXEName, "Option", "Target", Text2.Text
End Sub
Private Sub ListView1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
  If ColumnHeader.Index = 1 Then Exit Sub
   '排序
  Dim X As Integer
     For X = 1 To ListView1.ColumnHeaders.Count
         ListView1.ColumnHeaders(X).Icon = Empty
     Next
    ListView1.SortKey = ColumnHeader.Index - 1
  If bSort = True Then
     bSort = False
     ListView1.SortOrder = lvwAscending  '升
     ColumnHeader.Icon = 1
    Else
     bSort = True
     ListView1.SortOrder = lvwDescending  '降
     ColumnHeader.Icon = 2
  End If
     ListView1.Sorted = True
End Sub
Private Sub Text1_DblClick()
 Call cmdSource_Click
End Sub
Private Sub Text1_GotFocus()
  Text1.SelStart = 0
  Text1.SelLength = Len(Text1)
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
 If Text1 <> "" And KeyAscii = 13 Then
    Text2.SetFocus
   ElseIf KeyAscii = 13 Then
    Call cmdSource_Click
 End If
End Sub
Private Sub Text2_DblClick()
  Call cmdTarget_Click
End Sub
Private Sub Text2_GotFocus()
  Text2.SelStart = 0
  Text2.SelLength = Len(Text2)
End Sub
Private Sub Text2_KeyPress(KeyAscii As Integer)
 If Text2.Text <> "" And KeyAscii = 13 Then
    Call Command1_Click
  ElseIf KeyAscii = 13 Then
    Call cmdTarget_Click
 End If
End Sub

CopyRight 2018© 开源爱好者 All Rights Reserved 豫ICP备16030607号 隐私声明 网站地图