调用EXCEL做报表？
来源：百度文库 编辑：神马文学网 时间：2024/04/30 19:26:31
谁知道怎么调用EXCEL做报表？
‘引用excel9.0 Dim tempxlApp As New Excel.Application Dim tempxlWorkbook As New Excel.Workbook Dim tempxlSheet As New Excel.Worksheet Dim tempRange As String Dim strRangeValue As String ‘打开自己作好的报表模板templet.xlt Set tempxlWorkbook = tempxlApp.Workbooks.Open(App.Path & "\templet.xlt") tempxlApp.Visible = True tempxlApp.DisplayAlerts = False tempxlWorkbook.SaveAs "report.xls" Set tempxlSheet = tempxlWorkbook.Worksheets("sheet1") tempxlSheet.Select ‘单个单元格写入数据 tempxlSheet.Range("A1").Value = "test" ‘一次性写入tempRs数据记录集中的数据 tempxlSheet.Range("A1").CopyFromRecordset tempRS ‘保存 tempxlApp.save ‘释放对象 Set tempxlSheet = Nothing Set tempxlWorkbook = Nothing ‘关闭excel tempxlApp.Quit ‘千万别忘记写下面这一句，否则excel进程不会关闭 Set tempxlApp = Nothing Top 回复人： y97523szb() ( ) 信誉：100 2002-04-26 05:30:50Z 得分:10 icy_csdn() 的程序差不多 不过用前首先在自己的程序的引用中将Excel（office)的对象引用 关于Excel对象的资料你可以在Excel的帮助中找到（打开Excel，从宏菜单中启动VBA编辑器，那是一个office中的VB,F1就可以调出帮助） 主要就是几个对象： Application Workbook Worksheet 别忘了给分：）Top 回复人： cgh1970(聊天别找我) ( ) 信誉：100 2002-04-26 06:19:31Z 得分:20
‘指定链接 Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long ‘Option Explicit Dim x(1 To 4, 1 To 5) As Integer Dim a, i, j As Integer Dim b As String Private Sub Command1_Click() Dim ex As Object Dim exbook As Object Dim exsheet As Object Set ex = CreateObject("Excel.Application") Set exbook = ex.Workbooks().Add Set exsheet = exbook.Worksheets("sheet1") ‘按控件的内容赋值 ‘11 exsheet.Cells(1, 1).Value = Text1.Text ‘为同行的几个格赋值 Range("C3").Select ActiveCell.FormulaR1C1 = "表格" ‘ ex.Range("c3").Value = "表 格" ex.Range("d3").Value = " 春 天 " ex.Range("e3").Value = " 夏 天 " ex.Range("f3").Value = " 秋 天 " ex.Range("g3").Value = " 冬 天 " ‘大片赋值 ex.Range("c4:g7").Value = x ‘按变量赋值 a = 8 b = "c" & Trim(Str(a)) ex.Range(b).Value = "下雪" ‘另外一种大片赋值 For i = 9 To 12 For j = 4 To 7 exsheet.Cells(i, j).Value = i * j Next j Next i ‘计算赋值 exsheet.Cells(13, 1).Formula = "=R9C4 + R9C5" ‘设置字体 Dim exRange As Object Set exRange = exsheet.Cells(13, 1) exRange.Font.Bold = True ‘设置一行为18号字体加黑 Rows("3:3").Select Selection.Font.Bold = True With Selection.Font .Name = "宋体" .Size = 18 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With ‘设置斜体 Range("E2").Select Selection.Font.Italic = True ‘设置下划线 Range("E3").Select Selection.Font.Underline = xlUnderlineStyleSingle ‘设置列宽为15 Selection.ColumnWidth = 15 ‘设置一片数据居中 Range("C4:G7").Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .ShrinkToFit = False .MergeCells = False End With ‘设置某区域的小数位数 Range("F4:F7").Select Selection.NumberFormatLocal = "0.00" ‘求和 Range("G9:G13").Select Range("G13").Activate ActiveCell.FormulaR1C1 = "=SUM(R[-4]C:R[-1]C)" ‘某列自动缩放宽度 Columns("C:C").EntireColumn.AutoFit ‘画表格 Range("C4:G7").Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With ‘加黑框 Range("C9:G13").Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With Selection.Borders(xlInsideVertical).LineStyle = xlNone Selection.Borders(xlInsideHorizontal).LineStyle = xlNone ‘设置某单元格格式为文本 Range("E11").Select Selection.NumberFormatLocal = "@" ‘设置单元格格式为数值 Range("F10").Select Selection.NumberFormatLocal = "0.000_);(0.000)" ‘设置单元格格式为时间 Range("F11").Select Selection.NumberFormatLocal = "h:mm AM/PM" ‘取消选择 Range("C10").Select ‘设置横向打印，A4纸张 ‘ With ActiveSheet.PageSetup ‘ .PrintTitleRows = "" ‘ .PrintTitleColumns = "" ‘ End With ‘ ActiveSheet.PageSetup.PrintArea = "" With ActiveSheet.PageSetup ‘ .LeftHeader = "" ‘ .CenterHeader = "" ‘ .RightHeader = "" ‘ .LeftFooter = "" ‘ .CenterFooter = "" ‘ .RightFooter = "" ‘ .LeftMargin = Application.InchesToPoints(0.75) ‘ .RightMargin = Application.InchesToPoints(0.75) ‘ .TopMargin = Application.InchesToPoints(1) ‘ .BottomMargin = Application.InchesToPoints(1) ‘ .HeaderMargin = Application.InchesToPoints(0.5) ‘ .FooterMargin = Application.InchesToPoints(0.5) ‘ .PrintHeadings = False ‘ .PrintGridlines = False ‘ .PrintComments = xlPrintNoComments ‘ .PrintQuality = 300 ‘ .CenterHorizontally = False ‘ .CenterVertically = False .Orientation = xlLandscape ‘ .Draft = False .PaperSize = xlPaperA4 ‘ .FirstPageNumber = xlAutomatic ‘ .Order = xlDownThenOver ‘ .BlackAndWhite = False ‘ .Zoom = 100 End With ‘跨列居中 Range("A1:G1").Select With Selection .HorizontalAlignment = xlCenter ‘ .VerticalAlignment = xlBottom ‘ .WrapText = False ‘ .Orientation = 0 ‘ .AddIndent = False ‘ .ShrinkToFit = False .MergeCells = True End With Selection.Merge ‘打印表格 ActiveWindow.SelectedSheets.PrintOut Copies:=1 ‘取值 Text1.Text = exsheet.Cells(13, 1) ‘保存 ChDir "C:\WINDOWS\Desktop" ActiveWorkbook.SaveAs FileName:="C:\WINDOWS\Desktop\aaa.xls", FileFormat:=xlNormal, Password:="123", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False ‘ 关闭工作表。 exbook.Close ‘用 Quit 方法关闭 Microsoft Excel ex.Quit ‘释放对象 Set ex = Nothing Set exbook = Nothing Set exsheet = Nothing Dim retval ‘用excel打开表格 retval = Shell("C:\Program Files\Microsoft Office\Office\EXCEL.EXE" & " " & "C:\WINDOWS\Desktop\aaa.xls", 1) End Sub Private Sub Form_Load() Me.Show End Sub Private Sub Image2_Click() ‘打开主页 ret& = ShellExecute(Me.hwnd, "Open", "http://dyqing.533.net", "", App.Path, 1) End Sub Private Sub Image1_Click() ‘发送邮件 ret& = ShellExecute(Me.hwnd, "Open", "mailto:duyunqing@163.net", "", App.Path, 1) End Sub Top 回复人： dbcontrols(泰山__抛砖引玉) ( ) 信誉：被封杀 2002-04-26 06:47:17Z 得分:10 cgh1970() :复制我的代码就算了，怎么连我的邮箱也列出来啊？ :PTop 回复人： setfocus(斗是懂一点) ( ) 信誉：100 2002-04-26 08:30:33Z 得分:10
哈哈哈！搞笑呀！搜索一下帖子吧！原来有很多！Top 回复人： _1_(到jinesc.6600.org来找我) ( ) 信誉：100 2002-04-26 08:35:29Z 得分:20
我也来贴一个， 不太复杂的 ， 就是非常的长 属于好玩 ，你看看吧~~~ Form_Wait.Maxid = Detail.Rows + 20 Form_Wait.aa = 0 Dim r As New ADODB.Recordset Dim SQL As String ‘用输出到excel的方法打印 Dim Ex As New Excel.Application Dim ExW As Excel.Workbook Dim Exs As Excel.Worksheet Dim i As Integer Dim t As Integer Dim n As Integer Dim tempSt As String Dim totamount As Double Dim totqty As Double t = 1 On Error Resume Next Kill App.Path & "\intemp.xls" FileCopy App.Path & "\xls.dll", App.Path & "\intemp.xls" On Error GoTo 0 Set Ex = CreateObject("Excel.Application") Set ExW = Ex.Workbooks.Open(App.Path & "\intemp.xls") Set Exs = ExW.Worksheets("sheet1") Form_Wait.aa = 5 ‘表头 ‘公司名称 Exs.Cells(1, 2).Font.Name = "Times New Roman" Exs.Cells(1, 2).Font.Size = 14 Exs.Cells(1, 2).Font.Bold = True Exs.Cells(1, 2) = tt1 ‘公司地址 Exs.Cells(2, 2).Font.Name = "Times New Roman" Exs.Cells(2, 2).Font.Size = 9 Exs.Cells(2, 2).Font.Italic = True Exs.Cells(2, 2) = tt2 ‘公司电话 Exs.Cells(3, 2).Font.Name = "Times New Roman" Exs.Cells(3, 2).Font.Size = 8 Exs.Cells(3, 2).Font.Italic = True Exs.Cells(3, 2) = tt3 Exs.Range("a1:a3").MergeCells = True ‘公司标记 Exs.Cells(1, 1).Font.Name = "Braggadocio" Exs.Cells(1, 1).Font.Size = 28 Exs.Cells(1, 1).Font.Italic = True Exs.Cells(1, 1) = "JINESC" Exs.Columns("A:A").ColumnWidth = 17.13 Exs.Columns("B:B").ColumnWidth = 25.25 Exs.Columns("C:C").ColumnWidth = 11.63 Exs.Columns("D:D").ColumnWidth = 12 Exs.Columns("E:E").ColumnWidth = 11.63 With Exs ‘行高和画2根线 .Rows("1:1").RowHeight = 16.25 .Rows("2:2").RowHeight = 12.25 .Rows("3:3").RowHeight = 12.25 .Shapes.AddLine(6#, 47.25, 479.25, 47.25).Line.Weight = 2.25 .Shapes.AddLine(6#, 50.25, 479.25, 50.25).Line.Weight = 1 Form_Wait.aa = 10 ‘表头公司名称制作完毕 ‘下面开始做发票资料 ‘客户资料 .Cells(5, 1).Font.Name = "Times New Roman" .Cells(5, 1).Font.Size = 10 .Cells(5, 1).Font.Italic = True .Cells(5, 1) = "TO:" & TXTKHMC .Range("a5:b5").MergeCells = True .Range("a6:b6").MergeCells = True .Cells(6, 1) = Text4 ‘发票号 .Cells(5, 3).Font.Name = "Times New Roman" .Cells(5, 3).Font.Size = 10 .Cells(5, 3).Font.Italic = True .Cells(5, 3) = "Invoice No:" .Cells(5, 4) = TXTINVOICE ‘日期 .Cells(6, 3).Font.Name = "Times New Roman" .Cells(6, 3).Font.Size = 10 .Cells(6, 3).Font.Italic = True .Cells(6, 3) = "Date:" .Cells(6, 4) = Format(Rq, "MMM,dd,yyyy") ‘合同浩 .Cells(7, 3).Font.Name = "Times New Roman" .Cells(7, 3).Font.Size = 10 .Cells(7, 3).Font.Italic = True .Cells(7, 3) = "Contract No:" .Cells(8, 4) = Text5 .Range("d7:e8").MergeCells = True ‘定单浩 .Cells(7, 1).Font.Name = "Times New Roman" .Cells(7, 1).Font.Size = 10 .Cells(7, 1).Font.Italic = True .Cells(7, 1) = "Order No:" & Text1 .Cells(7, 1).VerticalAlignment = xlTop .Range("a7:b11").MergeCells = True ‘麦头 .Cells(9, 3).Font.Name = "Times New Roman" .Cells(9, 3).Font.Size = 10 .Cells(9, 3).Font.Italic = True .Cells(9, 3) = "Marks:" .Cells(9, 4) = Text2 .Range("d9:e11").MergeCells = True ‘INVOICE大字 .Cells(12, 1).Font.Name = "Times New Roman" .Cells(12, 1).Font.Size = 28 .Cells(12, 1).Font.Italic = True .Cells(12, 1).HorizontalAlignment = xlCenter .Cells(12, 1) = "Invoice" .Range("a12:E12").MergeCells = True ‘表格头 .Cells(12, 1).Borders(xlEdgeBottom).LineStyle = xlContinuous .Cells(12, 1).Borders(xlEdgeBottom).Weight = xlMedium .Cells(12, 2).Borders(xlEdgeBottom).LineStyle = xlContinuous .Cells(12, 2).Borders(xlEdgeBottom).Weight = xlMedium .Cells(12, 3).Borders(xlEdgeBottom).LineStyle = xlContinuous .Cells(12, 3).Borders(xlEdgeBottom).Weight = xlMedium .Cells(12, 4).Borders(xlEdgeBottom).LineStyle = xlContinuous .Cells(12, 4).Borders(xlEdgeBottom).Weight = xlMedium .Cells(12, 5).Borders(xlEdgeBottom).LineStyle = xlContinuous .Cells(12, 5).Borders(xlEdgeBottom).Weight = xlMedium ‘表格割线 .Cells(14, 1).Borders(xlEdgeBottom).LineStyle = xlContinuous .Cells(14, 1).Borders(xlEdgeBottom).Weight = xlThin .Cells(14, 2).Borders(xlEdgeBottom).LineStyle = xlContinuous .Cells(14, 2).Borders(xlEdgeBottom).Weight = xlThin .Cells(14, 3).Borders(xlEdgeBottom).LineStyle = xlContinuous .Cells(14, 3).Borders(xlEdgeBottom).Weight = xlThin .Cells(14, 4).Borders(xlEdgeBottom).LineStyle = xlContinuous .Cells(14, 4).Borders(xlEdgeBottom).Weight = xlThin .Cells(14, 5).Borders(xlEdgeBottom).LineStyle = xlContinuous .Cells(14, 5).Borders(xlEdgeBottom).Weight = xlThin Form_Wait.aa = 15 Top 回复人： _1_(到jinesc.6600.org来找我) ( ) 信誉：100 2002-04-26 08:36:01Z 得分:0 ‘明细内容的表头 ‘Description Of Goods .Cells(13, 1).Font.Name = "Times New Roman" .Cells(13, 1).Font.Size = 11 .Cells(13, 1).Font.Bold = True .Cells(13, 1).HorizontalAlignment = xlCenter .Cells(13, 1) = "Description Of Goods" ‘TYPE .Cells(13, 2).Font.Name = "Times New Roman" .Cells(13, 2).Font.Size = 11 .Cells(13, 2).Font.Bold = True .Cells(13, 2).HorizontalAlignment = xlCenter .Cells(13, 2) = "Type" ‘Quantity .Cells(13, 3).Font.Name = "Times New Roman" .Cells(13, 3).Font.Size = 11 .Cells(13, 3).Font.Bold = True .Cells(13, 3).HorizontalAlignment = xlCenter .Cells(13, 3) = "Quantity" ‘PCS .Cells(14, 3).Font.Name = "Times New Roman" .Cells(14, 3).Font.Size = 11 .Cells(14, 3).Font.Bold = True .Cells(14, 3).HorizontalAlignment = xlCenter .Cells(14, 3) = "(PCS)" ‘Unit Price .Cells(13, 4).Font.Name = "Times New Roman" .Cells(13, 4).Font.Bold = True .Cells(13, 4).Font.Size = 11 .Cells(13, 4).HorizontalAlignment = xlCenter .Cells(13, 4) = "Unit Price" ‘Amount .Cells(13, 5).Font.Name = "Times New Roman" .Cells(13, 5).Font.Size = 11 .Cells(13, 5).Font.Bold = True .Cells(13, 5).HorizontalAlignment = xlCenter .Cells(13, 5) = "Amount" ‘Unit Price 货币 .Cells(14, 4).Font.Name = "Times New Roman" .Cells(14, 4).Font.Bold = True .Cells(14, 4).Font.Size = 11 .Cells(14, 4).HorizontalAlignment = xlCenter .Cells(14, 4) = "(" & TXTHB & ")" ‘Amount 货币 .Cells(14, 5).Font.Name = "Times New Roman" .Cells(14, 5).Font.Size = 11 .Cells(14, 5).Font.Bold = True .Cells(14, 5).HorizontalAlignment = xlCenter .Cells(14, 5) = "(" & TXTHB & ")" End With Form_Wait.aa = 20 ‘以下假如显示内容 主要是 商品名称 规格 数量 单价 金额 单位 Dim stt1 As String Dim stt2 As String Dim stt3 As String Dim stt4 As String With Detail For i = 1 To .Rows - 1 Form_Wait.aa = 20 + i .row = i .col = 3 If Not Trim(.Text) = "" Then .col = 5 If IsNumeric(.Text) Then totqty = totqty + CDbl(.Text) .col = 7 If IsNumeric(.Text) Then totamount = totamount + CDbl(.Text) ‘商品名称 .col = 1 If stt1 <> Trim(.Text) Then Exs.Cells(t + 14, 1).Font.Name = "Times New Roman" Exs.Cells(t + 14, 1).Font.Size = 9 Exs.Cells(t + 14, 1).HorizontalAlignment = xlLeft Exs.Cells(t + 14, 1) = .Text stt1 = Trim(.Text) t = t + 1 End If .col = 8 If stt2 <> Trim(.Text) Then Exs.Cells(t + 14, 1).Font.Name = "Times New Roman" Exs.Cells(t + 14, 1).Font.Size = 9 Exs.Cells(t + 14, 1).HorizontalAlignment = xlLeft Exs.Cells(t + 14, 1) = .Text stt2 = Trim(.Text) End If .col = 3 ‘规格 Exs.Cells(t + 14, 2).Font.Name = "Times New Roman" Exs.Cells(t + 14, 2).Font.Size = 9 Exs.Cells(t + 14, 2).HorizontalAlignment = xlLeft Exs.Cells(t + 14, 2) = .Text ‘数量 .col = 5 Exs.Cells(t + 14, 3).Font.Name = "Times New Roman" Exs.Cells(t + 14, 3).Font.Size = 9 Exs.Cells(t + 14, 3).HorizontalAlignment = xlRight Exs.Cells(t + 14, 3) = .Text .col = 6 Exs.Cells(t + 14, 4).Font.Name = "Times New Roman" Exs.Cells(t + 14, 4).Font.Size = 9 Exs.Cells(t + 14, 4).HorizontalAlignment = xlRight Exs.Cells(t + 14, 4) = .Text ‘金额 .col = 7 Exs.Cells(t + 14, 5).Font.Name = "Times New Roman" Exs.Cells(t + 14, 5).Font.Size = 9 Exs.Cells(t + 14, 5).HorizontalAlignment = xlRight Exs.Cells(t + 14, 5) = .Text t = t + 1 End If Next ‘明细内容结束 画结尾表格线 Exs.Cells(13 + t, 1).Borders(xlEdgeBottom).LineStyle = xlContinuous Exs.Cells(13 + t, 1).Borders(xlEdgeBottom).Weight = xlThin Exs.Cells(13 + t, 2).Borders(xlEdgeBottom).LineStyle = xlContinuous Exs.Cells(13 + t, 2).Borders(xlEdgeBottom).Weight = xlThin Exs.Cells(13 + t, 3).Borders(xlEdgeBottom).LineStyle = xlContinuous Exs.Cells(13 + t, 3).Borders(xlEdgeBottom).Weight = xlThin Exs.Cells(13 + t, 4).Borders(xlEdgeBottom).LineStyle = xlContinuous Exs.Cells(13 + t, 4).Borders(xlEdgeBottom).Weight = xlThin Exs.Cells(13 + t, 5).Borders(xlEdgeBottom).LineStyle = xlContinuous Exs.Cells(13 + t, 5).Borders(xlEdgeBottom).Weight = xlThin End With With Exs ‘汇总数量和金额 .Cells(14 + t, 1).Font.Name = "Times New Roman" .Cells(14 + t, 1).Font.Size = 11 .Cells(14 + t, 1).Font.Bold = True .Cells(14 + t, 1) = "Total Quantity:" & totqty & "pcs Total Amount:(" & Me.TXTHB & ")" & totamount & " " & Me.TXTJG & " " & Me.TXTGK ‘备注 .Cells(16 + t, 1).Font.Name = "Times New Roman" .Cells(16 + t, 1).Font.Size = 11 .Cells(16 + t, 1).Font.Bold = True .Rows(16 + t).WrapText = True .Cells(16 + t, 1) = Text3 & vbCrLf & "We hereby certify that the above mentioned goods ase of chinese origin " .Range("a" & 14 + t & ":E" & 14 + t).MergeCells = True .Range("a" & 16 + t & ":E" & 16 + t).MergeCells = True End With Exs.Application.Visible = True End Sub 看楼上发那么多的代码 我也发个长代码来看看 Top 用VB控制EXCEL生成报表 做为一种简捷、系统的 Windows应用程序开发工具，Visual Basic 5 具有强大的数据处理功能，提供了多种数据访问方法，可以方便地存取
Microsoft SQL Server、Oracle、XBase等多种数据库，被广泛应用于建立各种信息管理系统。但是，VB缺乏足够的、符合中文习惯的数据表格输出功能，
虽然使用Crystal Report控件及 Crystal Reports程序可以输出报表，但操作起来很麻烦，中文处理能力也不理想。Excel作为Micorsoft公司的表格处
理软件在表格方面有着强大的功能，我们可用VB5编写直接控制Excel操作的程序,方法是用VB的OLE自动化技术获取Excel 97 的控制句柄,从而直接控制
Excel 97的一系列操作。 下面给出一个实例： 首先建立一个窗体（FORM1）在窗体中加入一个DATA控件和一按钮， 引用Microsoft Excel类型库: 从"工程"菜单中选择"引用"栏; 选择Microsoft Excel 8.0 Object Library; 选择"确定"。 在FORM的LOAD事件中加入： Data1.DatabaseName = 数据库名称 Data1.RecordSource = 表名 Data1.Refresh 在按钮的CLICK事件中加入 Dim Irow, Icol As Integer Dim Irowcount, Icolcount As Integer Dim Fieldlen() "存字段长度值 Dim xlApp As Excel.Application Dim xlBook As Excel.Workbook Dim xlSheet As Excel.Worksheet Set xlApp = CreateObject("Excel.Application") Set xlBook = xlApp.Workbooks.Add Set xlSheet = xlBook.Worksheets(1) With Data1.Recordset .MoveLast If .RecordCount < 1 Then MsgBox ("Error 没有记录!") Exit Sub End If Irowcount = .RecordCount "记录总数 Icolcount = .Fields.Count "字段总数 ReDim Fieldlen(Icolcount) .MoveFirst 8 For Irow = 1 To Irowcount + 1 For Icol = 1 To Icolcount Select Case Irow Case 1 "在Excel中的第一行加标题 xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1).Name Case 2 "将数组FIELDLEN()存为第一条记录的字段长 If IsNull(.Fields(Icol - 1)) = True Then Fieldlen(Icol) = LenB(.Fields(Icol - 1).Name) "如果字段值为NULL,则将数组Filelen(Icol)的值设为标题名的宽度 Else Fieldlen(Icol) = LenB(.Fields(Icol - 1)) End If xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol) "Excel列宽等于字段长 xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1) "向Excel的CellS中写入字段值 Case Else Fieldlen1 = LenB(.Fields(Icol - 1)) If Fieldlen(Icol) < Fieldlen1 Then xlSheet.Columns(Icol).ColumnWidth = Fieldlen1 "表格列宽等于较长字段长 Fieldlen(Icol) = Fieldlen1 "数组Fieldlen(Icol)中存放最大字段长度值 Else xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol) End If xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1) End Select Next If Irow <> 1 Then If Not .EOF Then .MoveNext End If Next With xlSheet .Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Name = "黑体" "设标题为黑体字 .Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Bold = True "标题字体加粗 .Range(.Cells(1, 1), .Cells(Irow, Icol - 1)).Borders.LineStyle = xlContinuous "设表格边框样式 End With xlApp.Visible = True "显示表格 xlBook.Save "保存 Set xlApp = Nothing "交还控制给Excel End With