Private Sub cmdSwatch_Click()Dim xls As excel.ApplicationDim xlbook As excel.Workbook'On Error GoTo exlErrorDim i As IntegerIf Dir(Text1.Text) <> "" Then '此目录下如有同名文件给出提示,并作相应处理If MsgBox("文件已存在，是否覆盖！", vbYesNo + vbQuestion, "另存为工程造价文件") = vbNo Then Exit SubElseKill (Text1.Text) '删除文件End IfEnd If'************打开工作表***************Set xls = New excel.Applicationxls.Visible = TrueSet xlbook = xls.Workbooks.Add'*********************************For i = 0 To 14If Check2(i).Value = vbChecked ThenSelect Case iCase 8ToExcelJDanJiaSum.ToExcelJDanJiaSum xlbook, xlsCase 9ToExcelADanJiaSum.ToExcelADanJiaSum xlbook, xlsCase 10ToExcelCailiao.ToExcelCailiao xlbook, xlsCase 11ToExcelTsf.ToExcelTsf xlbook, xlsCase 12ToExcelZgcl.ToExcelZgcl xlbook, xlsEnd SelectEnd IfNextFor i = 0 To 6If Check3(i).Value = vbChecked ThenSelect Case iCase 0ToExcelMan.ToExcelMan xlbook, xlsCase 1ToExcelFSD_CL.ToExcelFSD_CL xlbook, xls Case 2ToExcelHNT.ToExcelHNT xlbook, xlsCase 3ToExcelZsf.ToExcelZsf xlbook, xlsCase 4ToExcelJingChang.ToExcelJingChang xlbook, xls Case 5ToExcelJDanJia.ToExcelJDanJia xlbook, xls Case 6ToExcelADanJia.ToExcelADanJia xlbook, xls End SelectEnd IfNextxlbook.SaveAs Text1.Text '保存EXCEL文件'***************************关闭EXCEL对象*******************If Check1.Value = vbChecked Thenxlbook.Closexls.QuitEnd IfSet xlbook = NothingSet xls = NothingExit Sub'exlError:' MsgBox Err.Description, vbOKOnly + vbCritical, "警告"End SubOption ExplicitPublic Sub ToExcelZgcl(ByRef xlbook, ByRef xls) '输出总工程量Dim con As New ADODB.ConnectionDim rst_gcl As New ADODB.RecordsetDim rst_qm As New ADODB.Recordset'**************************连接数据库****************************************con.CursorLocation = adUseClientcon.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strConnection & ";Persist Security Info=False"con.Openrst_gcl.Open "zonggcl", con, adOpenKeyset, adLockOptimistic, adCmdTable '打开工程量汇总表If Not (rst_gcl.BOF And rst_gcl.EOF) Thenrst_gcl.MoveFirstEnd Ifrst_qm.Open "qianming", con, adOpenKeyset, adLockOptimistic, adCmdTable '打开签名表rst_qm.MoveFirst'****************************工作表初使化*********************************** Dim xlsheet As excel.WorksheetSet xlsheet = xlbook.Sheets.Add '添加一张工作表 = "工程量汇总"xls.ActiveSheet.PageSetup.Orientation = xlLandscape '纸张设置为横向xlsheet.Columns("a:j").Font.Size = 10xlsheet.Columns("a:j").VerticalAlignment = xlVAlignCenter '垂直居中xlsheet.Columns(1).HorizontalAlignment = xlHAlignCenter '1列水平居中对齐xlsheet.Columns(1).ColumnWidth = 8xlsheet.Columns(2).HorizontalAlignment = xlHAlignLeftxlsheet.Columns(2).ColumnWidth = 26xlsheet.Columns("c:j").HorizontalAlignment = xlHAlignRightxlsheet.Columns("c:j").ColumnWidth = 10xlsheet.Columns("c:j").NumberFormatLocal = "0.00_ " '3到10列保留两位小数'***************************写入标头************************************* xlsheet.Rows(1).RowHeight = 40xlsheet.Range(xlsheet.Cells(1, 1), xlsheet.Cells(1, 10)).MergeCells = Truexlsheet.Cells(1, 1).Value = "工程量汇总"xlsheet.Cells(1, 1).Font.Size = 14xlsheet.Cells(1, 1).Font.Bold = Truexlsheet.Rows(2).RowHeight = 18xlsheet.Rows(2).HorizontalAlignment = xlHAlignCenterxlsheet.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 Integeri = 3 'i控制行Dim j As Integer 'j控制列Dim countpage As Integercountpage = 0 '控制页Do While Not rst_gcl.EOFxlsheet.Rows(i).RowHeight = 18 '控制行高For j = 1 To 10xlsheet.Cells(i, j) = rst_gcl.Fields(j) '将工程理库中的一条记录的第一个字段写入工作表中Next'每18行为一页，如果数据超出一页时进行特殊处理If i > 18 Thenxls.ActiveWindow.SmallScroll Down:=1 '活动窗口内容向下滚动1行End IfIf i Mod 18 = 0 ThenIf countpage = 0 Thenxlsheet.Range(xlsheet.Cells(2, 1), xlsheet.Cells(i, 10)).Borders.LineStyle = xlContinuous '首页加边框Elsexlsheet.Range(xlsheet.Cells(23 + (countpage - 1) * 18, 1), xlsheet.Cells(i, 10)).Borders.LineStyle = xlContinuous '中间页加边框End Ifi = i + 2 '加一条空行'******************************在非尾页写入签名**************************************xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = Truexlsheet.Cells(i, 1).Value = Space(64) & rst_qm.Fields(0)xlsheet.Rows(i).RowHeight = 30i = i + 1 '换行xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = Truexlsheet.Cells(i, 1).Value = Space(50) & rst_qm.Fields(1)xlsheet.Rows(i).RowHeight = 15i = i + 1xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = Truexlsheet.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 Ifi = i + 1rst_gcl.MoveNextLoopxlsheet.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 = Truexlsheet.Cells(i, 1).Value = Space(64) & rst_qm.Fields(0)xlsheet.Rows(i).RowHeight = 30i = i + 1 '换行xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = Truexlsheet.Cells(i, 1).Value = Space(50) & rst_qm.Fields(1)xlsheet.Rows(i).RowHeight = 15i = i + 1xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = Truexlsheet.Cells(i, 1).Value = Space(55) & rst_qm.Fields(2)xlsheet.Rows(i).RowHeight = 30'*********************************************************************************** xls.ActiveWindow.View = xlPageBreakPreview '分页预览xls.ActiveWindow.Zoom = 100If con.State = adStateOpen Thenrst_gcl.Closerst_qm.CloseSet rst_gcl = NothingSet rst_qm = Nothingcon.CloseSet con = NothingEnd IfSet xlsheet = NothingEnd SubOption ExplicitPublic Sub ToExcelTsf(ByRef xlbook, ByRef xls)Dim con As New ADODB.ConnectionDim rst_tsf As New ADODB.RecordsetDim rst_qm As New ADODB.Recordset'**********************************连接数据库************************con.CursorLocation = adUseClientcon.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strConnection & ";Persist Security Info=False"con.Openrst_tsf.Open "tdefeiyong", con, adOpenKeyset, adLockOptimistic, adCmdTableIf Not (rst_tsf.BOF And rst_tsf.EOF) Thenrst_tsf.MoveFirstEnd Ifrst_qm.Open "qianming", con, adOpenKeyset, adLockOptimistic, adCmdTablerst_qm.MoveFirst'*********************************工作表初使化**********************************Dim xlsheet As excel.WorksheetSet xlsheet = xlbook.Sheets.Add = "机械台时、组时费汇总表"xlsheet.Columns(1).ColumnWidth = 5xlsheet.Columns(2).ColumnWidth = 20xlsheet.Columns(3).ColumnWidth = 7xlsheet.Columns(4).ColumnWidth = 7xlsheet.Columns(5).ColumnWidth = 7xlsheet.Columns(6).ColumnWidth = 7xlsheet.Columns(7).ColumnWidth = 7xlsheet.Columns(8).ColumnWidth = 7xlsheet.Columns(9).ColumnWidth = 7xlsheet.Columns("A:I").Font.Size = 9xlsheet.Columns("A:I").VerticalAlignment = xlVAlignCenter '垂直居中xlsheet.Columns(1).HorizontalAlignment = xlHAlignCenter '1列水平居中对齐xlsheet.Columns(2).HorizontalAlignment = xlHAlignLeft '2列水平左对齐'******************************写入标头************************************ xlsheet.Rows(1).RowHeight = 35xlsheet.Range(xlsheet.Cells(1, 1), xlsheet.Cells(1, 9)).MergeCells = Truexlsheet.Cells(1, 1).Font.Size = 14xlsheet.Cells(1, 1).Font.Bold = Truexlsheet.Cells(1, 1).Value = "机械台时、组时费汇总表"xlsheet.Cells(2, 9).Value = "单位：元"xlsheet.Range(xlsheet.Cells(3, 1), xlsheet.Cells(5, 1)).MergeCells = Truexlsheet.Cells(3, 1).Value = "编号"xlsheet.Range(xlsheet.Cells(3, 2), xlsheet.Cells(5, 2)).MergeCells = Truexlsheet.Cells(3, 2).Value = "机械名称"xlsheet.Range(xlsheet.Cells(3, 3), xlsheet.Cells(5, 3)).MergeCells = Truexlsheet.Cells(3, 3).Value = "台时费"xlsheet.Range(xlsheet.Cells(3, 4), xlsheet.Cells(3, 9)).MergeCells = Truexlsheet.Cells(3, 4).Value = "其中"xlsheet.Range(xlsheet.Cells(3, 3), xlsheet.Cells(5, 3)).MergeCells = Truexlsheet.Cells(3, 3).Value = "台时费"xlsheet.Range(xlsheet.Cells(4, 4), xlsheet.Cells(5, 4)).MergeCells = Truexlsheet.Cells(4, 4).Value = "折旧费"xlsheet.Range(xlsheet.Cells(4, 5), xlsheet.Cells(5, 5)).MergeCells = Truexlsheet.Cells(4, 5).Value = "修理替换费"xlsheet.Range(xlsheet.Cells(4, 6), xlsheet.Cells(5, 6)).MergeCells = Truexlsheet.Cells(4, 6).Value = "安拆费"xlsheet.Range(xlsheet.Cells(4, 7), xlsheet.Cells(5, 7)).MergeCells = Truexlsheet.Cells(4, 7).Value = "人工费"xlsheet.Range(xlsheet.Cells(4, 8), xlsheet.Cells(5, 8)).MergeCells = Truexlsheet.Cells(4, 8).Value = "燃料费"xlsheet.Range(xlsheet.Cells(4, 9), xlsheet.Cells(5, 9)).MergeCells = Truexlsheet.Cells(4, 9).Value = "其他费"xlsheet.Range(xlsheet.Cells(1, 1), xlsheet.Cells(5, 9)).HorizontalAlignment = xlHAlignCenterxls.ActiveSheet.PageSetup.PrintTitleRows = "$1:$5" '固定表头'****************************************写入内容************************************* Dim i As Integeri = 6Do While Not rst_tsf.EOFxlsheet.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 Thenxls.ActiveWindow.SmallScroll Down:=1 '活动窗口内容向下滚动1行End Ifi = i + 1rst_tsf.MoveNextLoopxlsheet.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 Thenrst_tsf.Closerst_qm.CloseSet rst_tsf = NothingSet rst_qm = Nothingcon.CloseSet con = NothingEnd IfSet xlsheet = NothingEnd Sub精彩的后续作者Blog：/mi6236/。