excel.bas

教务处成绩统计系统

Attribute VB_Name = "modExcel"
Option Explicit

Public Sub CreateExcel(SavePath As String)
Dim MyDB As ADODB.Recordset
Dim MyConnect As ADODB.Connection  '定义数据库对象
Dim MyExcel As Excel.Application   '定义Excel对象
Dim MySheet As Worksheet

Set MyDB = New ADODB.Recordset
Set MyConnect = New ADODB.Connection   '创建数据库
Set MyExcel = New Excel.Application   '创建Excel

MyExcel.Application.Visible = False '隐藏Excel程序

MyConnect.CursorLocation = adUseClient
MyConnect.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
            App.Path & "\report.tmp" & ";Persist Security Info=False"  '连接数据库
MyDB.Open "select * from 成绩统计结果", MyConnect, adOpenStatic, _
                adLockOptimistic   '打开数据库

'---------------------------------------------------------------------------------

Dim i As Integer, j As Integer, col As String


MyExcel.Application.Workbooks.Add   '添加Excel工作簿
Set MySheet = MyExcel.Application.Workbooks(1).Sheets.Add

MyDB.MoveFirst   '移动记录到顶部
MyDB.MoveNext

With MySheet
'--------------画字段-----------------------------
.Cells(1, 1) = "请在此处输入表格标题"
For i = 1 To MyDB.Fields.Count   '从MyDB中头一个字段到最后一个
.Cells(2, i) = MyDB.Fields(i - 1).Name
.Cells(2, i).Borders.LineStyle = xlContinuous   '添加边框
'--------------------写入分数线-------------------------
If i >= 3 Then
Select Case (i Mod 3)
    Case 0
    .Cells(3, i) = CStr(ArrSubLines1(CInt(i / 3) - 1))
    Case 1
    .Cells(3, i) = CStr(ArrSubLines2(CInt((i - 1) / 3) - 1))
    Case 2
    .Cells(3, i) = CStr(ArrSubLines3(CInt((i - 2) / 3) - 1))
End Select
.Cells(3, i).Borders.LineStyle = xlContinuous
End If

'--------------------写入记录---------------------------

For j = 1 To MyDB.RecordCount

.Cells(j + 3, i) = MyDB.Fields(i - 1).Value
.Cells(j + 3, i).Borders.LineStyle = xlContinuous   '添加边框

If j <> MyDB.RecordCount - 1 Then
    MyDB.MoveNext
Else
    MyDB.MoveFirst
End If

Next j
Next i
End With
'--------------------合并单元格------------------------
Range("A2:A3").Select

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

End With

Selection.Merge
'-----------------------
Range("B2:B3").Select

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

End With

Selection.Merge
'----------------------
Range("A1", MySheet.Cells(1, MyDB.Fields.Count)).Select

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

End With

Selection.Merge
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

'------------------------全部居中------------------------
Range("A1", MySheet.Cells(MyDB.RecordCount + 3, MyDB.Fields.Count)).Select

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

End With
'------------------------添加边框--------------------------
MySheet.Range("B2:B3").Borders.LineStyle = xlContinuous
MySheet.Range("A1", MySheet.Cells(1, MyDB.Fields.Count)).Borders.LineStyle = xlContinuous

'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
MyExcel.Application.Workbooks(1).SaveAs SavePath   '保存工作簿


'------------------删除变量---------------------------------

Set MyDB = Nothing
Set MyConnect = Nothing

MyExcel.Application.Quit
Set MyExcel = Nothing

End Sub