Private Sub Cmdswatch_Click () DIM XLS AS Excel.ApplicationDim XLBook AS Excel.Workbook'on Error Goto Exlerrdim i as Integer if Dir (Text1.Text) <> "" "" "this' This directory gives a prompt, and make The corresponding processing IF msgbox ("file already exists, whether it is overwritten!", Vbyesno vbquestion, "Save As Engineering Cost File") = VBNO THEN EXIT SUB ELSE KILL (Text1.Text) 'Delete file end if endiff
'************ Open Worksheet ************** 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 the select case i copy 0 TOEXCELMAN.TOEXCELMAN XLBOOK, XLS CASE 1 TOEXCELFSD_CL.TOEXCELFSD_CL XLBOOK, XLS Case 2 TOEXCEL HNT.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 ' Save the Excel file '************************* Close Excel object ************************* *** if check1.value = vbChecked the xlbook.close xls.quit end if set xlbook = nothing set xls = Nothing exit sub'Exlerror: '
MsgBox Err.description, Vbokonly Vbcritical, "Warning" end sub
Option ExplicitPublic Sub ToExcelZgcl (ByRef xlbook, ByRef xls) 'output from the overall project amount Dim con As New ADODB.Connection Dim rst_gcl As New ADODB.Recordset Dim rst_qm As New ADODB.Recordset' ************ **************Connect to the database********************************** ****** 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 'open quantities are summarized in table If Not (rst_gcl.BOF And rst_gcl.EOF) Then rst_gcl.MoveFirst End If rst_qm.Open "qianming", con, adOpenKeyset, adLockOptimistic, adCmdTable' signature open table rst_qm .MOVEFIRST '******************************************************************************************* ********************* DIM XLSHEET AS Excel.Worksheet Set Xlsheet = XLbook.sheets.add 'Add a work table xlsheet.name = "Engineering Summary" Xls.Activesheet.pagesetup.orientation = xllandscape 'Paper is set to horizontal xlsheet.columns ("A: J"). font.size = 10 xlsheet.columns ("A: j "). VerticalAlignment = xlVAlignCenter 'vertically centered xlsheet.Columns (1) .HorizontalAlignment = xlHAlignCenter' 1 column horizontally centered 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 to 10 columns reserve two decimal" ************************** Written head ******** ************************************** XLSHEET.ROWS (1) .rtowheight =
40 xlsheet.range (xlsheet.cells (1, 1), xlsheet.cells (1, 10)). Mergecells = true xlsheet.cells (1, 1) .value = "Engineering summary" Xlsheet.cells (1, 1 ) .Font.size = 14 xlsheet.cells (1, 1) .font.Bold = true xlsheet.Rows (2) .rtowHeight = 18 xlsheet.Rows (2) .hor xlsheet = xlhaligncenter xlsheet.cells (2, 1). Value = "Sequence Number" xlsheet.cells (2, 2) .value = "Engineering Project and Name" Xlsheet.cells (2, 3) .value = "Earth Excavation (M3)" Xlsheet.cells (2, 4). Value = "Stone Excavation (M3)" Xlsheet.cells (2, 5) .value = "Earth Backfill (M3)" Xlsheet.cells (2, 6) .value = "Cave Digital (M3)" Xlsheet .Cells (2, 7) .value = "pour (M3)" Xlsheet.cells (2, 8) .value = "Steel Bar San (T)" xlsheet.cells (2, 9) .value = "stone stone Engineering (M3) "Xlsheet.cells (2, 10) .Value =" Grouting Engineering (M) "Xls.Activesheet.pagesetup.printtitlerows =" $ 1: $ 2 "'fixed head" ******** ***************** Write content ******************************************** DIM i as integer i = 3 'i Control Di DIM J AS Integer' J Control Column DIM CountPage As INTEGER CUNTPAGE = 0 'Control Page Do While Not Rst_gcl.eof Xlsheet.Rows (i) .RowHeight = 18 'Control line high for j = 1 to 10 xlsheet.cells (i, j) = RST_GCL.Fields (j)' Write the first field of a record in the engineering library into the worksheet NEXT 'every 18 Appearance Xlsheet.Range (xlsheet.cells (2, 1), xlsheet.cells (i, 10)). Borders.LineStyle = Xlcontinuous' Home Pack Box Else Xlsheet.Range (xlsheet.cells (23
(CountPage - 1) * 18, 1), Xlsheet.cells (i, 10))). Borders.LineStyle = XLCONTINUOUS 'Intermediate Page End IF i = i 2' plus an empty line '****** *********************************************************************************************** ****************** xiSheet.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 'wrap XLsheet.Range (xlsheet.cells (i, 1), xlsheet.cells (i, 10)). Mrgecells = 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.AD D (Xlsheet.Rows (i 1)) 'Add Pedmentation COUNTPAGE = CountPage 1' Change page 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' Last Page Box i = i 1 'Add a space line' ************ ********************************************************************************************* ************** 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 'wrap 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) .rtowheight = 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 'preview tab 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 = Nothingend Suboption 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 '*************************** **************** Connection Database ********************************* 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.movefirst End If RST_QM.Open "Qianming", Con, AdopenKeyset, AdlockOptimistic, Adcmdtable Rst_qm.moveFirst '******************************** *********** Worksheets initiates ******************************************* * Dim xlsheet as excel.worksheet set xlsheet = xlbook.sheets.add xlsheet.name = "Machinery Table, Group Spend" 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 'vertical home xlsheet.columns (1) .horizontalalignment = xlhaligncenter' 1 column horizontal center align XLsheet.columns (2 ). Horizontalalignment = XlhalignLEFT '2 columns Left aligned' ***************************************************************************************** ******************************* XLSHEET.ROWS (1) .rtowheight =
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 = "Machinery Table, Group Time Federation Table" Xlsheet.cells (2, 9) .value = "Unit: Yuan" Xlsheet.Range (Xlsheet.cells (3, 1), xlsheet.cells (5, 1)). Mergecells = true xlsheet.cells (3, 1) .value = "Number" xlsheet.range (xlsheet.cells (3, 2), Xlsheet.cells 5, 2)). Mergecells = true xlsheet.cells (3, 2) .value = "Mechanical Name" xlsheet.range (xlsheet.cells (3, 3), xlsheet.cells (5, 3)). Mrgecells = true Xlsheet.cells (3, 3) .value = "Table" 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 = "Table time" xlsheet .Range (xlsheet.cells (4, 4), xlsheet.cells (5, 4)). Mergecells = true xlsheet.cells (4, 4) .value = "Depreciation fee" xlsheet.range (xlsheet.cells (4, 5), xlsheet.cells (5, 5)). Mergece LLS = True Xlsheet.cells (4, 5) .value = "Repair Alternative Fee" xlsheet.Range (xlsheet.cells (4, 6), Xlsheet.cells (5, 6)). Mergecells = true xlsheet.cells (4 , 6) .Value = "Submail" xlsheet.range (xlsheet.cells (4, 7), xlsheet.cells (5, 7)). Mergecells = true xlsheet.cells (4, 7) .value = "artificial Temple "xlsheet.range (xlsheet.cells (4, 8), xlsheet.cells (5, 8)). Mergecells = true xlsheet.cells (4, 8) .value =" Fuel fee "xlsheet.range (xlsheet.cells (4, 9), xlsheet.cells (5, 9)). Mergecells = true xlsheet.cells (4, 9) .value = "Other Fees"
Xlsheet.Range (Xlsheet.cells (1, 1), Xlsheet.cells (5, 9)). Horizontalalignment = XlhalignCenter Xls.Activesheet.pagesetup.printtitlerows = "$ 1: $ 5" 'fixed head "****** ************************************************************************** ************************ 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 'Active window content rolling 1 row END IF i = i 1 RST_TSF.MOVENEXT loop xlsheet.range (xlshe Et.cells (6, 3), Xlsheet.cells (i - 1, 9)). NumberformatLocal = "0.00_" 'Keep two decimal' **************** *************** Add Border ****************************************** ** xlsheet.Range (xlsheet.cells (3, 1), Xlsheet.cells (i - 1, 9)). Borders.LineStyle = Xlcontinuous' **************** *********************************************************** *********** XLS.Activesheet.pagesetup.bottommargin = Application.incheStopoints (2.2) Set the lower side margins xls.activeesheet.pagesetup.footermarmargin = Application.inchestopoints (1) '
Set footer high 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) 'Add Page Xls.ActiveWindow.View = XLpageBreakPreview' Page Preview Xls.ActiveWindow.Zoom = 100 '******************************** ***** Close Record Set *************************** 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 = Nothingend Sub Wonderful Subsequent
