VB中使用EXCEL输出(包含数据库的连接)
来源:互联网 发布:递归函数c语言 编辑:程序博客网 时间:2024/04/27 15:52
Private Sub cmdSwatch_Click()
Dim xls As excel.Application
Dim xlbook As excel.Workbook
'On Error GoTo exlError
Dim i As Integer
If Dir(Text1.Text) <> "" Then '此目录下如有同名文件给出提示,并作相应处理
If MsgBox("文件已存在,是否覆盖!", vbYesNo + vbQuestion, "另存为工程造价文件") = vbNo Then
Exit Sub
Else
Kill (Text1.Text) '删除文件
End If
End If
'************打开工作表***************
Set xls = New excel.Application
xls.Visible = True
Set xlbook = xls.Workbooks.Add
'*********************************
For i = 0 To 14
If Check2(i).Value = vbChecked Then
Select Case i
Case 8
ToExcelJDanJiaSum.ToExcelJDanJiaSum xlbook, xls
Case 9
ToExcelADanJiaSum.ToExcelADanJiaSum xlbook, xls
Case 10
ToExcelCailiao.ToExcelCailiao xlbook, xls
Case 11
ToExcelTsf.ToExcelTsf xlbook, xls
Case 12
ToExcelZgcl.ToExcelZgcl xlbook, xls
End Select
End If
Next
For i = 0 To 6
If Check3(i).Value = vbChecked Then
Select Case i
Case 0
ToExcelMan.ToExcelMan xlbook, xls
Case 1
ToExcelFSD_CL.ToExcelFSD_CL xlbook, xls
Case 2
ToExcelHNT.ToExcelHNT xlbook, xls
Case 3
ToExcelZsf.ToExcelZsf xlbook, xls
Case 4
ToExcelJingChang.ToExcelJingChang xlbook, xls
Case 5
ToExcelJDanJia.ToExcelJDanJia xlbook, xls
Case 6
ToExcelADanJia.ToExcelADanJia xlbook, xls
End Select
End If
Next
xlbook.SaveAs Text1.Text '保存EXCEL文件
'***************************关闭EXCEL对象*******************
If Check1.Value = vbChecked Then
xlbook.Close
xls.Quit
End If
Set xlbook = Nothing
Set xls = Nothing
Exit Sub
'exlError:
' MsgBox Err.Description, vbOKOnly + vbCritical, "警告"
End Sub
Option Explicit
Public Sub ToExcelZgcl(ByRef xlbook, ByRef xls) '输出总工程量
Dim con As New ADODB.Connection
Dim rst_gcl As New ADODB.Recordset
Dim rst_qm As New ADODB.Recordset
'**************************连接数据库****************************************
con.CursorLocation = adUseClient
con.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strConnection & ";Persist Security Info=False"
con.Open
rst_gcl.Open "zonggcl", con, adOpenKeyset, adLockOptimistic, adCmdTable '打开工程量汇总表
If Not (rst_gcl.BOF And rst_gcl.EOF) Then
rst_gcl.MoveFirst
End If
rst_qm.Open "qianming", con, adOpenKeyset, adLockOptimistic, adCmdTable '打开签名表
rst_qm.MoveFirst
'****************************工作表初使化***********************************
Dim xlsheet As excel.Worksheet
Set xlsheet = xlbook.Sheets.Add '添加一张工作表
xlsheet.Name = "工程量汇总"
xls.ActiveSheet.PageSetup.Orientation = xlLandscape '纸张设置为横向
xlsheet.Columns("a:j").Font.Size = 10
xlsheet.Columns("a:j").VerticalAlignment = xlVAlignCenter '垂直居中
xlsheet.Columns(1).HorizontalAlignment = xlHAlignCenter '1列水平居中对齐
xlsheet.Columns(1).ColumnWidth = 8
xlsheet.Columns(2).HorizontalAlignment = xlHAlignLeft
xlsheet.Columns(2).ColumnWidth = 26
xlsheet.Columns("c:j").HorizontalAlignment = xlHAlignRight
xlsheet.Columns("c:j").ColumnWidth = 10
xlsheet.Columns("c:j").NumberFormatLocal = "0.00_ " '3到10列保留两位小数
'***************************写入标头*************************************
xlsheet.Rows(1).RowHeight = 40
xlsheet.Range(xlsheet.Cells(1, 1), xlsheet.Cells(1, 10)).MergeCells = True
xlsheet.Cells(1, 1).Value = "工程量汇总"
xlsheet.Cells(1, 1).Font.Size = 14
xlsheet.Cells(1, 1).Font.Bold = True
xlsheet.Rows(2).RowHeight = 18
xlsheet.Rows(2).HorizontalAlignment = xlHAlignCenter
xlsheet.Cells(2, 1).Value = "序号"
xlsheet.Cells(2, 2).Value = "工程项目及名称"
xlsheet.Cells(2, 3).Value = "土方开挖(m3)"
xlsheet.Cells(2, 4).Value = "石方开挖(m3)"
xlsheet.Cells(2, 5).Value = "土方回填(m3)"
xlsheet.Cells(2, 6).Value = "洞挖石方(m3)"
xlsheet.Cells(2, 7).Value = "砼浇筑(m3)"
xlsheet.Cells(2, 8).Value = "钢筋制安(t)"
xlsheet.Cells(2, 9).Value = "砌石工程(m3)"
xlsheet.Cells(2, 10).Value = "灌浆工程(m)"
xls.ActiveSheet.PageSetup.PrintTitleRows = "$1:$2" '固定表头
'***************************写入内容*************************
Dim i As Integer
i = 3 'i控制行
Dim j As Integer 'j控制列
Dim countpage As Integer
countpage = 0 '控制页
Do While Not rst_gcl.EOF
xlsheet.Rows(i).RowHeight = 18 '控制行高
For j = 1 To 10
xlsheet.Cells(i, j) = rst_gcl.Fields(j) '将工程理库中的一条记录的第一个字段写入工作表中
Next
'每18行为一页,如果数据超出一页时进行特殊处理
If i > 18 Then
xls.ActiveWindow.SmallScroll Down:=1 '活动窗口内容向下滚动1行
End If
If i Mod 18 = 0 Then
If countpage = 0 Then
xlsheet.Range(xlsheet.Cells(2, 1), xlsheet.Cells(i, 10)).Borders.LineStyle = xlContinuous '首页加边框
Else
xlsheet.Range(xlsheet.Cells(23 + (countpage - 1) * 18, 1), xlsheet.Cells(i, 10)).Borders.LineStyle = xlContinuous '中间页加边框
End If
i = i + 2 '加一条空行
'******************************在非尾页写入签名**************************************
xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = True
xlsheet.Cells(i, 1).Value = Space(64) & rst_qm.Fields(0)
xlsheet.Rows(i).RowHeight = 30
i = i + 1 '换行
xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = True
xlsheet.Cells(i, 1).Value = Space(50) & rst_qm.Fields(1)
xlsheet.Rows(i).RowHeight = 15
i = i + 1
xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = True
xlsheet.Cells(i, 1).Value = Space(55) & rst_qm.Fields(2)
xlsheet.Rows(i).RowHeight = 30
'****************************************************************************
xlsheet.HPageBreaks.Add (xlsheet.Rows(i + 1)) '添加分页符
countpage = countpage + 1 '换页
End If
i = i + 1
rst_gcl.MoveNext
Loop
xlsheet.Range(xlsheet.Cells(23 + (countpage - 1) * 18, 1), xlsheet.Cells(i - 1, 10)).Borders.LineStyle = xlContinuous '尾页加边框
i = i + 1 '加入一空行
'*********************************在尾页加签名***************************************
xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = True
xlsheet.Cells(i, 1).Value = Space(64) & rst_qm.Fields(0)
xlsheet.Rows(i).RowHeight = 30
i = i + 1 '换行
xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = True
xlsheet.Cells(i, 1).Value = Space(50) & rst_qm.Fields(1)
xlsheet.Rows(i).RowHeight = 15
i = i + 1
xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = True
xlsheet.Cells(i, 1).Value = Space(55) & rst_qm.Fields(2)
xlsheet.Rows(i).RowHeight = 30
'***********************************************************************************
xls.ActiveWindow.View = xlPageBreakPreview '分页预览
xls.ActiveWindow.Zoom = 100
If con.State = adStateOpen Then
rst_gcl.Close
rst_qm.Close
Set rst_gcl = Nothing
Set rst_qm = Nothing
con.Close
Set con = Nothing
End If
Set xlsheet = Nothing
End Sub
Option Explicit
Public Sub ToExcelTsf(ByRef xlbook, ByRef xls)
Dim con As New ADODB.Connection
Dim rst_tsf As New ADODB.Recordset
Dim rst_qm As New ADODB.Recordset
'**********************************连接数据库************************
con.CursorLocation = adUseClient
con.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strConnection & ";Persist Security Info=False"
con.Open
rst_tsf.Open "tdefeiyong", con, adOpenKeyset, adLockOptimistic, adCmdTable
If Not (rst_tsf.BOF And rst_tsf.EOF) Then
rst_tsf.MoveFirst
End If
rst_qm.Open "qianming", con, adOpenKeyset, adLockOptimistic, adCmdTable
rst_qm.MoveFirst
'*********************************工作表初使化**********************************
Dim xlsheet As excel.Worksheet
Set xlsheet = xlbook.Sheets.Add
xlsheet.Name = "机械台时、组时费汇总表"
xlsheet.Columns(1).ColumnWidth = 5
xlsheet.Columns(2).ColumnWidth = 20
xlsheet.Columns(3).ColumnWidth = 7
xlsheet.Columns(4).ColumnWidth = 7
xlsheet.Columns(5).ColumnWidth = 7
xlsheet.Columns(6).ColumnWidth = 7
xlsheet.Columns(7).ColumnWidth = 7
xlsheet.Columns(8).ColumnWidth = 7
xlsheet.Columns(9).ColumnWidth = 7
xlsheet.Columns("A:I").Font.Size = 9
xlsheet.Columns("A:I").VerticalAlignment = xlVAlignCenter '垂直居中
xlsheet.Columns(1).HorizontalAlignment = xlHAlignCenter '1列水平居中对齐
xlsheet.Columns(2).HorizontalAlignment = xlHAlignLeft '2列水平左对齐
'******************************写入标头************************************
xlsheet.Rows(1).RowHeight = 35
xlsheet.Range(xlsheet.Cells(1, 1), xlsheet.Cells(1, 9)).MergeCells = True
xlsheet.Cells(1, 1).Font.Size = 14
xlsheet.Cells(1, 1).Font.Bold = True
xlsheet.Cells(1, 1).Value = "机械台时、组时费汇总表"
xlsheet.Cells(2, 9).Value = "单位:元"
xlsheet.Range(xlsheet.Cells(3, 1), xlsheet.Cells(5, 1)).MergeCells = True
xlsheet.Cells(3, 1).Value = "编号"
xlsheet.Range(xlsheet.Cells(3, 2), xlsheet.Cells(5, 2)).MergeCells = True
xlsheet.Cells(3, 2).Value = "机械名称"
xlsheet.Range(xlsheet.Cells(3, 3), xlsheet.Cells(5, 3)).MergeCells = True
xlsheet.Cells(3, 3).Value = "台时费"
xlsheet.Range(xlsheet.Cells(3, 4), xlsheet.Cells(3, 9)).MergeCells = True
xlsheet.Cells(3, 4).Value = "其 中"
xlsheet.Range(xlsheet.Cells(3, 3), xlsheet.Cells(5, 3)).MergeCells = True
xlsheet.Cells(3, 3).Value = "台时费"
xlsheet.Range(xlsheet.Cells(4, 4), xlsheet.Cells(5, 4)).MergeCells = True
xlsheet.Cells(4, 4).Value = "折旧费"
xlsheet.Range(xlsheet.Cells(4, 5), xlsheet.Cells(5, 5)).MergeCells = True
xlsheet.Cells(4, 5).Value = "修理替换费"
xlsheet.Range(xlsheet.Cells(4, 6), xlsheet.Cells(5, 6)).MergeCells = True
xlsheet.Cells(4, 6).Value = "安拆费"
xlsheet.Range(xlsheet.Cells(4, 7), xlsheet.Cells(5, 7)).MergeCells = True
xlsheet.Cells(4, 7).Value = "人工费"
xlsheet.Range(xlsheet.Cells(4, 8), xlsheet.Cells(5, 8)).MergeCells = True
xlsheet.Cells(4, 8).Value = "燃料费"
xlsheet.Range(xlsheet.Cells(4, 9), xlsheet.Cells(5, 9)).MergeCells = True
xlsheet.Cells(4, 9).Value = "其他费"
xlsheet.Range(xlsheet.Cells(1, 1), xlsheet.Cells(5, 9)).HorizontalAlignment = xlHAlignCenter
xls.ActiveSheet.PageSetup.PrintTitleRows = "$1:$5" '固定表头
'****************************************写入内容*************************************
Dim i As Integer
i = 6
Do While Not rst_tsf.EOF
xlsheet.Cells(i, 1).Value = rst_tsf.Fields("nn")
xlsheet.Cells(i, 2).Value = rst_tsf.Fields("name")
xlsheet.Cells(i, 3).Value = rst_tsf.Fields("price")
xlsheet.Cells(i, 4).Value = rst_tsf.Fields("zhejiu")
xlsheet.Cells(i, 5).Value = rst_tsf.Fields("xiuli")
xlsheet.Cells(i, 6).Value = rst_tsf.Fields("anchai")
xlsheet.Cells(i, 7).Value = rst_tsf.Fields("rengong")
xlsheet.Cells(i, 8).Value = rst_tsf.Fields("dongli")
xlsheet.Cells(i, 9).Value = rst_tsf.Fields("qita")
If i > 22 Then
xls.ActiveWindow.SmallScroll Down:=1 '活动窗口内容向下滚动1行
End If
i = i + 1
rst_tsf.MoveNext
Loop
xlsheet.Range(xlsheet.Cells(6, 3), xlsheet.Cells(i - 1, 9)).NumberFormatLocal = "0.00_ " '保留两位小数
'*********************************添加边框**********************************
xlsheet.Range(xlsheet.Cells(3, 1), xlsheet.Cells(i - 1, 9)).Borders.LineStyle = xlContinuous
'******************************************************************************
xls.ActiveSheet.PageSetup.BottomMargin = Application.InchesToPoints(2.2) '设置下侧面边距
xls.ActiveSheet.PageSetup.FooterMargin = Application.InchesToPoints(1) '设置页脚高
xls.ActiveSheet.PageSetup.CenterFooter = "&10" & rst_qm.Fields(0) & Chr(10) & Chr(10) & rst_qm.Fields(1) & Chr(10) & Chr(10) & rst_qm.Fields(2) '加页脚
xls.ActiveWindow.View = xlPageBreakPreview '分页预览
xls.ActiveWindow.Zoom = 100
'***************************关闭记录集*******************
If con.State = adStateOpen Then
rst_tsf.Close
rst_qm.Close
Set rst_tsf = Nothing
Set rst_qm = Nothing
con.Close
Set con = Nothing
End If
Set xlsheet = Nothing
End Sub
- VB中使用EXCEL输出(包含数据库的连接)
- VB中使用EXCEL输出
- VB中使用EXCEL输出
- VB中使用EXCEL输出
- VB中使用EXCEL
- VB中数据库的常用连接方式
- 如何在Excel中使用VB宏连接SAP系统
- VB中igrid输出到excel
- VB中,连接ACCESS数据库
- VB.NET将数据库的记录导出到excel中
- 连接数据库和vb的ADO的通常使用
- Java中JDBC连接大全,包含常用的数据库
- VB中引用方式连接ACCESS数据库的解答.
- 详解VB中连接access数据库的几种方法
- vb中数据库的连接(实例小结)
- 详解VB中连接access数据库的几种方法
- [VB.NET]请教使用DSO连接多维数据库的问题
- 实现VB与EXCEL的无缝连接
- 有感于金旭亮老师的抱怨
- 舍我其谁,人就是要活得有自信!
- 数字键盘输入法——崩出来的“猪”字的背后
- 郁闷啊???
- 需要软设视频资料的请进
- VB中使用EXCEL输出(包含数据库的连接)
- NULLSoft 真是个好东西
- FLTK beginning
- 层使用的示例
- 我就经常这样。。。。。
- [-生活随笔-] 当当购书·逛书店
- 公司改名了……
- j2se 5.0新特性之StringBuilder类应用
- 转贴(唐僧取经有感)