frmunite.frm

用VB6.0编写的关于车辆运输调度的系统

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{B02F3647-766B-11CE-AF28-C3A2FBE76A13}#2.5#0"; "SS32X25.OCX"
Begin VB.Form frmUnite 
   Caption         =   "Unite Database"
   ClientHeight    =   6435
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   8940
   BeginProperty Font 
      Name            =   "宋体"
      Size            =   9
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   6435
   ScaleWidth      =   8940
   WindowState     =   2  'Maximized
   Begin VB.CommandButton cmdexit 
      Caption         =   "Exit"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   495
      Left            =   6840
      TabIndex        =   3
      Top             =   1560
      Width           =   1455
   End
   Begin FPSpread.vaSpread vastabname 
      Height          =   3855
      Left            =   360
      TabIndex        =   2
      Top             =   240
      Width           =   6135
      _Version        =   131077
      _ExtentX        =   10821
      _ExtentY        =   6800
      _StockProps     =   64
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9.75
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      SpreadDesigner  =   "frmUnite.frx":0000
   End
   Begin MSComctlLib.ProgressBar ProBar1 
      Height          =   255
      Left            =   360
      TabIndex        =   1
      Top             =   5160
      Width           =   6255
      _ExtentX        =   11033
      _ExtentY        =   450
      _Version        =   393216
      Appearance      =   1
   End
   Begin VB.CommandButton cmdImport 
      Caption         =   "Import"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   495
      Left            =   6840
      TabIndex        =   0
      Top             =   480
      Width           =   1455
   End
End
Attribute VB_Name = "frmUnite"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Base 1

Private Enum enuName
    tablename = 1
    records
    status
    
    MaxCols = status          '总的列数
End Enum
Private Sub cmdexit_Click()
    Unload Me
End Sub

Private Sub cmdImport_Click()
On Error GoTo err
Dim sSQL As String, sPath As String
Dim adocon1 As New ADODB.Connection
Dim MyName As Variant, fs As Object
Dim lDataBase As Long, sFullPath As String
    
    
    ProBar1.Visible = True
    lDataBase = 0
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    sPath = App.Path & "\..\" & "dbs\"
    MyName = Dir(sPath, vbDirectory)   ' 找寻第一项。
    Do While MyName <> ""   ' 开始循环。
       ' 跳过当前的目录及上层目录。
       If MyName <> "." And MyName <> ".." Then
          ' 使用位比较来确定 MyName 代表一目录。
          If (GetAttr(sPath & MyName) And vbDirectory) = vbDirectory Then
             If fs.fileexists(sPath & MyName & "\lds.mdb") = True Then
                 lDataBase = lDataBase + 1
                 sFullPath = sPath & MyName & "\lds.mdb"
                 Call RefershSpread
                 Call UniteData(lDataBase, sFullPath)
             End If
          End If
       End If
       MyName = Dir   ' 查找下一个目录。
    Loop

    
    ProBar1.Visible = False
    Exit Sub
err:
    MsgBox err.Description, vbOKOnly, "Error"
End Sub


Private Sub UniteData(ByVal lCount As Long, ByVal sFullPath As String)
Dim rstTableName As New Recordset, rstLds1 As New Recordset, rstLds2 As New Recordset
Dim lFieldCount As Long, i As Long, lRowCount As Long
Dim sSQL As String, ColumnSQL As String, ValueSQL As String
Dim sPath As String, sTableName As String
Dim adocon1 As New ADODB.Connection, MyName As Object

    For lRowCount = 1 To vastabname.DataRowCnt
'        sTableName = rstTableName.Fields("tabname")
        sTableName = GetValue(vastabname, lRowCount, enuName.tablename)
        
        Set adocon1 = New ADODB.Connection
        If ConnectDB(adocon1, sFullPath) = False Then
            Exit Sub
        End If
        
        If lCount = 1 Then
            Acs_cnt.Execute ("delete from " & sTableName & "")
        End If
        
        sSQL = "select * from " & sTableName & ""
        Set rstLds1 = adocon1.Execute(sSQL)
        
        lFieldCount = rstLds1.Fields.Count
        
        
        ColumnSQL = ""
        For i = 0 To lFieldCount - 2
            ColumnSQL = ColumnSQL & rstLds1.Fields(i).name & ","
        Next i
        ColumnSQL = "(" & ColumnSQL & rstLds1.Fields(lFieldCount - 1).name & ")"
        
        ProBar1.Value = 0
        If rstLds1.RecordCount > 0 Then
            ProBar1.max = rstLds1.RecordCount
        End If
        With rstLds1
        Do While Not .EOF
            'ReDim a(lFieldCount) As Variant
            ValueSQL = ""
            For i = 0 To lFieldCount - 2
                Select Case rstLds1.Fields(i).Type
                    Case "5", "7", "13", "202"       '文本
                        ValueSQL = ValueSQL & "'" & Trim(rstLds1.Fields(i)) & "'" & ","
                    Case "3", "14"           '数字
                        ValueSQL = ValueSQL & rstLds1.Fields(i) & ","
                    
                    Case Else
                        

                End Select
            Next i
            
            Select Case rstLds1.Fields(lFieldCount - 1).Type
                Case "5", "7", "13", "202"
                    ValueSQL = "(" & ValueSQL & "'" & Trim(rstLds1.Fields(lFieldCount - 1)) & "'" & ")"
                Case "3", "14"
                    ValueSQL = "(" & ValueSQL & rstLds1.Fields(lFieldCount - 1) & ")"
                Case Else
            End Select
            
            sSQL = "insert into " & sTableName & " " & ColumnSQL & " values " & ValueSQL & ""
'            Call ExecuteInsert(sSQL, sTableName)
            Acs_cnt.Execute (sSQL)
            ProBar1.Value = ProBar1.Value + 1
            .MoveNext
        Loop
        End With
        Call SetValue(vastabname, lRowCount, enuName.status, True)
        Call SetValue(vastabname, lRowCount, enuName.records, rstLds1.RecordCount)
    Next lRowCount
'        .MoveNext
'    Loop
'    End With
End Sub

Private Sub RefershSpread()
Dim i As Long

    For i = 1 To vastabname.DataRowCnt
        Call SetValue(vastabname, i, enuName.records, "")
        Call SetValue(vastabname, i, enuName.status, False)
    Next i

End Sub

Private Sub IniSpreadHead()
    
    vastabname.MaxRows = 0
    vastabname.MaxCols = enuName.MaxCols
    
    SetColHead vastabname, enuName.tablename, "Table Name", 16
    SetColHead vastabname, enuName.status, "Status", 10
    SetColHead vastabname, enuName.records, "Records", 12
    
    Call SetBooleanType(vastabname, -1, enuName.status)
End Sub

Private Sub Form_Load()
Dim rstTableName As New Recordset
Dim sSQL As String
Dim i As Long
Dim sTableName As String
    
    ProBar1.Visible = False
    Call IniSpreadHead
    Call lockspread(vastabname, True)
    
    Set rstTableName = Acs_cnt.Execute("select tabname from imptab")
    With rstTableName
    Do While Not .EOF
        vastabname.MaxRows = vastabname.MaxRows + 1
        vastabname.Row = vastabname.MaxRows
        i = vastabname.MaxRows
        SetValue vastabname, i, enuName.tablename, rstTableName.Fields("tabname")
        .MoveNext
    Loop
    End With
    
    rstTableName.Close
    Set rstTableName = Nothing
    
End Sub