frmimport_sec.frm

医务收费系统,主要的功能不用我说大家都知道的

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmimport 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "每月数据导出"
   ClientHeight    =   3735
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4845
   Icon            =   "frmimport_sec.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3735
   ScaleWidth      =   4845
   StartUpPosition =   2  '屏幕中心
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   3510
      Top             =   660
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton Command3 
      Caption         =   "选择路径"
      Height          =   435
      Left            =   2910
      TabIndex        =   4
      Top             =   1560
      Width           =   1125
   End
   Begin VB.CommandButton Command2 
      Cancel          =   -1  'True
      Caption         =   "退出(&E)"
      Height          =   435
      Left            =   2880
      TabIndex        =   2
      Top             =   2820
      Width           =   1155
   End
   Begin VB.CommandButton Command1 
      Caption         =   "确定(&O)"
      Default         =   -1  'True
      Height          =   435
      Left            =   2880
      TabIndex        =   1
      Top             =   2280
      Width           =   1155
   End
   Begin VB.ListBox List1 
      BackColor       =   &H00C0FFFF&
      Height          =   2760
      Left            =   540
      TabIndex        =   0
      Top             =   570
      Width           =   1995
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "请选择数据表"
      ForeColor       =   &H000000FF&
      Height          =   180
      Left            =   210
      TabIndex        =   3
      Top             =   270
      Width           =   1080
   End
End
Attribute VB_Name = "frmimport"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim cn_access As New ADODB.Connection

Dim cn_sec As New ADODB.Connection
Dim rs_sec As New ADODB.Recordset
Dim rs As New ADODB.Recordset
Dim comm As New ADODB.Command
Dim table_name As String
Private td As TableDef
Private f As Field
Dim exist As Boolean
Dim db As Database
Dim rsfield_sec As ADODB.Field
Dim rsfield As ADODB.Field


Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Command3_Click()
CommonDialog1.CancelError = False
CommonDialog1.Filter = "ACCESS(*.mdb)|*.mdb|所有文件(*.*)|*.*"
CommonDialog1.DialogTitle = "选择数据库"
CommonDialog1.ShowOpen
If CommonDialog1.filename = "" Then
   Exit Sub
Else
    database_data = CommonDialog1.filename
    opendatabase CommonDialog1.filename
     Set rs = cn_access.OpenSchema(adSchemaTables)
     Do Until rs.EOF
        If rs!table_name = List1.Text Then
           exist = True
        End If
        rs.MoveNext
     Loop
     If exist = False Then MsgBox "没有可供备份的数据表！", vbOKOnly, "注意"
End If
End Sub

Private Sub Form_Load()
List1.AddItem "YF01"
List1.AddItem "YF02"
List1.AddItem "YF03"
List1.AddItem "YF04"
List1.AddItem "YF05"
List1.AddItem "YF06"
List1.AddItem "YF07"
List1.AddItem "YF08"
List1.AddItem "YF09"
List1.AddItem "YF10"
List1.AddItem "YF11"
List1.AddItem "YF12"


End Sub
Private Function opendatabase(filename As String)
 Set cn_access = Nothing
 Set rs = Nothing
 Set comm = Nothing
 Set rsfield = Nothing
    cn_access.Provider = "Microsoft.Jet.OLEDB.4.0"
 On Error GoTo err
    cn_access.open filename
    Exit Function
err:
    Dim err As ADODB.Error
    Dim errstr As String
    If cn_access = "" Then
       MsgBox "没有连接数据库文件！"
    Else
        For Each err In conn.Errors
            errstr = errstr & "错误描述：" & err.Description & vbCr
        Next
            MsgBox errstr, vbOKOnly, "注意"
    End If
End Function

Private Sub Command1_Click()
If exist = True Then
   '此处进行数据的备份
  
   Call check_condatabase
   Dim rs_back As ADODB.Recordset
   Dim cn_back As ADODB.Connection
   Dim rs_month As ADODB.Recordset
   
   Set rs_back = New ADODB.Recordset
   Set cn_back = New ADODB.Connection
       cn_back.Provider = "microsoft.jet.oledb.4.0"
       cn_back.ConnectionString = database_data
       cn_back.open
   Set rs_month = New ADODB.Recordset
       rs_back.open "select * from " & List1.Text & "", cn_back, adOpenStatic, adLockPessimistic
       If rs_back.recordcount <> 0 Then
          If rs_back.State = 1 Then rs_back.close
          rs_back.open "delete * from " & List1.Text & "", cn_back, adOpenStatic, adLockPessimistic
       End If
       rs_month.open "select * from " & List1.Text & "", cn, adOpenStatic, adLockPessimistic
       If rs_back.State = 0 Then
          rs_back.open "select * from " & List1.Text & "", cn_back, adOpenStatic, adLockPessimistic
       End If
       If rs_month.BOF <> True And rs_month.EOF <> True Then
            Do Until rs_month.EOF
               rs_back.AddNew
               For i = 0 To 7
                   rs_back.Fields(i).Value = rs_month.Fields(i).Value
               Next
               rs_month.MoveNext
               rs_back.Update
            Loop
            MsgBox "已经将数据表到处到指定的表中！", vbOKOnly, "成功"
        Else
            MsgBox "你所要备份的数据表中没有数据！", vbOKOnly + vbCritical, "注意"
        End If
Else
   MsgBox "没有可供备份的数据表！", vbOKOnly, "注意"
End If

End Sub