|
|
|
‘引用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.", "", 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() :复制我的代码就算了，怎么连我的邮箱也列出来啊？
:P
|
| Top |
|
|
回复人： 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
|
|
|
