Option Compare Database
Option Explicit
Public MyXL As Object
Sub GetExcel()
'使用这段代码，可以打开一个Excel实例或者引用已经打开的Excel实例
Const ERR_APP_NOTRUNNING As Long = 429
On Error Resume Next
Set MyXL = GetObject("Excel.Application")
If Err = ERR_APP_NOTRUNNING Then
Set MyXL = New Excel.Application
End If
MyXL.Application.Visible = True
End Sub
Public Sub CreateNewBook()
'新建一个工作簿
MyXL.Application.WorkBooks.Add
End Sub
Public Sub CopyToClip(FormName As String, SubFormName As String)
'使用代码将窗体上的数据复制到Windows粘贴板
Forms(FormName).Controls(SubFormName).SetFocus
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
End Sub
Public Sub CopyToExcel()
'使用代码将Windows粘贴板的内容粘贴到Excel
GetExcel
MyXL.Application.WorkBooks.Add
MyXL.Application.ActiveSheet.Paste
End Sub
Public Sub FormatTAB()
'对导出到Excel中的数据进行格式化，比如，加上报表标题、设置表格线等。
Dim J As Integer
SetLine '设置表格线的子程序，在Access中实现对Excel文档格式化
MyXL.Application.ActiveSheet.Rows("1:1").Select
'插入两行作为标题行
For J = 1 To 2
MyXL.Application.Selection.Insert Shift:=xlDown
Next J
MyXL.Application.ActiveSheet.Range("A1") = "标题文字"
'设置表标题字体
MyXL.Worksheets(1).Range("A1").Select
With MyXL.Application.Selection.Font
.Name = "宋体"
.Size = 16
End With
End Sub
Public Sub SetLine()
'设置表格线
On Error Resume Next
MyXL.Application.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
MyXL.Application.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
MyXL.Application.Selection.WrapText = False
With MyXL.Application.Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With MyXL.Application.Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With MyXL.Application.Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With MyXL.Application.Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With MyXL.Application.Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With MyXL.Application.Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
End Sub
Public Sub CloseExcel()
'关闭打开的工作簿
'关闭Excel
On Error Resume Next
MyXL.Application.DisplayAlerts = False
MyXL.Application.Save
MyXL.Application.quit
Set MyXL = Nothing '释放对该应用程序
End Sub
