databackup.ctl

星级酒店管理系统（附带系统自写控件源码）

  Dim BI As BROWSEINFO
  Dim nFolder As Long
  Dim IDL As ITEMIDLIST
  Dim pIdl As Long
  Dim sPath As String
  Dim SHFI As SHFILEINFO
  
  With BI
    .hOwner = UserControl.hwnd
    nFolder = GetFolderValue(m_wCurOptIdx)
    If SHGetSpecialFolderLocation(ByVal UserControl.hwnd, ByVal nFolder, IDL) = NOERROR Then
      .pidlRoot = IDL.mkid.cb
    End If
    
    .pszDisplayName = String$(MAX_PATH, 0)
    .lpszTitle = "请选择备份的路径 => 程序:俞思龙"
    .ulFlags = GetReturnType()
    
  End With
  
  ' 显示浏览对话框
  pIdl = SHBrowseForFolder(BI)

  If pIdl = 0 Then Exit Sub
  sPath = String$(MAX_PATH, 0)
  SHGetPathFromIDList ByVal pIdl, ByVal sPath
  
  txtBackupFileTo.Text = Left(sPath, InStr(sPath, vbNullChar) - 1)
  txtBackupFileTo.SetFocus

End Sub

Private Sub cmdSelect3_Click()

 On Error Resume Next
 
 dlgBrowser.DialogTitle = "请选择需要恢复的文件"
 dlgBrowser.CancelError = True
 dlgBrowser.Filter = "所有文件(*.*)|*.*|Access文件(*.MDB)|*.MDB|VB中国恢复文件(*.YVB)|*.YVB"
 dlgBrowser.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly + cdlOFNPathMustExist
 dlgBrowser.ShowOpen
 txtRestoreFileFrom = dlgBrowser.FileName
 txtRestoreFileFrom.SetFocus
 
 If Err.Number = 32755 Then '取消时
    Exit Sub
 End If
 
End Sub

Private Sub cmdSelect4_Click()

  Dim BI As BROWSEINFO
  Dim nFolder As Long
  Dim IDL As ITEMIDLIST
  Dim pIdl As Long
  Dim sPath As String
  Dim SHFI As SHFILEINFO
  
  With BI
    .hOwner = UserControl.hwnd
    nFolder = GetFolderValue(m_wCurOptIdx)
    If SHGetSpecialFolderLocation(ByVal UserControl.hwnd, ByVal nFolder, IDL) = NOERROR Then
      .pidlRoot = IDL.mkid.cb
    End If
    
    .pszDisplayName = String$(MAX_PATH, 0)
    .lpszTitle = "请选择恢复的路径 => 程序:俞思龙"
    .ulFlags = GetReturnType()
    
  End With
  
  ' 显示浏览对话框
  pIdl = SHBrowseForFolder(BI)

  If pIdl = 0 Then Exit Sub
  sPath = String$(MAX_PATH, 0)
  SHGetPathFromIDList ByVal pIdl, ByVal sPath
  
  txtRestoreFileTo.Text = Left(sPath, InStr(sPath, vbNullChar) - 1)
  txtRestoreFileTo.SetFocus

End Sub

Private Sub txtBackupFileFrom_Click()

  BackUpFileFrom = txtBackupFileFrom
  
End Sub

Private Sub txtBackupFileFrom_GotFocus()

  txtBackupFileFrom.SelStart = 0
  txtBackupFileFrom.SelLength = Len(txtBackupFileFrom)
  
End Sub

Private Sub txtBackupFileTo_Change()

 BackUpFileTo = txtBackupFileTo
 
End Sub

Private Sub txtBackupFileTo_GotFocus()
  
  txtBackupFileTo.SelStart = 0
  txtBackupFileTo.SelLength = Len(txtBackupFileTo)

End Sub

Private Sub txtRestoreFileFrom_Change()

  RestoreFileFrom = txtRestoreFileFrom
  
End Sub

Private Sub txtRestoreFileFrom_GotFocus()

  txtRestoreFileFrom.SelStart = 0
  txtRestoreFileFrom.SelLength = Len(txtRestoreFileFrom)

End Sub

Private Sub txtRestoreFileTo_Change()
  
   RestoreFileTo = txtRestoreFileTo
   
End Sub

Private Sub txtRestoreFileTo_GotFocus()
  
  txtRestoreFileFrom.SelStart = 0
  txtRestoreFileFrom.SelLength = Len(txtRestoreFileFrom)

End Sub

'注意！不要删除或修改下列被注释的行！
'MappingInfo=txtBackupFileFrom,txtBackupFileFrom,-1,Text
Public Property Get BackUpFileFrom() As String
Attribute BackUpFileFrom.VB_Description = "返回/设置控件中包含的文本。"
    BackUpFileFrom = txtBackupFileFrom.Text
End Property

Public Property Let BackUpFileFrom(ByVal New_BackUpFileFrom As String)
    txtBackupFileFrom.Text() = New_BackUpFileFrom
    PropertyChanged "BackUpFileFrom"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=txtBackupFileTo,txtBackupFileTo,-1,Text
Public Property Get BackUpFileTo() As String
Attribute BackUpFileTo.VB_Description = "返回/设置控件中包含的文本。"
    BackUpFileTo = txtBackupFileTo.Text
End Property

Public Property Let BackUpFileTo(ByVal New_BackUpFileTo As String)
    txtBackupFileTo.Text() = New_BackUpFileTo
    PropertyChanged "BackUpFileTo"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=txtRestoreFileFrom,txtRestoreFileFrom,-1,Text
Public Property Get RestoreFileFrom() As String
Attribute RestoreFileFrom.VB_Description = "返回/设置控件中包含的文本。"
    RestoreFileFrom = txtRestoreFileFrom.Text
End Property

Public Property Let RestoreFileFrom(ByVal New_RestoreFileFrom As String)
    txtRestoreFileFrom.Text() = New_RestoreFileFrom
    PropertyChanged "RestoreFileFrom"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=txtRestoreFileTo,txtRestoreFileTo,-1,Text
Public Property Get RestoreFileTo() As String
Attribute RestoreFileTo.VB_Description = "返回/设置控件中包含的文本。"
    RestoreFileTo = txtRestoreFileTo.Text
End Property

Public Property Let RestoreFileTo(ByVal New_RestoreFileTo As String)
    txtRestoreFileTo.Text() = New_RestoreFileTo
    PropertyChanged "RestoreFileTo"
End Property

'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    txtBackupFileFrom.Text = PropBag.ReadProperty("BackUpFileFrom", "")
    txtBackupFileTo.Text = PropBag.ReadProperty("BackUpFileTo", "")
    txtRestoreFileFrom.Text = PropBag.ReadProperty("RestoreFileFrom", "")
    txtRestoreFileTo.Text = PropBag.ReadProperty("RestoreFileTo", "")
End Sub

Private Sub UserControl_Resize()
 
 Size Frame1.Width, Frame1.Height

End Sub

'将属性值写到存储器
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("BackUpFileFrom", txtBackupFileFrom.Text, "")
    Call PropBag.WriteProperty("BackUpFileTo", txtBackupFileTo.Text, "")
    Call PropBag.WriteProperty("RestoreFileFrom", txtRestoreFileFrom.Text, "")
    Call PropBag.WriteProperty("RestoreFileTo", txtRestoreFileTo.Text, "")
    
End Sub

Private Function GetFolderValue(wIdx As Integer) As Long
    
    If wIdx < 2 Then
       GetFolderValue = 0
    ElseIf wIdx < 12 Then
      GetFolderValue = wIdx
    Else
      GetFolderValue = wIdx + 4
    End If
End Function

Private Function GetReturnType() As Long
  Dim dwRtn As Long
  dwRtn = dwRtn
  GetReturnType = dwRtn
End Function

Private Sub StartIt(sType)
   
   On Error GoTo POP_ERR
   Dim SHop As SHFILEOPSTRUCT
   If sType = "Backup" Then '备份时
      With SHop
        .fFlags = FOF_SIMPLEPROGRESS
        .pFrom = BackUpFileFrom
        .pTo = BackUpFileTo
        .wFunc = FO_COPY  '复制
      End With
   Else '恢复
      With SHop
        .fFlags = FOF_SIMPLEPROGRESS
        .pFrom = RestoreFileFrom
        .pTo = RestoreFileTo
        .wFunc = FO_COPY  '复制
      End With
   End If
    SHFileOperation SHop
    MsgBox "备份或恢复处理完毕！  ", vbInformation
   Exit Sub
  
POP_ERR:
   MsgBox "没有正常处理备份与恢复！   " & Err.Description, vbExclamation
   Exit Sub
End Sub

'代码:
Private Sub StartIt_Ex(sType As String)
    
    Dim Ret As Long
   
    Screen.MousePointer = 11
    
    picStatus.Visible = True
    bCancel = 0
    
   '开始拷贝
    If sType = "Backup" Then '备份时
       Ret = CopyFileEx(BackUpFileFrom, BackUpFileTo, AddressOf CopyProgressRoutine, ByVal 0&, bCancel, COPY_FILE_RESTARTABLE)
    
    Else '恢复
       Ret = CopyFileEx(RestoreFileFrom, RestoreFileTo, AddressOf CopyProgressRoutine, ByVal 0&, bCancel, COPY_FILE_RESTARTABLE)
    
    End If
    
    picStatus.Visible = False
    Screen.MousePointer = 0
    
    If Ret = 0 Then
       MsgBox " 文 件 处 理 完 毕 ！  ", vbInformation, "Design By Yusilong."
     Else
       MsgBox " 文 件 处 理 错 误 ？  ", vbInformation, "Design By Yusilong."
    End If
    
End Sub

Public Sub StopIt()

   '取消拷贝
    bCancel = 1
    
End Sub