frmdataoutput.frm

用vb+access库房管理开放源码 1、日常业务 药品入库 药品出库 入库退单管理 出库退单管理 2、库存管理 库存查询 库存盘点 价格管理 3、查询统计 入库查询 入库退

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmDataOutput 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "每月数据导出"
   ClientHeight    =   3735
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4845
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MDIChild        =   -1  'True
   MinButton       =   0   'False
   ScaleHeight     =   3735
   ScaleWidth      =   4845
   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 = "frmDataOutput"
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 "goodClass" '加入要导出数据的数据表名
List1.AddItem "goodInfo"
List1.AddItem "getInInfo"
List1.AddItem "getOutInfo"
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_source 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_source = 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_source.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_source.BOF <> True And rs_source.EOF <> True Then
            Do Until rs_source.EOF '复制数据
               rs_back.AddNew
               For i = 0 To rs_source.Fields.Count - 1
                   rs_back.Fields(i).Value = rs_source.Fields(i).Value
               Next
               rs_source.MoveNext
               rs_back.Update
            Loop
            MsgBox "已经将数据表到处到指定的表中！", vbOKOnly, "成功"
        Else
            MsgBox "你所要备份的数据表中没有数据！", vbOKOnly + vbCritical, "注意"
        End If
Else
   MsgBox "没有可供备份的数据表！", vbOKOnly, "注意"
End If
'Download by http://www.codefans.net
End Sub