Rem 导出电子表格excel的自定义过程
'接收参数：查询字符串，电子表格名
Public Sub ghexcel(stropen As String, cexcelname As String)
On Error GoTo gherr
If Len(stropen) = 0 Or Len(cexcelname) = 0 Then
MsgBox ("没有可导出数据信息或没有指定文件名，导出操作已取消")
Exit Sub
End If
Dim icol As Integer '列数，用于保存字段个数
Dim rstable As New ADODB.Recordset
Dim ijlts As Long '记录条数
Dim AppExcel As Excel.Application '定义尚未创建
Dim BookExcel As Excel.Workbook '工作簿对象
Dim sheetexcel As Excel.Worksheet '工作表
If Not mainmoudle.getlink Then
Exit Sub
End If
With rstable '记录集对象
If .State = adStateOpen Then
.Close '如果记录集处于打开状态，则先关闭它
End If
.ActiveConnection = conn '连接
.CursorLocation = adUseClient '本地游标
.CursorType = adOpenStatic '静态游标
.LockType = adLockReadOnly '只读
.Source = stropen '通过参数传过来的字符串
.Open
End With
With rstable
If .RecordCount < 1 Then
MsgBox ("没有记录,导出操作已被取消！")
Exit Sub
End If
'记录总数
'Irowcount = .RecordCount
'字段总数
icol = .Fields.Count '求出字段数
ijlts = .RecordCount
End With
' Set AppExcel = CreateObject("Excel.Application") '这句起何作用？
If Dir$(cexcelname) = "" Then
Set AppExcel = New Excel.Application '创建excel对象
AppExcel.Visible = False '什么用处？
Set BookExcel = AppExcel.Workbooks.Add '添加工作表
Set sheetexcel = BookExcel.Worksheets("sheet1")
' AppExcel.Worksheets(1).Name = "工作表一" '在Text1中输入表名
For icol = 0 To rstable.Fields.Count - 1
AppExcel.Worksheets(1).Cells(1, icol + 1).Value = rstable.Fields(icol).Name
Next
AppExcel.Worksheets(1).Range("A2").CopyFromRecordset rstable
With sheetexcel
.Range(.Cells(1, 1), .Cells(1, 5)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, 5)).Font.Bold = False '不加粗
'标题字体加粗
.Range(.Cells(1, 1), .Cells(ijlts + 1, icol)).Borders.LineStyle = xlContinuous '如果第一行不显示字段，则不用加一
'设表格边框样式
End With
'以下一句用法是正确的
'sheetexcel.Range(sheetexcel.Cells(3, 1), sheetexcel.Cells(3.3)).Font.Size = 120
BookExcel.SaveAs (cexcelname)
Else
MsgBox ("该文件名已经存在，不能导出，否则将覆盖,请给出新的名称")
Exit Sub
' Set BookExcel = AppExcel.Workbooks.Open(ExcelFileName)
' AppExcel.Worksheets(1).Name = "zgh2 table" '在Text1中输入表名
' AppExcel.Worksheets(1).Range("A70").CopyFromRecordset rsTable
' BookExcel.SaveAs (ExcelFileName)
End If
AppExcel.Quit '这一句起何作用？
Set sheetexcel = Nothing
Set BookExcel = Nothing
Set AppExcel = Nothing
rstable.Close
Set rstable = Nothing
MsgBox "电子表格导出操作顺利完成！"
Exit Sub
gherr:
MsgBox Err.Number & "," & Err.Description
End Sub
2008-11-25 16:09
