excelcompare.frm

实现两个excel文件的比较

Refresh
Changing = 0
End Sub

Private Sub cmdOpen_Click(index As Integer)
Dim OFName As OPENFILENAME
Dim XLApp As Object
Dim Wrk As Object
Dim Sht As Object
OFName.lStructSize = Len(OFName)
'Set the parent window
OFName.hwndOwner = Me.hWnd
'Set the application's instance
OFName.hInstance = App.hInstance
'Select a filter
OFName.lpstrFilter = "Excel 文件 (*.xls)" + Chr$(0) + "*.xls" + Chr$(0) + "所有文件 (*.*)" + Chr$(0) + "*.*" + Chr$(0)
'create a buffer for the file
OFName.lpstrFile = Space$(254)
'set the maximum length of a returned file
OFName.nMaxFile = 255
'Create a buffer for the file title
OFName.lpstrFileTitle = Space$(254)
'Set the maximum length of a returned file title
OFName.nMaxFileTitle = 255
'Set the initial directory if we have one saved
If Len(InitDir$) > 0 Then
    OFName.lpstrInitialDir = InitDir$
End If
'Set the title
OFName.lpstrTitle = "打开 XLS 文件"
'No flags
OFName.flags = 0
'Show the 'Open File'-dialog
If GetOpenFileName(OFName) Then
    'get the filename and full path
    txtFile(index).Text = Trim$(OFName.lpstrFile)
    'get the filename only (no path)
    Text1(index).Text = Trim$(OFName.lpstrFileTitle)
    'extract the path from the full filename
    InitDir$ = Left$(txtFile(index).Text, Len(txtFile(index).Text) - Len(Text1(index).Text))
    'save our path for the next time
    SaveSetting App.EXEName, "Settings", "InitDir", InitDir$
    'clear the combo box for the sheet list
    cmbSheet(index).Clear
    'Create a new instance of Excel
    Set XLApp = CreateObject("Excel.Application")
    'Open the XLS file. The two parameters representes, UpdateLink = False and ReadOnly = True.
    'These parameters have this setting so they don't occur any error on broken links and allready opened XLS file.
    Set Wrk = XLApp.Workbooks.Open(txtFile(index).Text, False, True)
    'Read all worksheets in xls file
    For Each Sht In Wrk.Worksheets
        'Put the name of worksheet in combo
        cmbSheet(index).AddItem Sht.Name
    Next
    cmbSheet(index).ListIndex = 0
    DoEvents
    'Close the XLS file and dont save
    Wrk.Close False
    'Quit the MS Excel
    XLApp.Quit
    'Release variables
    Set XLApp = Nothing
    Set Wrk = Nothing
    Set Sht = Nothing
Else
    'MsgBox "Cancel was pressed"
End If
End Sub

Sub cmdLoad_Click(index As Integer)
On Error GoTo Oops
Dim c As Integer
Dim XLApp As New Excel.Application
Dim Wrk As Excel.Workbook
Dim Sht As Excel.Worksheet
Dim Rng As Excel.Range
Dim ArrayCells() As Variant
Screen.MousePointer = 11
If cmbSheet(index).ListIndex <> -1 Then
    'Create a new instance of Excel
    Set XLApp = CreateObject("Excel.Application")
    'Open the XLS file. The two parameters representes, UpdateLink = False and ReadOnly = True. These parameters have this setting to dont occur any error on broken links and allready opened XLS file.
    Set Wrk = XLApp.Workbooks.Open(txtFile(index).Text, False, True)
    'Set the SHT variable to selected worksheet
    Set Sht = Wrk.Worksheets(cmbSheet(index).List(cmbSheet(index).ListIndex))
    'Get the used range of current worksheet
    Set Rng = Sht.UsedRange
    'Change the dimensions of array to fit the used range of worksheet
    ReDim ArrayCells(1 To Rng.Rows.Count, 1 To Rng.Columns.Count)
    'Transfer values of the used range to new array
    If Option1.Value Then
        ArrayCells = Rng.Value
    ElseIf Option2.Value Then
        ArrayCells = Rng.Formula
    End If
    'Close worksheet
    Wrk.Close False
    'Quit the MS Excel
    XLApp.Quit
    'Release variables
    Set XLApp = Nothing
    Set Wrk = Nothing
    Set Sht = Nothing
    Set Rng = Nothing
    'Configure the flexgrid to display data
    With Grid1(index)
        'we set the redraw to false and make the grid invisible
        'this allows the data to be filled in much faster since the screen
        'does not have to redraw with each change in cell text
        .Redraw = False
        .Visible = False
        'empty the grid
        .Clear
        'set the grid to a few cells to start from scratch for each new file
        .Rows = 1
        .Cols = 1
        .FixedCols = 0
        .FixedRows = 0
        'set the number of rows to selected sheet's rows
        .Rows = UBound(ArrayCells, 1)
        'do the same for the columns
        .Cols = UBound(ArrayCells, 2)
        For r = 0 To UBound(ArrayCells, 1) - 1
            For c = 0 To UBound(ArrayCells, 2) - 1
                'set the text to the cell
                .TextMatrix(r, c) = CStr(ArrayCells(r + 1, c + 1))
            Next
        Next
        .Redraw = True
        .Visible = True
    End With
Else
    MsgBox "选择工作表!", vbCritical, "提示"
    cmbSheet(index).SetFocus
End If
GoTo Exit_cmdLoad_Click
Oops:
'Abort=3,Retry=4,Ignore=5
eTitle$ = App.Title & ": 错误在子程序 cmdLoad_Click "
EMess$ = "错误号 # " & Err.Number & " - " & Err.Description & vbCrLf
EMess$ = EMess$ & "Occurred in cmdLoad_Click"
EMess$ = EMess$ & IIf(Erl <> 0, vbCrLf & " 在行 " & CStr(Erl) & ".", ".")
mError = MsgBox(EMess$, vbAbortRetryIgnore, eTitle$)
If mError = vbRetry Then Resume
If mError = vbIgnore Then Resume Next
Exit_cmdLoad_Click:
Grid1(index).Redraw = True
Grid1(index).Visible = True
Refresh
DoEvents
Screen.MousePointer = 0
End Sub

Private Sub Form_Load()
Inits = 0
WindowState = vbMaximized
Show
InitDir$ = GetSetting(App.EXEName, "Settings", "InitDir", "")
cmdOpen_Click (0)
cmdOpen_Click (1)
Inits = 1
Compare
End Sub

Private Sub Form_Resize()
If WindowState = vbMinimized Then Exit Sub
For i = 0 To 1
    With Me.Grid1(i)
        'size the grids to be 1/2 of the form
        .Height = Me.Height - .Top - 550
        .Width = (Me.Width / 2) - 150
        txtFile(i).Width = (.Width - cmdOpen(i).Width) - 100
    End With
Next i
Grid1(0).Left = 50
Grid1(1).Left = Grid1(0).Left + Grid1(0).Width + 50
'size the other objects
For i = 0 To 1
    txtFile(i).Left = Grid1(i).Left
    cmdOpen(i).Left = txtFile(i).Left + txtFile(i).Width + 50
Next i
Text1(1).Left = Grid1(1).Left
Text1(1).Width = Text1(0).Width
cmbSheet(1).Left = Grid1(1).Left
End Sub

Private Sub Form_Unload(Cancel As Integer)
Unload frmResults
End Sub

Private Sub Grid1_MouseMove(index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
Dim CellData$
With Grid1(index)
    If .MouseRow >= .Rows Then Exit Sub
    If .MouseCol >= .Cols Then Exit Sub
    If .MouseRow < 1 Then Exit Sub
    If .MouseCol < 1 Then Exit Sub
    'setup the cell's text to display as the tooldtip for the grid
    CellData$ = .TextMatrix(.MouseRow, .MouseCol)
    .ToolTipText = CellData$
End With
End Sub

Private Sub Grid1_RowColChange(index As Integer)
If Inits = 0 Then Exit Sub
Caption = "行 " & Grid1(index).Row & " 列 " & Grid1(index).Col & " (" & Chr$(65 + Grid1(index).Col) & (Grid1(index).Row + 1) & ")"
End Sub

Private Sub Grid1_Scroll(index As Integer)
If Inits = 0 Then Exit Sub
'if the a grid scrolls, change the opposite one as well
Grid1(1 - index).Row = Grid1(index).Row
Grid1(1 - index).Col = Grid1(index).Col
Grid1(1 - index).TopRow = Grid1(index).TopRow
Grid1(1 - index).LeftCol = Grid1(index).LeftCol
End Sub

Private Sub Grid1_SelChange(index As Integer)
If Inits = 0 Then Exit Sub
'if the selection in a grid changes, change the opposite one as well
Grid1(1 - index).Row = Grid1(index).Row
Grid1(1 - index).Col = Grid1(index).Col
Grid1(1 - index).RowSel = Grid1(index).Row
Grid1(1 - index).ColSel = Grid1(index).Col
'display the contents of the selected cell in our textbox
Text1(0) = Grid1(0).Text
Text1(1) = Grid1(1).Text
Refresh
End Sub

Sub Compare()
On Error GoTo Oops
Dim CompDiff As Byte
Dim Comp$(2)
Screen.MousePointer = 11
Inits = 0
Grid1(0).Redraw = False
Grid1(1).Redraw = False
'reset both grids to default colors and fonts
For i = 0 To 1
    'select all of the cells in the grid control
    Grid1(i).Row = 0
    Grid1(i).Col = 0
    Grid1(i).RowSel = Grid1(i).Rows - 1
    Grid1(i).ColSel = Grid1(i).Cols - 1
    'set the fill style to repeat
    Grid1(i).FillStyle = flexFillRepeat
    'set the foreground color to black and background to white
    Grid1(i).CellForeColor = &H80000008
    Grid1(i).CellBackColor = &H80000005
    Grid1(i).CellFontBold = False
    'reset the fillstyle back to single
    Grid1(i).FillStyle = flexFillSingle
    'reset the selection back to one cell
    Grid1(i).Row = 1
    Grid1(i).Col = 1
    Grid1(i).RowSel = 1
    Grid1(i).ColSel = 1
Next i
Dim gRows(2) As Integer
Dim gCols(2) As Integer
gRows(0) = Grid1(0).Rows
gRows(1) = Grid1(1).Rows
gCols(0) = Grid1(0).Cols
gCols(1) = Grid1(1).Cols
'check if the rows and columns are the same in each spreadsheet.
'if they are different, give the user the option to continue or cancel.
If gRows(0) <> gRows(1) Then
    EMess$ = "左边电子表格有 " & gRows(0) & " 行."
    EMess$ = EMess$ & vbCrLf & "右边电子表格有 " & gRows(1) & " 行."
    EMess$ = EMess$ & vbCrLf & "请问是否进行比较?"
    lRet = MsgBox(EMess$, vbOKCancel + vbCritical, "电子表格大小差异!")
    If lRet = vbCancel Then GoTo Exit_Compare
    'set the rows to be the same in each spreadsheet
    If gRows(0) > gRows(1) Then
        Grid1(1).Rows = Grid1(0).Rows
    ElseIf gRows(1) > gRows(0) Then
        Grid1(0).Rows = Grid1(1).Rows
    End If
End If
If gCols(0) <> gCols(1) Then
    EMess$ = "左边电子表格有 " & gCols(0) & " 列."
    EMess$ = EMess$ & vbCrLf & "右边电子表格有 " & gCols(1) & " 列."
    EMess$ = EMess$ & vbCrLf & "请问是否进行比较?"
    lRet = MsgBox(EMess$, vbOKCancel + vbCritical, "电子表格大小差异!")
    If lRet = vbCancel Then GoTo Exit_Compare
    'set the cols to be the same in each spreadsheet
    If gCols(0) > gCols(1) Then
        Grid1(1).Cols = Grid1(0).Cols
    ElseIf gCols(1) > gCols(0) Then
        Grid1(0).Cols = Grid1(1).Cols
    End If
End If
For r = 0 To gRows(0) - 1
    For c = 0 To gCols(0) - 1
        'if we ignore case, set both text's to be upper case
        If chkCase.Value = vbChecked Then
            Comp$(0) = UCase(Grid1(0).TextMatrix(r, c))
            Comp$(1) = UCase(Grid1(1).TextMatrix(r, c))
        Else
            Comp$(0) = Grid1(0).TextMatrix(r, c)
            Comp$(1) = Grid1(1).TextMatrix(r, c)
        End If
        'compare the contents of the cells in the 2 grids
        If Comp$(0) <> Comp$(1) Then
            'we found a difference
            For i = 0 To 1
                'select the cell that's difference
                Grid1(i).Row = r
                Grid1(i).Col = c
                'set the color to white on red
                Grid1(i).CellForeColor = vbWhite
                Grid1(i).CellBackColor = vbRed
                'set the font to bold
                Grid1(i).CellFontBold = True
                'Grid1(i).TopRow = r
                'Grid1(i).LeftCol = c
                CompDiff = 1
            Next i
            'add the mismatched data to the results sheet
            frmResults.GridResults.AddItem r & vbTab & c & vbTab & Grid1(0).TextMatrix(r, c) & vbTab & Grid1(1).TextMatrix(r, c)
        End If
    Next c
Next r
If frmResults.GridResults.Rows = 1 Then
    'if we haven't added anything, unload the results form
    Unload frmResults
Else
    frmResults.Left = (Me.Width - frmResults.Width) / 2
    frmResults.Height = ((frmResults.GridResults.Rows + 2) * (frmResults.GridResults.RowHeight(1))) + 200
    frmResults.Top = (Me.Height - frmResults.Height) - 150
End If
'show a message representing the compare status
If CompDiff = 1 Then
    EMess$ = "Excel文件存在差异!"
    'MsgBox EMess$, vbCritical
    lblResults.ForeColor = vbWhite
    lblResults.BackColor = vbRed
Else
    EMess$ = "Excel文件是完全相同的!"
    lblResults.ForeColor = 0
    lblResults.BackColor = Me.BackColor
End If
lblResults.Caption = EMess$
GoTo Exit_Compare
Oops:
'Abort=3,Retry=4,Ignore=5
eTitle$ = App.Title & ": 错误在比较子程序 "
EMess$ = "错误号 # " & Err.Number & " - " & Err.Description & vbCrLf
EMess$ = EMess$ & "错误发生在比较时"
EMess$ = EMess$ & IIf(Erl <> 0, vbCrLf & " 在行 " & CStr(Erl) & ".", ".")
mError = MsgBox(EMess$, vbAbortRetryIgnore, eTitle$)
If mError = vbRetry Then Resume
If mError = vbIgnore Then Resume Next
Exit_Compare:
Grid1(0).Redraw = True
Grid1(1).Redraw = True
Inits = 1
Screen.MousePointer = 0
End Sub