form1.frm

库房和客服配货单比较,合并数据表,并带有进度条

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1 
   Caption         =   "库房和客服配货单比较"
   ClientHeight    =   5370
   ClientLeft      =   60
   ClientTop       =   645
   ClientWidth     =   10650
   Icon            =   "Form1.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   14550
   ScaleWidth      =   19080
   StartUpPosition =   2  '屏幕中心
   Begin VB.ListBox ListB 
      Height          =   600
      ItemData        =   "Form1.frx":0ECA
      Left            =   5760
      List            =   "Form1.frx":0ED1
      MultiSelect     =   2  'Extended
      TabIndex        =   13
      Top             =   2160
      Width           =   3255
   End
   Begin VB.CommandButton cmd_mergeB 
      Caption         =   "合并B中数据表"
      Height          =   375
      Left            =   120
      TabIndex        =   9
      Top             =   3720
      Width           =   1575
   End
   Begin VB.CommandButton cmd_mergeA 
      Caption         =   "合并A中数据表"
      Height          =   375
      Left            =   120
      TabIndex        =   8
      Top             =   3000
      Width           =   1575
   End
   Begin VB.CommandButton cmd_compare 
      Caption         =   "比较两库异同"
      Height          =   375
      Left            =   4200
      TabIndex        =   7
      Top             =   3120
      Width           =   1575
   End
   Begin VB.TextBox txt_sourceB 
      Height          =   375
      Left            =   120
      MultiLine       =   -1  'True
      TabIndex        =   6
      Top             =   960
      Width           =   7335
   End
   Begin VB.CommandButton cmd_selectB 
      Caption         =   "选择数据库B"
      Height          =   375
      Left            =   7560
      TabIndex        =   5
      Top             =   960
      Width           =   1455
   End
   Begin VB.ListBox ListA 
      Height          =   600
      ItemData        =   "Form1.frx":0EDC
      Left            =   120
      List            =   "Form1.frx":0EE3
      MultiSelect     =   2  'Extended
      TabIndex        =   2
      Top             =   2160
      Width           =   3255
   End
   Begin VB.CommandButton cmd_selectA 
      Caption         =   "选择数据库A"
      Height          =   375
      Left            =   7560
      TabIndex        =   1
      Top             =   360
      Width           =   1455
   End
   Begin VB.TextBox txt_sourceA 
      Height          =   375
      Left            =   120
      MultiLine       =   -1  'True
      TabIndex        =   0
      Top             =   360
      Width           =   7335
   End
   Begin MSComDlg.CommonDialog CommonDialogAB 
      Left            =   10080
      Top             =   720
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      Filter          =   "(Access文件)*.mdb|*.mdb"
   End
   Begin MSComctlLib.ProgressBar ProgressBar1 
      Height          =   255
      Left            =   480
      TabIndex        =   10
      Top             =   4440
      Visible         =   0   'False
      Width           =   9855
      _ExtentX        =   17383
      _ExtentY        =   450
      _Version        =   393216
      Appearance      =   1
   End
   Begin VB.Label Label3 
      Caption         =   "检索到的B数据表："
      Height          =   195
      Left            =   4560
      TabIndex        =   15
      Top             =   1800
      Width           =   1575
   End
   Begin VB.Label lbl_infoB 
      ForeColor       =   &H000000FF&
      Height          =   255
      Left            =   6360
      TabIndex        =   14
      Top             =   1800
      Width           =   2295
   End
   Begin VB.Label lblDisplay2 
      Height          =   615
      Left            =   1800
      TabIndex        =   12
      Top             =   3600
      Width           =   8535
   End
   Begin VB.Label lblDisplay1 
      Height          =   495
      Left            =   480
      TabIndex        =   11
      Top             =   4800
      Width           =   9855
   End
   Begin VB.Label lbl_infoA 
      ForeColor       =   &H000000FF&
      Height          =   255
      Left            =   1920
      TabIndex        =   4
      Top             =   1800
      Width           =   2295
   End
   Begin VB.Label Label2 
      Caption         =   "检索到的A数据表："
      Height          =   195
      Left            =   120
      TabIndex        =   3
      Top             =   1800
      Width           =   1575
   End
   Begin VB.Menu helpme 
      Caption         =   "帮助"
      Index           =   0
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim bRun As Boolean
Private Sub cmd_compare_Click()
    If txt_sourceA.Text = "" Or txt_sourceB.Text = "" Then
        MsgBox "请选择上边的数据库"
        Exit Sub
    End If
    tablename = "所有渠道总表（库房和客服人员比较专用）"
    
    ProgressBar1.Value = 0
    ProgressBar1.Visible = True
    
    lblDisplay1.Caption = "正在把比较结果写入" & txt_sourceA.Text & "中的" & tablename
    Call Compare(txt_sourceA, txt_sourceB)
    ProgressBar1.Value = 0
    lblDisplay1.Caption = "正在把比较结果写入" & txt_sourceB.Text & "中的" & tablename
    Call Compare(txt_sourceB, txt_sourceA)
    MsgBox "比较完成" & "，比较结果已写入选择的这两个数据库的" & tablename & "表中", vbInformation
End Sub

Private Sub Compare(txt_source1 As TextBox, txt_source2 As TextBox) '比较
    '连接数据库
    Dim connA As New ADODB.Connection
    Dim connB As New ADODB.Connection
    
    db1 = txt_source1.Text
    db2 = txt_source2.Text

    ConnStrA = "PROVIDER=microsoft.jet.oledb.4.0;persist security info =false;data source=" & db1
    ConnStrB = "PROVIDER=microsoft.jet.oledb.4.0;persist security info =false;data source=" & db2
    
    connA.Open ConnStrA
    connB.Open ConnStrB
        
    tablename = "所有渠道总表（库房和客服人员比较专用）"
    
    
    Dim rsA As New ADODB.Recordset
    Dim rsB As New ADODB.Recordset
    
    sqlA = "select  orderid,自编号,数量,差额,附加说明,name from " & tablename
    On Error Resume Next
    rsA.Open sqlA, connA, 1, 3
    If Err.Number <> 0 Then
        MsgBox Err.Description, vbCritical
        Exit Sub
    Else
        On Error GoTo 0
    End If
    
    bRun = True
    
    '设置进度条
    ProgressBar1.Min = 0
    ProgressBar1.Max = rsA.RecordCount
    
    Do While Not rsA.EOF
        '进度条加一
        If ProgressBar1.Value < ProgressBar1.Max Then
            ProgressBar1.Value = ProgressBar1.Value + 1
        End If
        
        If Not bRun Then
            Exit Sub
        End If
        
        
        orderid = rsA("orderid")
        selfcode = rsA("自编号")
        quantity = rsA("数量")
        bookname = rsA("name")
        
        lblDisplay2.Caption = "正在检索" & db1 & "中的" & orderid & "--" & selfcode & "--" & bookname
        
        searchsql = "select 数量 from " & tablename & " where orderid='" & orderid & "' and 自编号 = '" & selfcode & "' "
        On Error Resume Next
        rsB.Open searchsql, connB, 1, 1
        If Err.Number <> 0 Then
            MsgBox Err.Description, vbCritical
            Exit Sub
        Else
            On Error GoTo 0
        End If
        
        If Not rsB.EOF Then
            rsA("差额") = quantity - rsB("数量")
            rsA("附加说明") = ""
        Else
            rsA("附加说明") = "与之比较表的中没有该订单号相同且自编号也相同的记录"
            rsA("差额") = 0
        End If
        
        rsB.Close
        rsA.Update
        rsA.MoveNext
        
        DoEvents
    Loop
    
    rsA.Close
         
    
    connA.Close
    connB.Close
    
    
    
End Sub

Private Sub cmd_mergeA_Click()
    Call mergeTable(txt_sourceA, ListA, lbl_infoA)
End Sub

Private Sub cmd_mergeB_Click()
    Call mergeTable(txt_sourceB, ListB, lbl_infoB)
End Sub

Private Sub cmd_selectA_Click()
    Call searchTable(txt_sourceA, ListA, lbl_infoA)
End Sub

Private Sub cmd_selectB_Click()
    Call searchTable(txt_sourceB, ListB, lbl_infoB)
End Sub



Private Sub searchTable(oneText As TextBox, oneList As ListBox, oneLabel As Label) '检索数据表过程
    oneList.Clear
    oneList.Clear
    CommonDialogAB.ShowOpen
    oneText.Text = CommonDialogAB.FileName
    
    db = oneText.Text
    
    '连接源数据库
    Dim conn As New ADODB.Connection
    DbPw = ""
    On Error Resume Next
    ConnStr = "PROVIDER=microsoft.jet.oledb.4.0;persist security info =false;data source=" & db & ";Jet OLEDB:Database Password=" & DbPw
    
    conn.Open ConnStr
    
    If Err <> 0 Then
        MsgBox Err.Description
        Exit Sub
    End If
    
    '填充list列表控件
    Set rstSchema = conn.OpenSchema(adSchemaTables)
    Do Until rstSchema.EOF
        If rstSchema!TABLE_TYPE = "TABLE" And InStr(rstSchema!TABLE_NAME, "_saomiao") > 0 Then
            oneList.AddItem (rstSchema!TABLE_NAME)
        End If
        rstSchema.MoveNext
    Loop
    rstSchema.Close
    
    oneLabel.Caption = " 共检索到" & oneList.ListCount & "个数据表"
    

    
End Sub

Private Sub mergeTable(oneText As TextBox, oneList As ListBox, oneLabel As Label) '合并数据表过程

    db = oneText.Text
    
    '连接源数据库
    Dim conn As New ADODB.Connection
    DbPw = ""
    On Error Resume Next
    ConnStr = "PROVIDER=microsoft.jet.oledb.4.0;persist security info =false;data source=" & db & ";Jet OLEDB:Database Password=" & DbPw
    
    conn.Open ConnStr
    
    If Err <> 0 Then
        MsgBox Err.Description
        Exit Sub
    End If
    

    Set db = OpenDatabase(db)
    
    findtable = 0
    tablename = "所有渠道总表（库房和客服人员比较专用）"
    field1 = "orderid,gid,自编号,isbn,name,pub,定价,折扣,数量,find,0 as 差额,'' as 附加说明 "
    
    '------------搜索tablename是否存在----------------
    For dbs = 0 To db.TableDefs.Count - 1
        If db.TableDefs(dbs).Name = tablename Then
            findtable = 1
        End If
    Next
    '------------------------------------------------
    
    '创建表的结构
    If findtable = 1 Then
        YesNo = MsgBox(oneText & "中已存在" & tablename & "," & vbCrLf & "要覆盖吗？", vbYesNo + vbQuestion)
        If YesNo = 7 Then
            Exit Sub
        End If
        SQL = "DROP TABLE " & tablename
        On Error Resume Next
        conn.Execute SQL
        If Err.Number <> 0 Then
            MsgBox Err.Description, vbCritical
            Exit Sub
        Else
            On Error GoTo 0
        End If
    End If

    SQL = "select '' as 所属渠道," & field1 & " into " & tablename & " from chinapub_saomiao where 1<>1 " '只创建结构
    On Error Resume Next
    conn.Execute SQL
    If Err.Number <> 0 Then
        MsgBox Err.Description, vbCritical
        Exit Sub
    Else
        On Error GoTo 0
    End If

    
    If oneList.ListCount = 0 Then
        MsgBox "请至少选择一个表"
        Exit Sub
    End If
    
    '合并数据
    For i = 0 To oneList.ListCount - 1
        SQL = "insert into " & tablename & " select  '" & oneList.List(i) & "' as 所属渠道," & field1 & "  from  " & oneList.List(i)
        conn.Execute SQL
    Next
    
    MsgBox oneText & "已自动创建了渠道总表" & vbCrLf & "表名：" & tablename, vbInformation
End Sub



Private Sub Form_Unload(Cancel As Integer)
    bRun = False
End Sub

Private Sub helpme_Click(Index As Integer)
    frmHelp.Show
End Sub