frmopen.frm

CheckTwoFile比较任意两个CSV文件, 得出不同的部分

                'If InStr(1, CC(i), s) = 0 Then
                    'FLD(i) = FLD(i) & "," & s
                'End If
                FLD(i) = FLD(i) & s & ","
            Next
        End If  ''' check two CSV file
        FLD(i) = Mid(FLD(i), 1, Len(FLD(i)) - 1)
        
        If iCheckType = 1 Then
            Do While Not rs.EOF
                r = r + 1
                sSQL = "Insert Into " & sTblName & " Values (" & r
                strckValue = ""
                For j = 0 To rs.Fields.Count - 1
                    strValue = Replace(IIf(IsNull(rs(j)), "", Trim(rs(j))), "'", "''")
                    strValue = Replace(strValue, Chr(160), "")
                    strValue = Replace(strValue, " ", "")
                    If Len(strValue) > 64 Then strValue = Mid(strValue, 1, 64)
                    For u = 0 To UBound(aa) 'to get ckFlag Value
                        If UCase(Trim(aa(u))) = "[" & UCase(Trim(rs(j).Name)) & "]" Then
                            strckValue = strckValue & strValue & "_"
                            Exit For
                        End If
                    Next
                    sSQL = sSQL & ",'" & strValue & "'"
                Next
                
                DoEvents
                lblAll = pb.Value & "/" & iRc
                pb.Value = pb.Value + 1
                lblbfb = Format(pb.Value / pb.Max * 100, "#,##0.00") & "%"
                
                If strckValue <> "" Then strckValue = Mid(strckValue, 1, Len(strckValue) - 1)
                sSQL = sSQL & ",0,'" & strckValue & "')"
                sb.Panels(2).Text = sSQL
                
                cnExecuteSQL (sSQL)  ''' ckFlag
                'If i = 2 Then MsgBox sSQL, vbInformation, InfoMsg
                rs.MoveNext
            Loop
            
        Else ''' checkType ? xls ? csv ?
        
            fs.ReadLine ''' remove the first line
            ff = Split(bb(i), ",")
            Do While Not fs.AtEndOfStream
                r = r + 1
                sSQL = "Insert Into " & sTblName & " Values (" & r
                strckValue = ""
                vv = Split(Trim(fs.ReadLine), ",")
                For j = 0 To UBound(ff)
                    If j <= UBound(vv) Then
                        strValue = Trim(vv(j)) ''' Ucase
                        If Len(strValue) > 64 Then strValue = Mid(strValue, 1, 64)
                        strValue = Replace(strValue, "_*_", ",")
                        strValue = Replace(strValue, Chr(160), "")
                        strValue = Replace(strValue, " ", "")
                        For u = 0 To UBound(aa)  ''' select column to get ckFlag Value
                            If UCase(Trim(aa(u))) = "[" & UCase(Trim(ff(j))) & "]" Then
                                strckValue = strckValue & strValue & "_"
                                Exit For
                            End If
                        Next
                    Else
                        strValue = ""
                    End If
                    sSQL = sSQL & ",'" & strValue & "'"
                Next
                
                DoEvents
                lblAll = pb.Value & "/" & iRc
                pb.Value = pb.Value + 1
                lblbfb = Format(pb.Value / pb.Max * 100, "#,##0.00") & "%"
                
                If strckValue <> "" Then strckValue = Mid(strckValue, 1, Len(strckValue) - 1)
                sSQL = sSQL & ",0,'" & strckValue & "')"
                sb.Panels(2).Text = sSQL
                
                cnExecuteSQL (sSQL)  ''' ckFlag
                'If i = 2 Then MsgBox sSQL, vbInformation, InfoMsg
            Loop
            fs.Close
            
        End If ''' ck Xls ? csv 2
        
    Next
    
    ''' for Index !!!
    If cn.State = 1 Then cn.Close
    cn.Open
    
    Dim strSour, strAnd, strAdd As String
    
    DoEvents
    
    If rs.State = 1 Then rs.Close
    pb.Min = 1
    pb.Value = 1
    pb.Max = 6
    
    strSour = "ckCol"
   
    pb.Value = 1
    sb.Panels(2).Text = "Deleting Null Xls1..."
    cn.Execute ("Delete From CheckXls1 Where " & strSour & "=''")
    
    pb.Value = 2
    sb.Panels(2).Text = "Checking 8 (Equal) Xls1..."
    sSQL = "Update CheckXls1 Set ckFlag=8 Where " & strSour & " In (Select " & strSour & " From CheckXls2)"
    cn.Execute (sSQL)
    
    pb.Value = 3
    sb.Panels(2).Text = "Counting 2 | 4 (Ct>1) Xls1..."
    sSQL = "Update checkXls1 Set ckFlag=2 Where " & strSour & " In (Select " & strSour & " from checkXls1 Group By " & strSour & " Having(Count(*)) > 1)"
    cn.Execute (sSQL)
    sSQL = "Update checkXls1 Set ckFlag=4 Where " & strSour & " In (Select " & strSour & " from checkXls2 Group By " & strSour & " Having(Count(*)) > 1)"
    cn.Execute (sSQL)
    
    DoEvents
    
    pb.Value = 4
    sb.Panels(2).Text = "Deleting Null Xls2..."
    cn.Execute ("Delete From CheckXls2 Where " & strSour & "=''")
    
    pb.Value = 5
    sb.Panels(2).Text = "Checking 8 (Equal) Xls2..."
    sSQL = "Update CheckXls2 Set ckFlag=8 Where " & strSour & " In (Select " & strSour & " From CheckXls1)"
    cn.Execute (sSQL)
    
    pb.Value = 6
    sb.Panels(2).Text = "Counting 2 | 4 (Ct>1) Xls2..."
    sSQL = "Update checkXls2 Set ckFlag=2 Where " & strSour & " In (Select " & strSour & " from checkXls2 Group By " & strSour & " Having(Count(*)) > 1)"
    cn.Execute (sSQL)
    sSQL = "Update checkXls2 Set ckFlag=4 Where " & strSour & " In (Select " & strSour & " from checkXls1 Group By " & strSour & " Having(Count(*)) > 1)"
    cn.Execute (sSQL)
   
    Dim sXlsFile As String
    Dim sPath As String
    
    Dim sTj As String
    Dim arrSQL(2) As String
    Dim sMsg As String
    
    sSQL = "Update CheckXls1 Set ckCol=ckCol+'_'+ckFlag" ''' Where " & strSour & " In (Select " & strSour & " From CheckXls2)"
    sb.Panels(2).Text = sSQL
    cn.Execute (sSQL)
    sSQL = "Update CheckXls2 Set ckCol=ckCol+'_'+ckFlag" ''' Where " & strSour & " In (Select " & strSour & " From CheckXls2)"
    sb.Panels(2).Text = sSQL
    cn.Execute (sSQL)
    
    arrSQL(1) = "Select * From checkXls1 Where ckCol Not In (Select ckCol From CheckXls2)"
    arrSQL(2) = "Select * From checkXls2 Where ckCol Not In (Select ckCol From CheckXls1)"
    If ickSAME = 1 Then  ''' SAME DATA
        arrSQL(1) = Replace(arrSQL(1), "Not In", "In")
        arrSQL(2) = Replace(arrSQL(2), "Not In", "In")
    End If
    sb.Panels(2).Text = "Creating Result.."

    sPath = App.Path
    If Right(App.Path, 1) <> "\" Then sPath = App.Path & "\"
    
    If ickGetTWO = 0 Then
        sXlsFile = sPath & "CheckXlsResult.xls"
        If Obj.FileExists(sXlsFile) Then Obj.DeleteFile (sXlsFile)
        Set fs = Obj.CreateTextFile(sXlsFile, True)
        
        For i = 1 To 2
            'sSQL = "Select " & FLD(i) & " From CheckXls" & i & sTj & " Order By LineID" ''' ,ckFlag
            sSQL = Replace(arrSQL(i), "*", FLD(i)) & " Order by LineId"
            If rs.State = 1 Then rs.Close
            rs.Open sSQL, cn, 3, 1
            If rs.RecordCount = 0 Then
                iRc = 1
            Else
                iRc = rs.RecordCount
                If i = 1 Then
                    sMsg = " ckXlsResult1 = " & rs.RecordCount
                Else
                    sMsg = sMsg & ", ckXlsResult2 = " & rs.RecordCount
                End If
            End If
            
            pb.Value = 1
            pb.Max = iRc + 1
            pb.Min = 1
            
            If i = 2 Then
                fs.WriteLine "Total Xls2" & Chr(9) & rs.RecordCount
                fs.WriteLine Space(3)
            End If
            
            ''' colName !!!
            s = ""
            For j = 0 To rs.Fields.Count - 1
                s = s & IIf(IsNull(rs(j).Name), "", rs(j).Name) & Chr(9)
            Next
            fs.WriteLine s
            Do While Not rs.EOF
                s = ""
                For j = 0 To rs.Fields.Count - 1
                    s = s & IIf(IsNull(rs(j)), "", rs(j)) & Chr(9)
                Next
                DoEvents
                
                fs.WriteLine FixDblCharTo(s)
                
                lblAll = pb.Value & "/" & iRc
                pb.Value = pb.Value + 1
                lblbfb = Format(pb.Value / pb.Max * 100, "#,##0.00") & "%"
            
                rs.MoveNext
            Loop
            
            If i = 1 Then
                fs.WriteLine Space(3)
                fs.WriteLine "Total Xls1" & Chr(9) & rs.RecordCount
            End If
            
        Next
        fs.Close
        If sMsg <> "" Then
            If MsgBox(sMsg & ", Open it ?", vbQuestion + vbYesNo, QuesMsg) = vbYes Then
                Call OpenXls(sXlsFile)
            End If
        End If
        
    Else ''' Get two Result Xls
    
        For i = 1 To 2
                    
            sXlsFile = "CheckXlsResult"
            
            sXlsFile = sPath & sXlsFile & i & ".xls"
            
            If Obj.FileExists(sXlsFile) Then Obj.DeleteFile (sXlsFile)
        
            's = Year(Date) & Month(Date) & Day(Date) & Hour(Time) & Minute(Time) & Second(Time)
            s = "[Excel 8.0;database=" & sXlsFile & "].checkXls" & i
            
            'sSQL = "Select " & FLD(i) & " From CheckXls" & i & sTj & " Order By LineID"
            sSQL = Replace(arrSQL(i), "*", FLD(i)) & " Order by LineId"
            If rs.State = 1 Then rs.Close
            rs.Open sSQL, cn, 3, 1
            If rs.RecordCount = 0 Then
                'MsgBox "the " & i & " xls file is right (all haved checked) !", vbInformation, InfoMsg
            Else
                'sSQL = "Select " & FLD(i) & " Into " & s & " From CheckXls" & i & sTj & " Order By ckFlag,LineID"
                sSQL = Replace(arrSQL(i), "*", FLD(i) & " Into " & s) & " Order by LineId"
                cn.Execute (sSQL)
                If MsgBox("Export " & rs.RecordCount & " Record(s) Successfully! Do you want to open " & Chr(13) & Chr(13) & sXlsFile & "?", vbQuestion + vbYesNo + vbDefaultButton1, InfoMsg) = vbYes Then
                    OpenXls (sXlsFile)
                End If
            End If
        
        Next
    End If
    
    Set Obj = Nothing
    
    If rs.State = 1 Then rs.Close
    Set rs = Nothing
    
    If cn0.State = 1 Then cn0.Close
    Set cn0 = Nothing
    If cn.State = 1 Then cn.Close
    Set cn = Nothing
    
    Screen.MousePointer = vbDefault
    timExe.Enabled = False
    
    MsgBox "The task have finished.", vbInformation, InfoMsg
    
    sb.Panels(1).Text = "100% Finished"
    sb.Panels(2).Text = "Ok"
    Exit Sub
ErrMsg:
    sb.Panels(1).Text = "Task false"
    timExe.Enabled = False
    Screen.MousePointer = vbDefault
    'lstMsg.AddItem Err.Description
    MsgBox Err.Description, vbExclamation, InfoMsg
End Sub

Private Sub cmdOpen3_Click()
    dlg.ShowOpen
    txtf3.Text = dlg.FileName
    sExcelProg = txtf3.Text
End Sub

Private Sub cmdStart_Click()
    MsgBox lbl2.Caption, vbInformation, InfoMsg
    cmdStart.Enabled = False
    Call doImportCheckTwoXls(2)
    cmdStart.Enabled = True
End Sub

Private Sub cmdStart_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then PopupMenu mnuMenu
End Sub

Private Sub Command1_Click()
    If MsgBox("do you want to quit now ?", vbQuestion + vbYesNo, QuesMsg) = vbYes Then Unload Me
End Sub

Private Sub Form_Load()
    txtf1 = GetSetting(App.Title, "UserSetting", "ckFile1", "")
    txtf2 = GetSetting(App.Title, "UserSetting", "ckFile2", "")
    txtf3 = GetSetting(App.Title, "UserSetting", "ExcelFile", "")
    sExcelProg = txtf3
    sb.Panels(1).Text = "ID" & Int(Rnd(99999) * 100000)
    sb.Panels(2).Text = "Now is: " & Now
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then PopupMenu mnuMenu
End Sub

Private Sub Form_Unload(Cancel As Integer)
    SaveSetting App.Title, "UserSetting", "ckFile1", txtf1
    SaveSetting App.Title, "UserSetting", "ckFile2", txtf2
    SaveSetting App.Title, "UserSetting", "ExcelFile", txtf3
End Sub
Private Sub cnExecuteSQL(sSQL)
    On Error GoTo ErrMsg:
    cn.Execute (sSQL)
    Exit Sub
ErrMsg:
    MsgBox Err.Description, vbCritical, ErrMsg
End Sub

Private Sub Image1_Click()
    Call Image2_Click
End Sub

Private Sub Image2_Click()
    MsgBox "此版本不提供对 Excel 文件的比较, 因为相当而言 csv 获取数据更准确 !", vbInformation, InfoMsg
End Sub

Private Sub mnuckXls_Click()
    Call Image2_Click
End Sub

Private Sub timExe_Timer()
    Dim iMin As Integer
    iSec = iSec + 1
    iMin = Int(iSec / 60)
    lblsec = iMin & "'" & iSec - 60 * iMin & "''"
End Sub