frm1.frm

数据同步工具

                        GoTo Next1
                    End If
                End If
                
                If s_From = "source" Then
                    For K = 0 To rs.Fields.Count - 1
                        s_FieldList = s_FieldList & "," & rs.Fields(K).Name
                    Next
                    s_FieldList = Mid(s_FieldList, 2)
                Else
                    If s_DestFieldList = "" Then
                        If chkNoConnectD.Value = 1 Then
                            .TextRC(I, n_ResaultCol) = "该数据表更新设置为 字段列表参照目标数据库，但不连接目标数据库" & _
                                "就不能获取字段列表。或者请设置 destfieldlist 参数手动指定目标表字段。"
                            GoTo Next1
                        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
                            For K = 0 To rs1.Fields.Count - 1
                                s_FieldList = s_FieldList & "," & rs1.Fields(K).Name
                            Next
                            s_FieldList = Mid(s_FieldList, 2)
                        End If
                    Else
                        s_FieldList = s_DestFieldList
                    End If
                End If
                
                If s_Option = "refresh" Then
                    s_SQL = "delete from " & s_Table
                    If s_Where <> "" Then s_SQL = s_SQL & " where " & s_Where
                    If chkSQL.Value = 1 Then
                        ts.WriteLine "" & vbCrLf & "/*  delete " & s_Table & "  */" & vbCrLf & s_SQL & ";"
                    Else
                        .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) = ""
                        DoEvents
                    End If
                End If
                
                If s_SourceSQL = "" Then
                    s_SQL = "select count(*) from " & s_Table
                    If s_Where <> "" Then s_SQL = s_SQL & " where " & s_Where
                    If mobjDBS.GetRecordSet(s_SQL, rs) = False Then
                        .TextRC(I, n_ResaultCol) = "查询源表记录总数错误:" & mobjDBS.ErrDesc
                        GoTo Next1
                    End If
                    n_Total = RIsN(rs(0), 0)
                    .TextRC(I, 4) = n_Total
                Else
                    n_Total = -1
                    .TextRC(I, 4) = "未知"
                End If
                
                If s_SourceSQL = "" Then
                    s_SourceSQL = "select " & s_FieldList & " from " & s_Table
                    If s_Where <> "" Then s_SourceSQL = s_SourceSQL & " where " & s_Where
                End If
                
                If mobjDBS.GetRecordSet(s_SourceSQL, rs, adUseServer, adOpenForwardOnly, adLockReadOnly) = False Then
                    .TextRC(I, n_ResaultCol) = "从源表查询记录错误:" & mobjDBS.ErrDesc
                    GoTo Next1
                End If
                

                
                n_ReadCount = 0
                n_WriteCount = 0
                n_ErrCount = 0
                J = 0
                
                mfrmErr.LV1.ListItems.Add , "k" & I, s_Table
                Load mfrmErr.F1(I)

                mfrmErr.F1(I).Top = mfrmErr.F1(0).Top
                mfrmErr.F1(I).Left = mfrmErr.F1(0).Left
                mfrmErr.F1(I).Width = mfrmErr.F1(0).Width
                mfrmErr.F1(I).Height = mfrmErr.F1(0).Height
                
                mfrmErr.F1(I).MaxRow = 1
                mfrmErr.F1(I).MaxCol = rs.Fields.Count + 1
                For K = 0 To rs.Fields.Count - 1
                    mfrmErr.F1(I).ColText(K + 1) = rs.Fields(K).Name
                Next
                mfrmErr.F1(I).ColText(mfrmErr.F1(I).MaxCol) = "错误提示"
                
                ReDim tDF(rs.Fields.Count - 1)
                
                If chkNoConnectD.Value = 1 Then
                    For K = 0 To rs.Fields.Count - 1
                        tDF(K).FieldName = rs.Fields(K).Name
                        tDF(K).DataType = GetDataType(rs.Fields(K).Type)
                        If tDF(K).DataType = "" Then
                            .TextRC(I, n_ResaultCol) = "源表字段 " & _
                                rs.Fields(K).Name & "(" & rs.Fields(K).Type & ") 的数据类型未知，" & _
                                "不能进行处理。您可以手动将该数据类型添加到 Config.ini 文件中，然后再处理该表。"
                            GoTo Next1
                        End If
                    Next
                Else
                    s_DestSQL = "select " & s_FieldList & " from " & s_Table & " where 1=0"
    
                    If mobjDBD.GetRecordSet(s_DestSQL, rs1, adUseClient, adOpenStatic, adLockOptimistic) = False Then
                        .TextRC(I, n_ResaultCol) = "打开目标表错误:" & mobjDBD.ErrDesc
                        GoTo Next1
                    End If
                    
                    If rs.Fields.Count <> rs1.Fields.Count Then
                        .TextRC(I, n_ResaultCol) = "源表和目标表字段数不同，不能复制记录"
                        GoTo Next1
                    End If
                    
                    For K = 0 To rs1.Fields.Count - 1
                        tDF(K).FieldName = rs1.Fields(K).Name
                        tDF(K).DataType = GetDataType(rs1.Fields(K).Type)
                        If tDF(K).DataType = "" Then
                            .TextRC(I, n_ResaultCol) = "目标表字段 " & _
                                rs1.Fields(K).Name & "(" & rs1.Fields(K).Type & ") 的数据类型未知，" & _
                                "不能进行处理。您可以手动将该数据类型添加到 Config.ini 文件中，然后再处理该表。"
                            GoTo Next1
                        End If
                    Next
                    rs1.Close
                End If
                
                If chkSQL.Value = 1 Then ts.WriteLine "" & vbCrLf & "/*  insert " & s_Table & "  */"
                s_SQL = "insert into " & s_Table & "(" & s_FieldList & ") values ("
                Do While Not rs.EOF
                    n_ReadCount = n_ReadCount + 1
                    J = J + 1
                    S = s_SQL
                    For K = 0 To UBound(tDF)
                        S = S & mobjDBD.GetSS(RIsN(rs(K)), tDF(K).DataType) & ","
                    Next
                    S = Mid(S, 1, Len(S) - 1)
                    S = S & ")"
                    If chkSQL.Value = 1 Then
                        ts.WriteLine S & ";"
                        n_WriteCount = n_WriteCount + 1
                    Else
                        If mobjDBD.ExeSQL(S) = False Then
                            blnErr = True
                            n_ErrCount = n_ErrCount + 1
                            mfrmErr.F1(I).MaxRow = n_ErrCount
                            For K = 0 To rs.Fields.Count - 1
                                mfrmErr.F1(I).TextRC(n_ErrCount, K + 1) = RIsN(rs(K))
                            Next
                            mfrmErr.F1(I).TextRC(n_ErrCount, mfrmErr.F1(I).MaxCol) = mobjDBD.ErrDesc
                        Else
                            n_WriteCount = n_WriteCount + 1
                        End If
                    End If

                    If J >= 10 Then
                        J = 0
                        .TextRC(I, 5) = n_WriteCount & " / " & n_ErrCount
                        If n_Total > 0 Then
                            .TextRC(I, 6) = Int(n_ReadCount * 100 / n_Total)
                        End If
                        .TextRC(I, 6) = .TextRC(I, 6) & "%  " & XF_FJSeconds(DateDiff("s", dtm_Start, Now))
                        DoEvents
                        If cmdStop.Tag = "1" Then Exit For
                    End If
                    
                    rs.MoveNext
                    
                    If n_AllowErrCount > 0 Then
                        If n_ErrCount >= n_AllowErrCount Then
                            .TextRC(I, n_ResaultCol) = "写记录错误数已达到最大错误数：" & n_AllowErrCount & "，操作未完成" & S
                            GoTo Next1
                        End If
                    Else
                        If n_AllowErrCount = 0 Then
                            If n_ErrCount > 0 Then
                                .TextRC(I, n_ResaultCol) = "发生错误，操作未完成" & S
                                GoTo Next1
                            End If
                        End If
                    End If
                    
                    If n_MaxRecords > 0 Then
                        If n_WriteCount >= n_MaxRecords Then
                            Exit Do
                        End If
                    End If
                Loop
                rs.Close
                
                If J > 0 Then
                    .TextRC(I, 5) = n_WriteCount & " / " & n_ErrCount
                    If n_Total > 0 Then
                        .TextRC(I, 6) = Int(n_ReadCount * 100 / n_Total)
                    End If
                    .TextRC(I, 6) = .TextRC(I, 6) & "%  " & XF_FJSeconds(DateDiff("s", dtm_Start, Now))
                    DoEvents
                End If
                
                If s_Option = "add" Then
                    .TextRC(I, n_ResaultCol) = "记录已追加"
                Else
                    .TextRC(I, n_ResaultCol) = "记录已刷新"
                End If
                
                If n_ErrCount > 0 Then
                    .TextRC(I, n_ResaultCol) = .TextRC(I, n_ResaultCol) & "(有错误)"
                Else
                    mfrmErr.LV1.ListItems.Remove ("k" & I)
                End If
                    
                .TextRC(I, 1) = ""
            Case Else
                .TextRC(I, n_ResaultCol) = "错误的操作方法"
        End Select
Next1:
    Next
    End With
    Timer1.Enabled = False
    cmdStart.Enabled = True
    cmdStop.Enabled = False
    
    If chkSQL.Value = 1 Then
        ts.Close
    End If
    
    If cmdStop.Tag = "" Then
        sbar.Panels("info").Text = "操作已完成!"
        XF_MsgI "操作已完成!"
    Else
        sbar.Panels("info").Text = sbar.Panels("info").Text & " 操作被中断!"
        XF_MsgI "操作被中断!"
    End If
    If blnErr Then cmdShowErrRecord.Enabled = True
    Exit Sub
Err1:
    F1.TextRC(I, n_ResaultCol) = "出错:" & Err.Description
    Err.Clear
    GoTo Next1
End Sub

Private Sub cmdStop_Click()
    cmdStop.Tag = "1"
End Sub

Private Sub Form_Load()
    If IniData = False Then
        Unload Me
        Exit Sub
    End If
    Me.Show
End Sub

Private Function IniData() As Boolean
    IniData = False
    
    gstrAppName = "XF_DataCopyV1.0"
    gstrAppPath = App.Path
    
    mstrIniS = gstrAppPath & "\Database_Config_S.ini"
    mstrIniD = gstrAppPath & "\Database_Config_D.ini"
    
    If ReadConfig = False Then Exit Function
    
    Set mobjDBS = New clsDB
    Set mobjDBD = New clsDB
    
    mstrCP = Me.Caption
    
    If gFSO.FileExists(mstrIniS) = False Then
        'XF_MsgE mstrIniS & " 不存在!"
    Else
        If mobjDBS.Init(mstrIniS) = False Then
            XF_ShowErrInfo mobjDBS.ErrInfo, , , "初始化源数据库对象"
        Else
            txtS.Text = mobjDBS.DBTypeString & " " & mobjDBS.DBConnectString
        End If
    End If
    
    If gFSO.FileExists(mstrIniD) = False Then
'        XF_MsgE mstrIniD & " 不存在!"
    Else
        If mobjDBD.Init(mstrIniD) = False Then
            XF_ShowErrInfo mobjDBD.ErrInfo, , , "初始化目标数据库对象"
        Else
            txtD.Text = mobjDBD.DBTypeString & " " & mobjDBD.DBConnectString
        End If
    End If
    
    If gFSO.FileExists(gstrAppPath & "\tablelist.txt") Then
        OpenTableList gstrAppPath & "\tablelist.txt"
    End If
     
    cmdStart.Enabled = False
    cmdStop.Enabled = False
    cmdShowErrRecord.Enabled = False
    chkNoConnectD.Enabled = False
    IniData = True
End Function

Private Function OpenTableList(pstrListFile As String) As Boolean

    Dim S As String
    Dim S1 As String
    Dim strTable As String
    Dim strOption As String
    
    Dim ts As TextStream
    Dim I As Integer
    Dim J As Integer
    OpenTableList = False
    On Error GoTo Err1
    F1.ClearRange 1, 1, F1.MaxRow, F1.MaxCol, F1ClearValues
    F1.MaxRow = 1
    
    Set ts = gFSO.OpenTextFile(pstrListFile)
    I = 0
    Do While Not ts.AtEndOfStream
        S = Trim(ts.ReadLine)
        If S = "" Then GoTo Next1
        If Mid(S, 1, 1) = "'" Then GoTo Next1
        J = InStr(1, S, ",")
        If J = 0 Then GoTo Next1
        strTable = Trim(Mid(S, 1, J - 1))
        strOption = Trim(Mid(S, J + 1))

        I = I + 1
        F1.MaxRow = I
        F1.TextRC(I, 1) = "1"
        F1.TextRC(I, 2) = Trim(strTable)
        F1.TextRC(I, 3) = Trim(strOption)
Next1:
    Loop
    ts.Close
    Me.Caption = mstrCP & " - " & pstrListFile
    mstrListFile = pstrListFile
    OpenTableList = True
    Exit Function
Err1:
    XF_ShowErr "打开配置文件", Err
End Function

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    If mobjDBS.Connect Then mobjDBS.Disconnect
    If mobjDBD.Connect Then mobjDBD.Disconnect
    Set mobjDBS = Nothing
    Set mobjDBD = Nothing
    If mfrmErr Is Nothing Then
    
    Else
        Unload mfrmErr
        Set mfrmErr = Nothing
    End If
End Sub

Private Sub Timer1_Timer()
    sbar.Panels("usetime").Text = "已用:" & XF_FJSeconds(DateDiff("s", mdtm_Start, Now))
End Sub