frmsavedata.frm

针对于订房中心的酒店合同管理。管理权限有管理员和业务员等。

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmsavedata 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "数据备份"
   ClientHeight    =   2280
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5265
   Icon            =   "frmsavedata.frx":0000
   LinkTopic       =   "form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2280
   ScaleWidth      =   5265
   StartUpPosition =   2  '屏幕中心
   Begin VB.Frame Frame1 
      Height          =   2175
      Left            =   120
      TabIndex        =   0
      Top             =   0
      Width           =   5055
      Begin VB.CommandButton Command3 
         Caption         =   "开始保存数据"
         Height          =   375
         Left            =   480
         TabIndex        =   6
         Top             =   1560
         Width           =   1815
      End
      Begin VB.CommandButton Command2 
         Caption         =   "放弃保存数据"
         Height          =   375
         Left            =   2760
         TabIndex        =   5
         Top             =   1560
         Width           =   1815
      End
      Begin MSComctlLib.ProgressBar ProgressBar1 
         Height          =   255
         Left            =   120
         TabIndex        =   4
         Top             =   960
         Width           =   4695
         _ExtentX        =   8281
         _ExtentY        =   450
         _Version        =   393216
         Appearance      =   1
      End
      Begin VB.CommandButton Command1 
         Caption         =   "..."
         Height          =   375
         Left            =   4200
         TabIndex        =   3
         Top             =   240
         Width           =   495
      End
      Begin VB.TextBox txtpathText 
         Height          =   375
         Left            =   1920
         TabIndex        =   2
         Top             =   240
         Width           =   2175
      End
      Begin VB.Label Label1 
         Caption         =   "请选择备份数据目录："
         Height          =   255
         Left            =   120
         TabIndex        =   1
         Top             =   360
         Width           =   1815
      End
   End
End
Attribute VB_Name = "frmsavedata"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private m_bHaveDone As Boolean


Private Sub Command1_Click()
    frmopendir.Show 1
    txtpathText.Text = frmopendir.strSelDir
End Sub

Private Sub Command2_Click()
    Unload Me
End Sub

Private Sub Command3_Click()
    m_iBeginSaveTimer = 0
    Dim rsTableName As New ADODB.Recordset
    Dim rsColumnName As New ADODB.Recordset
    Dim rsData As New ADODB.Recordset
    Dim cnnJLDB As New ADODB.Connection
    
    Dim sqlname As String
    Dim strName As String
    
    Dim FieldType() As Integer
    Dim FieldLength() As Integer
    Dim FieldName() As String
    Dim FieldNote() As String
    
    cnnJLDB.Open "provider=Microsoft.Jet.OLEDB.4.0; data source=" & App.Path & "\database\yh8888.mdb"
    If (Len(Trim(txtpathText.Text)) = 0) Then
        Result = MsgBox("请指定所要备份数据的路径!", vbOKOnly, "数据备份")
        Exit Sub
    Else
        If (Right(Trim(txtpathText.Text), 1) <> "\") Then
            txtpathText.Text = Trim(txtpathText.Text) + "\"
        Else
            txtpathText.Text = Trim(txtpathText.Text)
        End If
        If (Dir(txtpathText.Text, vbDirectory) = "") Then
            Result = MsgBox("指定路径不存在,请建立后继续!", vbOKOnly, "数据备份")
            Exit Sub
        End If
        
    End If
    
    On Error GoTo ErrorHand
    '''''''''''''''' '''''''''''''''''''''以下为备份数据库
    '连接数据库
    '取得数据库所有表名称
  '  Dim strTableName As String
   ' Dim nreccount As Long
   ' Dim RecordSize As Integer
   ' sqlname = "select * from sysobjects Where type = 'u'"
  '  rsTableName.Open sqlname, cnnJLDB, adOpenStatic, adLockReadOnly
   ' While Not rsTableName.EOF
      '  strTableName = Trim(rsTableName!Name)
        '--------------------------------------------------------------------------
        '根据表名确定各个域名及域类型
        'sqlname = "select xtype,length,name from syscolumns where id in (select id from sysobjects where name = '" + strTableName + "')"
       ' rsColumnName.Open sqlname, cnnJLDB, adOpenStatic, adLockReadOnly
      '  rsColumnName.MoveLast
       ' nreccount = rsColumnName.RecordCount
    ''
        'ReDim FieldType(nreccount)
       ' ReDim FieldLength(nreccount)
       ' ReDim FieldName(nreccount)
       ' ReDim FieldNote(nreccount)
            
      '  rsColumnName.MoveFirst
        
       ' RecordSize = 0
       ' While Not rsColumnName.EOF
            'nIndex = rsColumnName.AbsolutePosition
           ' FieldLength(nIndex) = rsColumnName!Length
            'RecordSize = RecordSize + rsColumnName!Length
           ' FieldType(nIndex) = rsColumnName!xtype
           ' FieldName(nIndex) = rsColumnName!Name
           ' rsColumnName.MoveNext
        'Wend
       ' rsColumnName.Close
       ' Open txtpathText.Text + strTableName + ".dat" For Binary As #1
        
        '从表中读纪录
       ' sqlname = "select * from " + Trim(strTableName)
        'rsData.Open sqlname, cnnJLDB, adOpenStatic, adLockReadOnly
       ' lblShowInfo.Caption = "正在备份数据库中表" + Trim(TableName) + "的数据..."
        'lblShowInfo.Refresh
        'ProcessDataSave.Min = 0
       ' Dim lRowCount As Long
       ' Dim n As Long
       ' lRowCount = 0
       ' If Not rsData.EOF Then
           ' rsData.MoveLast
          '  lRowCount = rsData.RecordCount
            'rsData.MoveFirst
        'End If
        'If lRowCount = 0 Then
           ' ProcessDataSave.Max = 1
           ' ProcessDataSave.Value = 1
           ' lblShowInfo.Caption = strTableName + "表没有纪录!"
        'Else
           ' ProcessDataSave.Max = lRowCount
            'ProcessDataSave.Value = ProcessDataSave.Min
        'End If
        'Put #1, , lRowCount
        'For n = 1 To lRowCount
            'lblShowInfo.Caption = "正在备份数据库中表" + strTableName + "的数据:" + Format(n) + "/" + Format(lRowCount)
           ' lblShowInfo.Refresh
           ' For nStep = 0 To nreccount - 1
                'fieldData = rsData(nStep)
                'Put #1, , fieldData
           ' Next nStep
            'ProcessDataSave.Value = n
           'm_iBeginSaveTimer = 0
            'rsData.MoveNext
       'Next n
        'rsData.Close
       ' Close #1
    'rsTableName.MoveNext
    'Wend
    'rsTableName.Close
    'm_bHaveDone = True
    'MousePointer = 1
    'Result = MsgBox("本系统数据库中的数据备份完毕，请保存数据备份目录下的数据备份文件!", vbOKOnly, "数据备份")
    
   'SaveSetting App.Title, "Settings", "StoreDirection", Trim(txtpathText.Text)

   ' Unload Me
    
    'Exit Sub
ErrorHand:
    MousePointer = 1
    MsgBox "数据备份失败，请重试，必要时联系开发人员！", 64, "信息提示"

End Sub

Private Sub Form_Load()
    m_iBeginSaveTimer = 0
    On Error Resume Next
    m_bHaveDone = False
    txtpathText.Text = GetSetting(App.Title, "Settings", "StoreDirection", "d:\temp")
End Sub

Private Sub Form_Unload(Cancel As Integer)
    m_iBeginSaveTimer = 0
    Dim iRespond As Integer
    If m_bHaveDone = False Then  '如果还没有备份完数据
        iRespond = MsgBox("是否确认取消数据备份?", 64 + 4, "信息提示")
        If iRespond = 7 Then
            Cancel = -1
        End If
    End If
End Sub