frm1.frm

数据同步工具

    CD1.Filter = "文本文件(*.txt)|*.txt|其他文件(*.*)|*.*"
    CD1.FilterIndex = 1
    CD1.ShowOpen
    S = CD1.FileName
    If S = "" Then Exit Sub
    If gFSO.FileExists(S) = False Then Exit Sub
    OpenTableList S
    Exit Sub
Err1:

End Sub

Private Sub cmdSelectDest_Click()
    Dim strFileName As String
    
    On Error GoTo Err1
    CD1.CancelError = True
    CD1.Filter = "数据库配置文件(*.ini)|*.ini|其他文件(*.*)|*.*"
    CD1.FilterIndex = 1
    CD1.ShowOpen
    strFileName = CD1.FileName
    If strFileName = "" Then Exit Sub
    
    If gFSO.FileExists(strFileName) = False Then
        XF_MsgE strFileName & " 不存在!"
    Else
        If mobjDBD.Connect Then mobjDBD.Disconnect
        lblD.Caption = "未连接"
        txtD.Text = ""
        mstrIniD = ""
        
        If mobjDBD.Init(strFileName) = False Then
            XF_ShowErrInfo mobjDBD.ErrInfo, , , "初始化目标数据库对象"
        Else
            txtD.Text = mobjDBD.DBTypeString & " " & mobjDBD.DBConnectString
            mstrIniD = strFileName
        End If
    End If
    
    Exit Sub
Err1:
End Sub

Private Sub cmdSelectSource_Click()
    Dim strFileName As String
    
    On Error GoTo Err1
    CD1.CancelError = True
    CD1.Filter = "数据库配置文件(*.ini)|*.ini|其他文件(*.*)|*.*"
    CD1.FilterIndex = 1
    CD1.ShowOpen
    strFileName = CD1.FileName
    If strFileName = "" Then Exit Sub
    
    If gFSO.FileExists(strFileName) = False Then
        XF_MsgE strFileName & " 不存在!"
    Else
        If mobjDBS.Connect Then mobjDBS.Disconnect
        lblS.Caption = "未连接"
        txtS.Text = ""
        mstrIniS = ""
        
        If mobjDBS.Init(strFileName) = False Then
            XF_ShowErrInfo mobjDBS.ErrInfo, , , "初始化源数据库对象"
        Else
            txtS.Text = mobjDBS.DBTypeString & " " & mobjDBS.DBConnectString
            mstrIniS = strFileName
        End If
    End If
    
    Exit Sub
Err1:

End Sub

Private Sub cmdSelectSQL_Click()
    Dim S As String
    On Error GoTo Err1
    CD1.CancelError = True
    CD1.Filter = "SQL脚本文件(*.sql)|*.sql|文本文件(*.txt)|*.txt|其他文件(*.*)|*.*"
    CD1.FilterIndex = 1
    CD1.ShowSave
    S = CD1.FileName
    If S = "" Then Exit Sub
    txtSQLFile.Text = S
    Exit Sub
Err1:
End Sub

Private Sub cmdShowErrRecord_Click()
    If mfrmErr Is Nothing Then
        XF_MsgE "还未执行操作，所以没有错误记录可看!"
        Exit Sub
    End If
    mfrmErr.Show
End Sub

Private Sub cmdStart_Click()

    Dim I As Long
    Dim J As Long
    Dim K As Long
    Dim S As String
    Dim S1 As String
    Dim s_SQL As String
    Dim rs As ADODB.Recordset
    Dim rs1 As ADODB.Recordset
    Dim s_Table As String                       '数据表名
    Dim s_Option As String                      '操作类别
    
    Dim n_WriteCount As Long                    '写成功记录数量
    Dim n_ReadCount As Long                     '从数据源读取记录数量
    Dim n_ErrCount As Long                      '写失败记录数量

    Dim s_FieldList As String
    Dim n_ResaultCol As Integer
    Dim n_Total As Long                         '数据源记录总数
    Dim dtm_Start As Date                       '本次操作开始时间
    
    Dim objPara As New clsPara
    
    Dim n_MaxRecords As Long                    '写入目标数据库的最大记录数。
    Dim s_Where As String                       '查询 / 删除记录条件
    Dim s_From As String                        '字段列表按源 或 目标 表为准
    Dim s_SourceSQL As String                   '从源 中查询记录的 SQL
    Dim s_DestSQL As String                     '从目标表查询记录的SQL
    Dim s_DestFieldList As String               '目标字段列表
    
    Dim n_AllowErrCount As Long                 '最大允许错误数
    Dim blnErr As Boolean                       '整个操作期间是否出错。
    
    Dim tDF() As TYPE_FIELDDEFINE
    
    Dim strSQLFile As String
    Dim ts As TextStream
    
    n_ResaultCol = 7
    
    F1.EndEdit
    
    If mobjDBS.DBConnect = False Then
        XF_MsgE "源数据库还未连接!"
        Exit Sub
    End If
    
    If chkSQL.Value = 1 Then
        txtSQLFile.Text = Trim(txtSQLFile.Text)
        If txtSQLFile.Text = "" Then
            XF_MsgE "请输入SQL文件路径!"
            txtSQLFile.SetFocus
            Exit Sub
        End If
        
        If gFSO.FileExists(txtSQLFile.Text) Then
            I = MsgBox("SQL文件已存在。选 是(Y)重写该文件，选 否(N)将本次操作内容追加到该文件后，否则请选择取消(Cancel)。", _
                vbQuestion + vbYesNoCancel, gstrAppName & " - 询问您")
            If I = vbCancel Then
                Exit Sub
            End If
            If I = vbYes Then
                On Error Resume Next
                Set ts = gFSO.CreateTextFile(txtSQLFile.Text, True)
                If Err.Number <> 0 Then
                    XF_ShowErr "创建SQL脚本文件", Err
                    Exit Sub
                End If
                On Error GoTo 0
            End If
            If I = vbNo Then
                On Error Resume Next
                Set ts = gFSO.OpenTextFile(txtSQLFile.Text, ForAppending, False)
                If Err.Number <> 0 Then
                    XF_ShowErr "打开SQL脚本文件", Err
                    Exit Sub
                End If
                On Error GoTo 0
            End If
        Else
            On Error Resume Next
            Set ts = gFSO.CreateTextFile(txtSQLFile.Text, True)
            If Err.Number <> 0 Then
                XF_ShowErr "创建SQL脚本文件", Err
                Exit Sub
            End If
            On Error GoTo 0
        End If
        
        ts.WriteLine "/*" & vbCrLf & _
            "说明：             本SQL脚本文件由 XF_DataCopy 程序生成" & vbCrLf & _
            "配置列表文件：     " & mstrListFile & vbCrLf & _
            "源数据库：         " & mobjDBS.DBTypeString & vbCrLf & _
            "目标数据库：       " & mobjDBD.DBTypeString & vbCrLf & _
            "生成时间：         " & Format(Now, "yyyy-mm-dd hH:Nn:Ss") & vbCrLf & _
            "*/" & vbCrLf
    Else
        If mobjDBD.DBConnect = False Then
            XF_MsgE "目标数据库还未连接!"
            Exit Sub
        End If
    End If
    
    objPara.FGF_Para = ";"
    objPara.FGF_NameValue = "="
    
    With F1
    For I = 1 To .MaxRow
        If .TextRC(I, 1) = "1" Then
            .TextRC(I, 4) = ""
            .TextRC(I, 5) = ""
            .TextRC(I, 6) = ""
            .TextRC(I, 7) = ""
        End If
    Next
    
    mdtm_Start = Now
    sbar.Panels("starttime").Text = "开始:" & Format(Now, "Hh:Nn:Ss")
    sbar.Panels("usetime").Text = ""
    Timer1.Enabled = True
    
    cmdStart.Enabled = False
    cmdStop.Enabled = True
    cmdStop.Tag = ""
    cmdShowErrRecord.Enabled = False
    
    Set mfrmErr = New frmErrRecord
    
    mfrmErr.LV1.ListItems.Clear
    For I = mfrmErr.F1.UBound To 1 Step -1
        Unload mfrmErr.F1(I)
    Next
    blnErr = False
    
    I = 1
    For I = 1 To .MaxRow
    
        On Error GoTo Err1
        
        s_Table = ""
        J = 0
        K = 0
        s_FieldList = ""
        n_Total = 0
        n_MaxRecords = 0
        n_ErrCount = 0
        ReDim tDF(0)
        dtm_Start = Now
        
        .Row = I
        .SetActiveCell .Row, .Col
        .ShowActiveCell
        sbar.Panels("info") = I & " - " & .TextRC(I, 2) & " - " & .TextRC(I, 3)
        DoEvents
        
        
        If cmdStop.Tag = "1" Then Exit For
        If Trim(.TextRC(I, 1)) <> "1" Then GoTo Next1
        s_Table = Trim(.TextRC(I, 2))
        If s_Table = "" Then GoTo Next1
        
        'option可以为：
        'delete     (删除全部记录）
        'add        (追加记录）
        'refresh    (刷新记录，先删除后追加）
        
        '参数格式为  f=s;n=100
        '参数说明:   f:   数据同步来源 s:以源为标准，d:以目标为标准
        '           n:  写目标数据库的最大记录数
        '           w:  where 条件
        
        s_Option = Trim(.TextRC(I, 3))
        K = InStr(1, s_Option, " ")
        If K > 0 Then
            S = Trim(Mid(s_Option, K + 1))
            s_Option = LCase(Trim(Mid(s_Option, 1, K - 1)))
        Else
            S = ""
        End If
        objPara.ParaString = S
        
        S = Trim(objPara.GetValue("maxrecords"))
        If S = "" Then
            n_MaxRecords = 0
        Else
            If IsNumeric(S) = False Then
                n_MaxRecords = 0
            Else
                n_MaxRecords = Val(S)
                If n_MaxRecords < 0 Then n_MaxRecords = 0
            End If
        End If
        
        'fieldlistfrom 参数，指出从源表中查询记录时应是按照源表还是目标表
        s_From = Trim(objPara.GetValue("fieldlistfrom"))
        If s_From <> "dest" Then
            s_From = "source"
        End If
        
        'where 参数指定 从源表查询记录或目标表删除记录时的条件。
        s_Where = Trim(objPara.GetValue("where"))
        
        'sourcesql参数 可以给数据源指定一个SQL，一个完整的Select SQL，指定该SQL后，从源表查询记录不使用 where 条件。
        s_SourceSQL = Trim(objPara.GetValue("sourcesql"))
        
        'destfieldlist 数据目标字段列表。如果未指定该参数，则默认为 * (全部字段）
        s_DestFieldList = Trim(objPara.GetValue("destfieldlist"))
        
        'allowerrcount 最大允许错误数。默认0：一出错就退出；-1：忽略所有发生的错误；>0 ：允许指定的错误数
        S = Trim(objPara.GetValue("allowerrcount"))
        If S = "" Then
            n_AllowErrCount = 0
        Else
            If IsNumeric(S) = False Then
                n_AllowErrCount = 0
            Else
                n_AllowErrCount = Val(S)
            End If
        End If
                
        Select Case s_Option
            
            Case "delete"
                If chkSQL.Value = 1 Then
                    s_SQL = "delete from " & s_Table
                    If s_Where <> "" Then s_SQL = s_SQL & " where " & s_Where
                    ts.WriteLine "" & vbCrLf & "/*  delete " & s_Table & "  */" & vbCrLf & s_SQL & ";"
                    .TextRC(I, n_ResaultCol) = "目标表记录已删除"
                Else
                    s_SQL = "select * from " & s_Table & " where 1=0"
                    If mobjDBD.GetRecordSet(s_SQL, rs1) = False Then
                        .TextRC(I, n_ResaultCol) = "目标表不存在"
                        GoTo Next1
                    End If
                    s_SQL = "delete from " & s_Table
                    If s_Where <> "" Then s_SQL = s_SQL & " where " & s_Where
                    .TextRC(I, n_ResaultCol) = "正在清除目标表记录，请稍候..."
                    DoEvents
                    If mobjDBD.ExeSQL(s_SQL) = False Then
                        .TextRC(I, n_ResaultCol) = "清除目标表记录错误:" & mobjDBD.ErrDesc
                        GoTo Next1
                    End If
                    .TextRC(I, n_ResaultCol) = "目标表记录已删除"
                End If
                .TextRC(I, 1) = ""
            Case Is = "add", "refresh"
                If s_SourceSQL = "" Then
                    s_SQL = "select * from " & s_Table & " where 1=0"
                    If mobjDBS.GetRecordSet(s_SQL, rs) = False Then
                        .TextRC(I, n_ResaultCol) = "源表不存在"
                        GoTo Next1
                    End If
                Else
                    If InStr(1, LCase(s_SourceSQL), "where") > 0 Then
                        s_SQL = s_SourceSQL & " and 1=0"
                    Else
                        s_SQL = s_SourceSQL & " where 1=0"
                    End If
                    If mobjDBS.GetRecordSet(s_SQL, rs) = False Then
                        .TextRC(I, n_ResaultCol) = "从数据源查询记录出错 " & mobjDBS.ErrDesc
                        GoTo Next1
                    End If
                End If
                        
                If chkSQL.Value = 0 Then
                    s_SQL = "select * from " & s_Table & " where 1=0"
                    If mobjDBD.GetRecordSet(s_SQL, rs1) = False Then
                        .TextRC(I, n_ResaultCol) = "目标表不存在"