frmdataimport.frm

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

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form frmdataimport 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "学生基本数据导入"
   ClientHeight    =   4290
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4545
   Icon            =   "frmdataimport.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4290
   ScaleWidth      =   4545
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  '所有者中心
   Begin VB.Frame Frame1 
      Height          =   3885
      Left            =   210
      TabIndex        =   0
      Top             =   150
      Width           =   4065
      Begin VB.TextBox Text1 
         BackColor       =   &H80000018&
         Height          =   330
         Left            =   270
         TabIndex        =   5
         Top             =   570
         Width           =   3105
      End
      Begin VB.CommandButton Command1 
         Caption         =   "..."
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   9
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   345
         Left            =   3360
         TabIndex        =   4
         Top             =   570
         Width           =   495
      End
      Begin VB.ListBox List1 
         BackColor       =   &H80000018&
         Height          =   1140
         Left            =   270
         TabIndex        =   3
         Top             =   1515
         Width           =   3135
      End
      Begin VB.CommandButton Command2 
         Caption         =   "确定(&O)"
         Default         =   -1  'True
         Height          =   420
         Left            =   1590
         TabIndex        =   2
         Top             =   3240
         Width           =   915
      End
      Begin VB.CommandButton Command3 
         Cancel          =   -1  'True
         Caption         =   "取消(&C)"
         Height          =   420
         Left            =   2670
         TabIndex        =   1
         Top             =   3240
         Width           =   915
      End
      Begin MSComDlg.CommonDialog CommonDialog1 
         Left            =   1935
         Top             =   990
         _ExtentX        =   847
         _ExtentY        =   847
         _Version        =   393216
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "1.请选择数据库"
         BeginProperty Font 
            Name            =   "楷体_GB2312"
            Size            =   10.5
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   210
         Index           =   0
         Left            =   270
         TabIndex        =   7
         Top             =   210
         Width           =   1605
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "2.请选择表"
         BeginProperty Font 
            Name            =   "楷体_GB2312"
            Size            =   10.5
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   210
         Index           =   1
         Left            =   270
         TabIndex        =   6
         Top             =   1200
         Width           =   1155
      End
   End
End
Attribute VB_Name = "frmdataimport"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Dim rs As New ADODB.Recordset
Dim comm As New ADODB.Command
Dim table_name As String
Dim rsfield As ADODB.Field

Private Sub Command1_Click()
   CommonDialog1.CancelError = False
   CommonDialog1.Filter = "ACCESS(*.mdb)|*.mdb"
   CommonDialog1.DialogTitle = "open database"
   CommonDialog1.ShowOpen
If CommonDialog1.filename = "" Then
   Exit Sub
Else                    '获取数据库中所有表的名称
    opendatabase CommonDialog1.filename
    Text1.Text = CommonDialog1.filename
'    List1.Clear
     Set rs = cntemp.OpenSchema(adSchemaTables)
     Do Until rs.EOF
        If rs!table_type = "TABLE" Then
           List1.AddItem rs!table_name
        End If
        rs.MoveNext
     Loop
End If
End Sub

Private Sub Command2_Click()
'*************************这里是数据导入的程序**************************
On Error GoTo err
t = MsgBox("是否将该表导入人员基本信息表！", vbOKCancel + vbExclamation, "注意")

If t = 1 Then
    Set rs = New ADODB.Recordset
    table_name = List1.Text
    strsql = "select * from " & table_name
        rs.open strsql, cntemp, adOpenStatic, adLockPessimistic
Call condatabase
    Set rsrmk = New ADODB.Recordset
        rsrmk.open "select * from rmk", cn, adOpenStatic, adLockPessimistic
'**********把要导入的数据付值给RMK表**********
Dim msg As String
     If rs.recordcount <> 0 Then
        For i = 0 To rs.recordcount - 1
            rsrmk.AddNew
            For j = 0 To 5
                rsrmk.Fields(j).Value = rs.Fields(j).Value
            Next j
            rsrmk.Update
            rs.MoveNext
        Next i
            msg = "成功完成数据导入！共有" & rs.recordcount & "记录被导入人员基本信息表！"
            MsgBox msg, vbOKOnly, "完成"
     Else
        MsgBox "要导入的数据表中无记录！", vbOKOnly + vbExclamation, "注意"
     End If
'********************************************
Else
    Exit Sub
End If
Exit Sub
err:
   MsgBox err.Description, vbOKOnly + vbExclamation, "出错了"
'********************************************************************
End Sub

Private Sub Command3_Click()
Unload Me
End Sub

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

Private Sub Form_Unload(Cancel As Integer)
mainform.StatusBar1.Panels(1).Text = "状态： 无"

End Sub