Sub ExcelFull(OFile As String) '导出为EXCEL
Dim i As Long
Dim J As Long
Dim XlApp As Object
Dim XlBook As Object
Dim XlSheet As Object
Dim TmpStr As String
Dim RowMax As Long
Dim ColMax As Long
On Error Resume Next
Set XlApp = CreateObject("Excel.Application")
If XlApp Is Nothing Then
MsgBox "系统没有安装Excel!", vbOKOnly + 16, "成绩统计"
Exit Sub
End If
Screen.MousePointer = 11
XlApp.Visible = False
RowMax = MainFrm.MainGrid.Rows
ColMax = MainFrm.MainGrid.Cols
FullBar.Max = MaxVal + 1
FullBar.Value = 0
NewVal = 0: OleVal = 0
FullBar.Visible = True
DoEvents
With XlApp
Set XlBook = XlApp.Workbooks.Add
Set XlSheet = XlBook.Worksheets(1)
.Sheets(1).Name = "成绩表"
For i = 5 To RowMax - 1
For J = 1 To ColMax - 1
TmpStr = MainFrm.MainGrid.TextMatrix(i, J)
If i = 5 Then
If J > 4 And J < ColMax - 3 And J Mod 2 = 0 Then TmpStr = "名次"
End If
XlSheet.Cells(i - 4, J) = TmpStr
Next J
NewVal = i * MaxVal \ RowMax
If OleVal <> NewVal Then
FullBar.Value = NewVal
OleVal = NewVal
End If
Next i
FullBar.Value = FullBar.Max
XlBook.SaveAs OFile
XlBook.FileClose
XlBook.Close SaveChanges:=False
.quit
Set XlSheet = Nothing
Set XlBook = Nothing
Set XlApp = Nothing
Screen.MousePointer = 0
End With
End Sub
2.最快速的导出方法,可以不安装EXCEL.
Sub RtfTextFull(FileName As String)
Dim MaxRows As Long
Dim MaxCols As Long
Dim StarRow As Long
Dim ConTents As String
Dim LoopI As Long
Dim EndRow As Long
Dim TmpStr As String
Dim Tmp As String
Dim a As Long
Dim FileID As Long
With MainFrm.MainGrid
FileID = FreeFile()
MaxRows = .Rows - 1: MaxCols = .Cols - 1
FullBar.Max = MaxVal + 1
FullBar.Value = 0: FullBar.Visible = True
NewVal = 0: OleVal = 0
FullBar.Visible = True
DoEvents
TmpStr = .TextMatrix(5, 0)
For a = 1 To MaxCols
Tmp = .TextMatrix(5, a)
If a > 4 And a < MaxCols - 2 And a Mod 2 = 0 Then Tmp = "名次"
TmpStr = TmpStr & vbTab & Tmp
Next a
'---------------------------------------------------------
Open FileName For Output As #FileID
Print #FileID, TmpStr
For a = 6 To MaxRows
.Row = a: .Col = 0
.RowSel = a: .ColSel = MaxCols
ConTents = .Clip
Print #FileID, ConTents
NewVal = a * MaxVal \ MaxRows
If OleVal <> NewVal Then
FullBar.Value = NewVal
OleVal = NewVal
End If
Next a
Close #FileID
.Row = 6: .Col = 1
End With
End Sub