lmb1.bas

lmb--路面工程数量计算软件

Attribute VB_Name = "Module1"
Option Explicit
'Public xlapp As Excel.Application
Public xlbook As Excel.Workbook
Public xlsheet1 As Excel.Worksheet
Public xlsheet2 As Excel.Worksheet
Public xlsheet3 As Excel.Worksheet
Public xlsheet4 As Excel.Worksheet
Public xlsheet5 As Excel.Worksheet
Public qdzh As Double, zdzh As Double
Private hang As Integer, tt As Integer
Private aa As String
Private zqc As Single, wlcs As Single

Sub read_suju()
'读入路幅资料
    Dim lmk As Single, yljk As Single, tljk As Single, zyfgdk As Single
    lmk = xlsheet1.Cells(4, "B")
    yljk = xlsheet1.Cells(4, "C")
    tljk = xlsheet1.Cells(4, "D")
    zyfgdk = xlsheet1.Cells(4, "E")
    aa = InputBox("请输入工作表名：")
    Do While sgzb(aa) = 1 And aa <> ""
        aa = InputBox("请重新输入工作表名：")
    Loop
    If aa = "" Then Exit Sub
    copy_sheet yljk        '调用拷贝指定表到指定工作表子过程
    qdzh = 0: zdzh = 0
    Load Form3
    Form3.Show 1
'读入中央分隔带各层结构厚度
    If yljk <> 0 And zyfgdk <> 0 Then
        Dim zydch(5) As Integer, ii As Integer
        Call zydsj(zydch)
    End If
'读入每沿米路肩加固工程量
    Dim ljjgsn As Single, ljjgsl As Single
    ljjgsn = xlsheet1.Cells(16, "B")
    ljjgsl = xlsheet1.Cells(16, "C")
'读入挖路槽深度
    wlcs = xlsheet1.Cells(18, "C")
'读入路缘石资料
    Dim lysmj As Single, lysds As Integer
    lysmj = xlsheet1.Cells(18, "F")
    lysds = xlsheet1.Cells(19, "F")
'读入路面结构组合资料
    Dim cs_lmzh As Integer, cs_ljzh As Integer
    Dim cs_ljmc As Integer, cs_lmmc As Integer
    Dim zhs_lm As Integer, zhs_lj As Integer, i As Integer, j As Integer
    cs_lmmc = xlsheet1.Cells(21, "C")
    cs_ljmc = xlsheet1.Cells(32, "C")
    ReDim lmzh(10, 0) As String, lmch(10, 0) As String
    zqc = 0
    If qdzh = -999 Or zdzh = -999 Then
        xlbook.Application.DisplayAlerts = False
        xlbook.Worksheets(aa).Delete
        xlbook.Application.DisplayAlerts = True
        Exit Sub
    End If
'读入路面组合分段资料
    Dim fdgs As Integer
    Dim fdqdz As Double, fdzdz As Double
    Dim jglxdh As Integer
    ReDim str(0) As String
    Dim kqc As Single, dbc As Single, wfc As Single
    fdgs = 0
    hang = 0
    Do While xlsheet1.Cells(44 + fdgs, "C") <> Empty
        fdqdz = xlsheet1.Cells(44 + fdgs, "B")
        fdzdz = xlsheet1.Cells(44 + fdgs, "C")
        If fdqdz < qdzh Then
            GoTo 100
        ElseIf (fdqdz >= qdzh) And (fdzdz <= zdzh) Then
            jglxdh = xlsheet1.Cells(44 + fdgs, "D")
'读入该jglxdh的路面结构及厚度资料和各层宽度
            cs_lmzh = read_cl(lmzh, lmch, jglxdh)
            zhs_lm = UBound(lmzh, 2)
            ReDim lmck(cs_lmzh) As Single
            For i = 1 To cs_lmzh
                lmck(i) = xlsheet1.Cells(8, 1 + i)
            Next i
'读入对应jglxdh的路肩结构及厚度资料和各层宽度
            If yljk <> 0 Then
            Dim ljlxdh As Integer
            ReDim ljzh(10, 0) As String, ljch(10, 0) As String
            ljlxdh = xlsheet1.Cells(44 + fdgs, "E")
            cs_ljzh = read_cllj(ljzh, ljch, ljlxdh)
            zhs_lj = UBound(ljzh, 2)
            ReDim ljck(cs_ljzh) As Single
                For i = 1 To cs_ljzh
                    ljck(i) = xlsheet1.Cells(12, 1 + i)
                Next i
            End If
            kqc = xlsheet1.Cells(44 + fdgs, "F")
            dbc = xlsheet1.Cells(44 + fdgs, "G")
            wfc = xlsheet1.Cells(44 + fdgs, "H")
        ElseIf fdzdz > zdzh Then
            Exit Do
        End If
'将桩号改变为“K**+***”的形式
    Dim zhgb As String
    zhgb = gbzh(fdqdz) & "～" & gbzh(fdzdz)       '调用改变桩号函数
'计算培路肩宽
    Dim chlj As Single
    Dim ljk1 As Single
    ReDim ljk(cs_lmzh) As Single, pljk(cs_lmzh) As Single
    ljk(0) = lmk + zyfgdk + tljk * 2 + yljk * 2
    chlj = 0
    For j = 1 To cs_lmzh
        ljk(j) = ljk(j - 1) + chlj
        pljk(j) = ljk(j) - lmck(j) + lmch(j, zhs_lm) * 1.5 / 100
        chlj = lmch(j, zhs_lm) * 3 / 100
    Next j
'计算该结构类型的各层长度及工程量
    Dim k As Integer
    Dim jgccd As Single
    Dim p1 As String, K_i As String
    Dim colNI As Integer, colSL As Integer, colVN As Integer
    ljyf colNI, colSL, colVN, yljk
    If wfc <> 0 Then
        xlsheet5.Cells(7 + hang, 16 + colVN) = wlcs
        xlsheet5.Cells(7 + hang, 17 + colVN) = Int(wfc * lmck(cs_lmzh) + 0.5) / 1000
    End If
    If kqc <> 0 Then
        xlsheet5.Cells(7 + hang, 18 + colVN) = "扣桥长" & kqc + dbc & "m。"
    End If
    For k = 1 To cs_lmmc
        p1 = CStr(7 + k - 1 + hang)
        If yljk = 0 Then
            K_i = "=I" & p1 & "+J" & p1
        Else
            K_i = "=N" & p1 & "+O" & p1
        End If
        jgccd = fdzdz - fdqdz - kqc - dbc
        If k = 1 Then
            xlsheet5.Cells(7 + hang, "A") = zhgb
            xlsheet5.Cells(7 + hang, 12 + colSL) = Int(jgccd * ljjgsn * 100 + 0.5) / 100
            xlsheet5.Cells(7 + hang, 13 + colSL) = Int(jgccd * ljjgsl * 100 + 0.5) / 100
            If yljk <> 0 Then
                If lysmj <> 0 Then
                    xlsheet5.Cells(7 + hang, "U") = Int(lysmj * lysds * jgccd * 100 + 0.5) / 100
                End If
            ElseIf ljjgsn = 0 Then
                xlsheet5.Cells(7 + k - 1 + hang, 14 + colVN) = lmch(k, zhs_lm)
                xlsheet5.Cells(7 + k - 1 + hang, 15 + colVN) = Int(jgccd * pljk(k) + 0.5) / 1000
            End If
        End If
        xlsheet5.Cells(7 + k - 1 + hang, "B") = jgccd
        xlsheet5.Cells(7 + k - 1 + hang, "C") = lmzh(k, zhs_lm)
        xlsheet5.Cells(7 + k - 1 + hang, "D") = lmck(k)
        xlsheet5.Cells(7 + k - 1 + hang, 9 + colNI) = Int(jgccd * lmck(k) + 0.5) / 1000
        xlsheet5.Cells(7 + k - 1 + hang, 11 + colNI) = K_i
        xlsheet5.Cells(7 + k - 1 + hang, "E") = lmch(k, zhs_lm)
        xlsheet5.Cells(7 + k - 1 + hang, 19 + colVN) = lmzh(k, zhs_lm) & lmch(k, zhs_lm)
        If zydch(k) <> 0 Then
            xlsheet5.Cells(7 + k - 1 + hang, "I") = zyfgdk
            xlsheet5.Cells(7 + k - 1 + hang, "J") = zydch(k)
            xlsheet5.Cells(7 + k - 1 + hang, "R") = Int(jgccd * zyfgdk + 0.5) / 1000
        End If
        If yljk <> 0 Then
            xlsheet5.Cells(7 + k - 1 + hang, "K") = ljzh(k, zhs_lj)
            xlsheet5.Cells(7 + k - 1 + hang, "L") = ljck(k)
            xlsheet5.Cells(7 + k - 1 + hang, "M") = ljch(k, zhs_lj)
            xlsheet5.Cells(7 + k - 1 + hang, "Q") = Int(ljck(k) * jgccd * 2 + 0.5) / 1000
            xlsheet5.Cells(7 + k - 1 + hang, "AC") = ljzh(k, zhs_lj) & ljch(k, zhs_lj)
            xlsheet5.Cells(7 + j - 1 + hang, 14 + colVN) = lmch(k, zhs_lm)
            xlsheet5.Cells(7 + j - 1 + hang, 15 + colVN) = Int(jgccd * pljk(k) + 0.5) / 1000

        End If
    Next k
    k = 0
    For j = cs_lmmc + 1 To cs_lmzh
        p1 = CStr(7 + j - 1 + hang)
        If yljk = 0 Then
            K_i = "=I" & p1 & "+J" & p1
        Else
            K_i = "=N" & p1 & "+O" & p1
        End If
        jgccd = fdzdz - fdqdz - kqc - dbc
        jgccd = fdzdz - fdqdz - kqc
        xlsheet5.Cells(7 + j - 1 + hang, 14 + colVN) = lmch(j, zhs_lm)
        xlsheet5.Cells(7 + j - 1 + hang, 15 + colVN) = Int(jgccd * pljk(j) + 0.5) / 1000
        xlsheet5.Cells(7 + j - 1 + hang, "B") = jgccd
        xlsheet5.Cells(7 + j - 1 + hang, "C") = lmzh(j, zhs_lm)
        xlsheet5.Cells(7 + j - 1 + hang, 19 + colVN) = lmzh(j, zhs_lm) & lmch(j, zhs_lm)
        xlsheet5.Cells(7 + j - 1 + hang, "D") = lmck(j)
        xlsheet5.Cells(7 + j - 1 + hang, 6 + k) = lmch(j, zhs_lm)
        xlsheet5.Cells(7 + j - 1 + hang, 9 + colNI) = Int(jgccd * lmck(j) + 0.5) / 1000
        xlsheet5.Cells(7 + j - 1 + hang, 11 + colNI) = K_i
        If yljk <> 0 Then
            xlsheet5.Cells(7 + j - 1 + hang, "K") = ljzh(j, zhs_lj)
            xlsheet5.Cells(7 + j - 1 + hang, "L") = ljck(j) * 2
            xlsheet5.Cells(7 + j - 1 + hang, "M") = ljch(j, zhs_lj)
            xlsheet5.Cells(7 + j - 1 + hang, "Q") = Int(ljck(j) * jgccd + 0.5) / 1000
            xlsheet5.Cells(7 + j - 1 + hang, "AC") = ljzh(j, zhs_lj) & ljch(j, zhs_lj)
        End If
        k = k + 1
    Next j
    hang = hang + cs_lmzh + 1
    zqc = kqc + dbc + zqc
100 fdgs = fdgs + 1
    Loop
    hang = hang + 9
    t lmzh, lmch, cs_lmmc, yljk, ljjgsn   '找出路面的不同各层结构及厚度
    If yljk <> 0 Then
        t1 ljzh, ljch, cs_ljmc
    End If
    xlsheet5.Activate   '激活路面表
    If yljk = 0 Then
        xlsheet5.Columns("S:U").Select
    Else
        xlsheet5.Columns("AA:AC").Select
    End If
    xlbook.Application.Selection.EntireColumn.Hidden = True
    zjbgk yljk
    ymsz
    xlsheet5.Range("a1").Select
End Sub
Sub copy_sheet(yljk As Single)
    xlsheet4.Activate
    xlsheet4.Select
    xlbook.Sheets.Add.Name = aa
    Set xlsheet5 = xlbook.Worksheets(aa)
    If yljk = 0 Then
        xlsheet2.Activate
        xlsheet2.Cells.Select
        xlsheet2.Application.Selection.Copy
    Else
        xlsheet3.Activate
        xlsheet3.Cells.Select
        xlsheet3.Application.Selection.Copy
    End If
    xlsheet5.Select
    xlsheet5.Range("A1").Select
    xlbook.ActiveSheet.Paste
    xlsheet5.Range("A1").Select
End Sub
Function sgzb(bm As String)
    Dim a
    On Error GoTo nnn
    a = xlbook.Worksheets(bm).Cells(1, 1)
    sgzb = 1
    Exit Function
nnn:
    sgzb = 0
End Function
Sub ymsz()
    Dim ldmc As String
    ldmc = InputBox("请输入路段名称：")
    Do While ldmc = ""
       ldmc = InputBox("请重新输入工作表名：")
    Loop
    ldmc = "              " & ldmc
    With xlbook.ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$6"
        .PrintTitleColumns = ""
    End With
       With xlbook.ActiveSheet.PageSetup
        .LeftHeader = Chr(10) & Chr(10) & ldmc
        .CenterHeader = "&20路面工程数量表"
        .RightHeader = _
        "&""Times New Roman,常规""" & Chr(10) & "" & Chr(10) & "&""宋体,常规""第&""Times New Roman,常规""&P&""宋体,常规""页 共&N页                  ."
        .LeftFooter = _
        "&""Times New Roman,常规""                               &""宋体,常规""编制："
        .CenterFooter = "复核："
        .RightFooter = _
        "审核：          &""Times New Roman,常规""          &""宋体,常规""         &""Times New Roman,常规""."
        .LeftMargin = Application.InchesToPoints(1.37795275590551)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(1.18110236220472)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.590551181102362)
        .FooterMargin = Application.InchesToPoints(0.590551181102362)
        .Orientation = xlLandscape
        .PaperSize = xlPaperA3
       End With
End Sub

Sub zjbgk(yljk As Single)