VB中使用EXCEL输出 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 = xlHAlignLe

评论