frmzt97import.frm

用vb编了一个数据库程序

VERSION 5.00
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Begin VB.Form frmZT97Import 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "从ZT97导入企业信息"
   ClientHeight    =   4725
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   7230
   ControlBox      =   0   'False
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4725
   ScaleWidth      =   7230
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin MSComCtl2.Animation Animation 
      Height          =   1605
      Left            =   1493
      TabIndex        =   5
      Top             =   1350
      Width           =   4245
      _ExtentX        =   7488
      _ExtentY        =   2831
      _Version        =   393216
      Center          =   -1  'True
      FullWidth       =   283
      FullHeight      =   107
   End
   Begin VB.CommandButton CmdImport 
      Caption         =   "开始(&E)"
      Default         =   -1  'True
      Height          =   375
      Left            =   4005
      TabIndex        =   2
      Top             =   4080
      Width           =   1500
   End
   Begin VB.CommandButton CmdFinish 
      Caption         =   " 取消(&E)"
      Height          =   375
      Left            =   5505
      TabIndex        =   1
      Top             =   4080
      Width           =   1500
   End
   Begin VB.Frame Frame1 
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   125
      Left            =   120
      TabIndex        =   0
      Top             =   3660
      Width           =   7005
   End
   Begin VB.Frame Frame 
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   3285
      Left            =   210
      TabIndex        =   3
      Top             =   150
      Width           =   6705
      Begin VB.Label lblCaption 
         AutoSize        =   -1  'True
         Caption         =   "正在导入"
         Height          =   180
         Left            =   360
         TabIndex        =   4
         Top             =   450
         Width           =   720
      End
   End
End
Attribute VB_Name = "frmZT97Import"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub CmdFinish_Click()
    Unload Me
    
End Sub

Private Sub CmdImport_Click()
'***************************************************************
'功能: 连接Sybase数据库,在本地数据库中建立同名表并写入数据
'
'***************************************************************
On Error GoTo ErrorHandler

Dim i As Integer

Dim SQL(4) As String
Dim TypeText(4) As String
Dim RecordCount(4) As Integer

Dim strMsg As String

Dim rstZT97 As ADODB.Recordset
Dim rstCaseMain As ADODB.Recordset

SQL(0) = csDJ_QYSQL
SQL(1) = csDJ_GTSQL
SQL(2) = csDJ_WZSQL
SQL(3) = csDJ_WGSQL
SQL(4) = csDJ_ZCSQL

TypeText(0) = csDJ_QY
TypeText(1) = csDJ_GT
TypeText(2) = csDJ_WZ
TypeText(3) = csDJ_WG
TypeText(4) = csDJ_ZC

Set rstZT97 = New ADODB.Recordset
Set rstCaseMain = New ADODB.Recordset

Me.MousePointer = vbHourglass
cmdImport.Enabled = False
CmdFinish.Enabled = False

'连接ZT97数据库
frmSplash.lblAction.Caption = "正在连接ZT97数据库..."
frmSplash.lblAction.Refresh
Set conZT97 = New ADODB.Connection
'conZT97.Provider = csProvider
'conZT97.CursorLocation = adUseServer
'conZT97.ConnectionTimeout = 60
conZT97.ConnectionString = "DSN=zt97"
conZT97.Open 'csConZT97

'开始播放动画
If Dir(App.Path & "\filecopy.avi") <> vbNullString Then
    Animation.Open App.Path & "\filecopy.avi"
    Animation.Visible = True
    Animation.Play
End If

For i = 0 To 4
    
    conCaseMain.Execute "DELETE * FROM " & Right(SQL(i), 5)
    
    rstCaseMain.Open SQL(i), conCaseMain, 1, 1 ', adCmdText
    rstZT97.Open SQL(i), conZT97, 1, 1 ', adCmdText
    RecordCount(i) = rstZT97.RecordCount
    lblCaption.Caption = "正在导入: " & TypeText(i) & " ( " & UCase(Right(SQL(i), 5)) & " )"
    lblCaption.Refresh
    
    With rstZT97
        If Not .EOF Then .MoveLast
        If Not .BOF Then .MoveFirst
        Do Until .EOF
            rstCaseMain.AddNew
            rstCaseMain!QYBM = !QYBM
            rstCaseMain!Nsrmc = !Nsrmc
            rstCaseMain.Update
            .MoveNext
        Loop
    End With
    rstZT97.Close
    rstCaseMain.Close
    
Next i

'停止播放动画
If Dir(App.Path & "\filecopy.avi") <> vbNullString Then
    Animation.Stop
    Animation.Visible = False
End If

Screen.MousePointer = vbDefault
For i = 0 To 4
    strMsg = strMsg & "从 " & Right(SQL(i), 5) & " 中导入纪录共 " & RecordCount(i) & " 条" & vbCrLf
Next i
MsgBox "导入结束!" & vbCrLf & strMsg, vbInformation

lblCaption.Caption = " 导入结束,正在更新系统信息!"
CmdFinish.Caption = " 结束(&F)"
Screen.MousePointer = vbHourglass

'开始播放动画
If Dir(App.Path & "\globe.avi") <> vbNullString Then
    Animation.Open App.Path & "\globe.avi"
    Animation.Visible = True
    Animation.Play
End If

'刷新fCenter
Unload fCenter
Load fCenter

Screen.MousePointer = vbDefault
cmdImport.Enabled = True
CmdFinish.Enabled = True

'停止播放动画
If Dir(App.Path & "\globe.avi") <> vbNullString Then
    Animation.Stop
    Animation.Visible = False
End If

Unload Me
fCenter.Show

Exit Sub
ErrorHandler:
    If Err Then
        If Err.Number = -2147467259 Then
            MsgBox "用户取消连接数据库,无法导入!", vbInformation
        Else
            MsgBox Err.Description & CStr(Err.Number), vbInformation
        End If
        Err.Clear
        Unload Me
    End If
End Sub

Private Sub Form_Load()
    lblCaption.Caption = "导入数据将连接Sybase数据库,从中复制必要的数据" & vbCrLf & "如果现在要导入数据,请按[开始]!"
    
    If Dir(App.Path & "\filecopy.avi") <> vbNullString And Dir(App.Path & "\Globe.avi") <> vbNullString Then
        Animation.AutoPlay = False
        Animation.Visible = False
    End If

End Sub

Private Sub Form_Unload(Cancel As Integer)
   If Dir(App.Path & "\filecopy.avi") <> vbNullString Then
        Animation.Close
   End If

End Sub