form_gdword.frm

业余做的水利工程压力管道质检表自生成软件！

End Sub

Public Sub TB2_5(fname As String) '(xcxm() As Integer)'表2.5
    Set tabx = wD.ActiveDocument.Tables(1)
    TB
    '评定意见
    JCJG Val(tbs), 8 + tp, 24, Str$(Int((yhgds / yds * 1000 + 0.5)) / 10)
    Selection.MoveRight Unit:=wdCharacter, Count:=34
    Selection.TypeText Text:=Str$(Int(((zxmy + yxmy) / (zxm + yxm) * 1000 + 0.5)) / 10)
    Selection.MoveRight Unit:=wdCharacter, Count:=16
    Selection.TypeText Text:=Str$(Int((zhgds / zds * 1000 + 0.5)) / 10)
    SaveNewDocument App.Path + "\MG\" + fname + ".doc"
    
End Sub

Private Sub Cmd_AG_Click()
  Dim temp As String
  ReDim xcxm(3, 7)
  JBCS
  For BH = 1 To Val(Text_GCS.Text)
    temp = "第" + LTrim(Str$(BH)) + "段埋管安装"
    dyds = temp + Chr$(13) + "0+100.00～0+200.00"
    OpenDocument App.Path & "\GD-AG2.4.doc" '打开文件
    TB2_41 2
    TB2_42 3
    TB2_43 4
    TB2_44 5
    TB2_4 temp
  Next BH

End Sub

Public Sub TB2_4(fname As String)  '(xcxm() As Integer)'表2.4
    Set tabx = wD.ActiveDocument.Tables(1)
    TB
    '评定意见
    JCJG Val(tbs), 8 + tp, 23, Str$(Int((yhgds / yds * 1000 + 0.5)) / 10)
    Selection.MoveRight Unit:=wdCharacter, Count:=24
    Selection.TypeText Text:=Str$(Int(((zxmy + yxmy) / (zxm + yxm) * 1000 + 0.5)) / 10)
    Selection.MoveRight Unit:=wdCharacter, Count:=16
    Selection.TypeText Text:=Str$(Int((zhgds / zds * 1000 + 0.5)) / 10)
    SaveNewDocument App.Path + "\AG\" + fname + ".doc"
    
End Sub

Public Sub TB2_41(tbs) '表2.4－1
    ReDim xc(15, 2) '1-主要项目 2－一般项目
    Set tabx = wD.ActiveDocument.Tables(tbs)

    TBbt tbs '标题栏
    
    '项目
    If Chk_SZJ.Value Then
        '1、△始装节管口里程
        yxpc = 4 '允许偏差
        xc(0, 0) = 1
        xc(0, 1) = 1
        xc(0, 2) = Scz(xc(0, 0), yxpc, xc(0, 1), 7, 10, tbs)
        '2、△始装节管口中心
        yxpc = 4 '允许偏差
        xc(1, 0) = 1
        xc(1, 1) = 2
        xc(1, 2) = Scz(xc(1, 0), yxpc, xc(1, 1), 8, 10, tbs)
    Else
        xc(0, 0) = 33
        tabx.Cell(7, 10).Range.Text = "/"
        xc(1, 0) = 33
        tabx.Cell(8, 10).Range.Text = "/"
    End If
    
    '3、与蜗壳、蝴蝶阀、球阀、岔管连接的管节及弯管起点的管口中心
    If Chk_SCW.Value Then
        tmp = Val(Text_LJ.Text)
        If tmp < 3 Or tmp = 3 Then
            yxpc = 6 '允许偏差
        ElseIf tmp > 5 Then
            yxpc = 12 '允许偏差
        Else
            yxpc = 10 '允许偏差
        End If
        xc(2, 0) = 2
        xc(2, 1) = 2
        xc(2, 2) = Scz(xc(2, 0), yxpc, xc(2, 1), 9, 10, tbs)
    Else
        xc(2, 0) = 33
        tabx.Cell(9, 10).Range.Text = "/"
    End If
    
    '4、其它部位管节的管口中心
    yxpc = 10 '允许偏差
    xc(3, 0) = 2
    xc(3, 1) = zfs
    xc(3, 2) = Scz(xc(3, 0), yxpc, xc(3, 1), 11, 10, tbs)
    
    '5、△钢管园度
    yxpc = 4 * Val(Text_LJ.Text) '允许偏差
    xc(4, 0) = 1
    xc(4, 1) = zfs
    xc(4, 2) = Scz(xc(4, 0), yxpc, xc(4, 1), 12, 6, tbs)
        
    '6、△纵缝错位
    If Chk_ZF.Value Then
        tmp = Val(Text_HD)
        yxpc = tmp * 0.05
        If tmp < 20 Then
            yxpc = 1
        Else
            If yxpc > 2 Then yxpc = 2
        End If
        xc(5, 0) = 1
        xc(5, 1) = zfs
        xc(5, 2) = Scz(xc(5, 0), yxpc, xc(5, 1), 14, 6, tbs)
    Else
        xc(5, 0) = 33
        tabx.Cell(14, 6).Range.Text = "/"
    End If
        
    '7、△环缝错位
    tmp = Val(Text_HD)
    yxpc = tmp * 0.1
    If tmp < 15 Then
        yxpc = 1.5
    Else
        If yxpc > 3 Then yxpc = 3 '允许偏差
    End If
    xc(6, 0) = 1
    xc(6, 1) = zfs
    xc(6, 2) = Scz(xc(6, 0), yxpc, xc(6, 1), 16, 6, tbs)
  
    For tp = 0 To UBound(xc, 1)
        If xc(tp, 0) = 1 Then zxm = zxm + 1: zds = zds + xc(tp, 1): zhgds = zhgds + xc(tp, 2)
        If xc(tp, 0) = 11 Then zxm = zxm + 1
        If xc(tp, 0) = 2 Then
            yxm = yxm + 1
            yds = yds + xc(tp, 1): yhgds = yhgds + xc(tp, 2)
            If yhgds / yds < 0.9 Then yxmy = yxmy + 1
        End If
        If xc(tp, 0) = 22 Then yxm = yxm + 1
        'xc(tp, 0) = 33 本项不选
    Next tp
    zxmy = zxm
    yxmy = yxm - yxmy

    xcxm(tbs - 2, 0) = zxm: xcxm(tbs - 2, 1) = zxmy: xcxm(tbs - 2, 2) = zds: xcxm(tbs - 2, 3) = zhgds
    xcxm(tbs - 2, 4) = yxm: xcxm(tbs - 2, 5) = yxmy: xcxm(tbs - 2, 6) = yds: xcxm(tbs - 2, 7) = yhgds
    
    '检查结果
    JCJG Val(tbs), 12, 14, Str$(xcxm(tbs - 2, 2)) '表，下移，右移，文本
    Selection.MoveRight Unit:=wdCharacter, Count:=15
    Selection.TypeText Text:=xcxm(tbs - 2, 3)
    Selection.MoveRight Unit:=wdCharacter, Count:=15
    Selection.TypeText Text:=Int(xcxm(tbs - 2, 3) / xcxm(tbs - 2, 2) * 100 + 0.5)
    JCJG Val(tbs), 12, 71, Str$(xcxm(tbs - 2, 6)) '表，下移，右移，文本
    Selection.MoveRight Unit:=wdCharacter, Count:=15
    Selection.TypeText Text:=xcxm(tbs - 2, 7)
    Selection.MoveRight Unit:=wdCharacter, Count:=15
    Selection.TypeText Text:=Int(xcxm(tbs - 2, 7) / xcxm(tbs - 2, 6) * 100 + 0.5)
    '评定意见
    JCJG Val(tbs), 14, 4, Str$(xcxm(tbs - 2, 0))
    Selection.MoveRight Unit:=wdCharacter, Count:=12
    Selection.TypeText Text:=Str$(xcxm(tbs - 2, 1))
    Selection.MoveRight Unit:=wdCharacter, Count:=12
    Selection.TypeText Text:=Str$(xcxm(tbs - 2, 4))
    Selection.MoveRight Unit:=wdCharacter, Count:=12
    Selection.TypeText Text:=Str$(xcxm(tbs - 2, 5))
    
End Sub

Public Sub TB2_42(tbs) '表2.4－2
    ReDim xc(10, 2) '1-主要项目 2－一般项目
    Dim temp As String
    Set tabx = wD.ActiveDocument.Tables(tbs)

    TBbt tbs '标题栏
    
    '项目
    '1、△裂纹
    xc(0, 0) = 11
    tabx.Cell(5, 4).Range.Text = "无裂纹"
    
    '2、△表面夹渣
    xc(1, 0) = 11
    tabx.Cell(6, 4).Range.Text = "无表面夹渣"
    
    '3、△咬边
    xc(2, 0) = 11
    tmp = Int(10 * Rnd * 10) / 10
    If tmp < 1 Then temp = "0" + Trim(Str$(tmp)) Else temp = Str$(tmp)
    tabx.Cell(7, 4).Range.Text = "咬边深度0" + Trim(Str$(Int(0.5 * Rnd * 10) / 10)) + "～0.5,连续长度最大" _
                                 + Str$(Int(100 * Rnd * 10) / 10) + "mm,累计长度为:" + temp + "%全长焊缝"
    
    '4、未焊满
    xc(3, 0) = 22
    tabx.Cell(8, 4).Range.Text = "焊满"
    
    '5、△表面气孔
    xc(4, 0) = 11
    tabx.Cell(9, 5).Range.Text = "表面无气孔"
    
    '6、焊缝余高△h
    xc(5, 0) = 22
    tmp = Int(2 * Rnd * 10) / 10
    If tmp < 1 Then temp = "0" + Trim(Str$(tmp)) Else temp = Str$(tmp)
    tabx.Cell(11, 5).Range.Text = "△h=" + temp + "～2.5"
    
    '7、对接接头焊缝宽度
    xc(6, 0) = 22
    tmp = Int(2 * Rnd * 10) / 10
    If tmp < 1 Then temp = "0" + Trim(Str$(tmp)) Else temp = Str$(tmp)
    tabx.Cell(13, 5).Range.Text = "盖过坡口" + temp + "～4,平缓过渡"
    
    '8、飞溅
    xc(7, 0) = 22
    tabx.Cell(15, 4).Range.Text = "基本清除干净"
    
    '9、焊瘤
    xc(8, 0) = 22
    tabx.Cell(16, 4).Range.Text = "无焊瘤"
    
    '10、角焊缝厚度不足
    If Txt_H.Enabled Then
        xc(9, 0) = 22
        tabx.Cell(17, 4).Range.Text = "角焊缝厚度符合设计规范要求。"
    Else
        xc(9, 0) = 33
        tabx.Cell(17, 4).Range.Text = "/"
    End If
    
    '11、角焊缝焊脚K
    If Txt_H.Enabled Then
        xc(10, 0) = 22
        tabx.Cell(18, 5).Range.Text = "角焊缝焊脚符合设计规范要求。"
    Else
        xc(10, 0) = 33
        tabx.Cell(18, 5).Range.Text = "/"
    End If

    For tp = 0 To UBound(xc, 1)
        If xc(tp, 0) = 1 Then zxm = zxm + 1: zds = zds + xc(tp, 1): zhgds = zhgds + xc(tp, 2)
        If xc(tp, 0) = 11 Then zxm = zxm + 1
        If xc(tp, 0) = 2 Then yxm = yxm + 1: yds = yds + xc(tp, 1): yhgds = yhgds + xc(tp, 2)
        If xc(tp, 0) = 22 Then yxm = yxm + 1
        'xc(tp, 0) = 33 本项不选
    Next tp
    zxmy = zxm
    yxmy = yxm - 1

    xcxm(tbs - 2, 0) = zxm: xcxm(tbs - 2, 1) = zxmy: xcxm(tbs - 2, 2) = zds: xcxm(tbs - 2, 3) = zhgds
    xcxm(tbs - 2, 4) = yxm: xcxm(tbs - 2, 5) = yxmy: xcxm(tbs - 2, 6) = yds: xcxm(tbs - 2, 7) = yhgds

    '检查结果
    JCJG Val(tbs), 15, 13, Str$(xcxm(tbs - 2, 0) + xcxm(tbs - 2, 4))
    Selection.MoveRight Unit:=wdCharacter, Count:=15
    Selection.TypeText Text:=Str$(xcxm(tbs - 2, 0) + xcxm(tbs - 2, 4))
    Selection.MoveRight Unit:=wdCharacter, Count:=15
    Selection.TypeText Text:=Str$(xcxm(tbs - 2, 1) + xcxm(tbs - 2, 5))
    '评定意见
    JCJG Val(tbs), 17, 6, Str$(xcxm(tbs - 2, 0))
    Selection.MoveRight Unit:=wdCharacter, Count:=12
    Selection.TypeText Text:=Str$(xcxm(tbs - 2, 1))
    Selection.MoveRight Unit:=wdCharacter, Count:=10
    Selection.TypeText Text:=Str$(xcxm(tbs - 2, 4))
    Selection.MoveRight Unit:=wdCharacter, Count:=10
    Selection.TypeText Text:=Str$(xcxm(tbs - 2, 4))
    Selection.MoveRight Unit:=wdCharacter, Count:=10
    Selection.TypeText Text:=Str$(xcxm(tbs - 2, 5))
    
End Sub

Public Sub TB2_43(tbs) '表2.4－3
    ReDim xc(5, 2) '1-主要项目 2－一般项目
    Dim temp As String
    Set tabx = wD.ActiveDocument.Tables(tbs)

    TBbt tbs '标题栏
    
    '项目
    '1、△一、二类焊缝X射线透照
    If Opt_X.Value Then
        xc(0, 0) = 11
        tabx.Cell(6, 5).Range.Text = "一次合格率85%"
    Else
        xc(0, 0) = 33
        tabx.Cell(6, 5).Range.Text = "/"
    End If
    
    '2、△一、二类焊缝超声波探伤
    If Opt_Ch.Value Then
        xc(1, 0) = 11
        tabx.Cell(7, 5).Range.Text = "一次合格率95%"
    Else
        xc(1, 0) = 33
        tabx.Cell(7, 5).Range.Text = "/"
    End If
    
    '3、埋管外壁的表面清除
    xc(2, 0) = 22
    tabx.Cell(8, 5).Range.Text = "清除干净并磨光"
    
    '4、埋管外壁局部凹坑焊补
    xc(3, 0) = 22
    tabx.Cell(9, 5).Range.Text = "局部凹坑深度均小于2mm"
    
    '5、埋管内壁的表面清除
    xc(4, 0) = 22
    tabx.Cell(10, 5).Range.Text = "清除干净并磨光"
    
    '6、埋管内壁局部凹坑焊补
    xc(5, 0) = 22
    tabx.Cell(11, 5).Range.Text = "局部凹坑深度均小于2mm"
  
    For tp = 0 To UBound(xc, 1)
        If xc(tp, 0) = 1 Then zxm = zxm + 1: zds = zds + xc(tp, 1): zhgds = zhgds + xc(tp, 2)
        If xc(tp, 0) = 11 Then zxm = zxm + 1
        If xc(tp, 0) = 2 Then yxm = yxm + 1: yds = yds + xc(tp, 1): yhgds = yhgds + xc(tp, 2)
        If xc(tp, 0) = 22 Then yxm = yxm + 1
        'xc(tp, 0) = 33 本项不选
    Next tp
    zxmy = zxm
    yxmy = yxm

    xcxm(tbs - 2, 0) = zxm: xcxm(tbs - 2, 1) = zxmy: xcxm(tbs - 2, 2) = zds: xcxm(tbs - 2, 3) = zhgds
    xcxm(tbs - 2, 4) = yxm: xcxm(tbs - 2, 5) = yxmy: xcxm(tbs - 2, 6) = yds: xcxm(tbs - 2, 7) = yhgds

    '检查结果
    JCJG Val(tbs), 11, 13, Str$(xcxm(tbs - 2, 0)) '主要项目
    Selection.MoveRight Unit:=wdCharacter, Count:=15
    Selection.TypeText Text:=Str$(xcxm(tbs - 2, 0))
    JCJG Val(tbs), 11, 50, Str$(xcxm(tbs - 2, 4)) '一般项目
    Selection.MoveRight Unit:=wdCharacter, Count:=16
    Selection.TypeText Text:=Str$(xcxm(tbs - 2, 4))
    Selection.MoveRight Unit:=wdCharacter, Count:=13
    Selection.TypeText Text:="/"
    '评定意见
    JCJG Val(tbs), 13, 6, Str$(xcxm(tbs - 2, 0))
    Selection.MoveRight Unit:=wdCharacter, Count:=12
    Selection.TypeText Text:=Str$(xcxm(tbs - 2, 0))
    Selection.MoveRight Unit:=wdCharacter, Count:=10
    Selection.TypeText Text:=Str$(xcxm(tbs - 2, 4))
    Selection.MoveRight Unit:=wdCharacter, Count:=12
    Selection.TypeText Text:=Str$(xcxm(tbs - 2, 4))
    
End Sub

Public Sub TB2_44(tbs) '表2.4－4
    ReDim xc(2, 2) '1-主要项目 2－一般项目
    Dim temp As String
    Set tabx = wD.ActiveDocument.Tables(tbs)

    TBbt tbs '标题栏
    
    '项目
    '1、埋管内壁防腐蚀表面处理
    xc(0, 0) = 22
    tabx.Cell(6, 5).Range.Text = "喷吵除锈达到Sa2 1/2标准,表面粗糙度50～70μm"
    
    '2、埋管内壁涂料涂装
    xc(1, 0) = 22
    tabx.Cell(7, 5).Range.Text = "漆膜厚度,外表质量达设计要求,涂层粘附力较强"
    
    '3、灌浆孔堵焊
    If Chk_GJK.Value Then
        xc(2, 0) = 22
        tabx.Cell(8, 4).Range.Text = "表面平整，无裂纹，无渗水"
    Else
        xc(2, 0) = 33
        tabx.Cell(8, 4).Range.Text = "/"
    End If
  
    For tp = 0 To UBound(xc, 1)
        If xc(tp, 0) = 1 Then zxm = zxm + 1: zds = zds + xc(tp, 1): zhgds = zhgds + xc(tp, 2)
        If xc(tp, 0) = 11 Then zxm = zxm + 1
        If xc(tp, 0) = 2 Then yxm = yxm + 1: yds = yds + xc(tp, 1): yhgds = yhgds + xc(tp, 2)
        If xc(tp, 0) = 22 Then yxm = yxm + 1
        'xc(tp, 0) = 33 本项不选
    Next tp
    zxmy = zxm
    yxmy = yxm

    xcxm(tbs - 2, 0) = zxm: xcxm(tbs - 2, 1) = zxmy: xcxm(tbs - 2, 2) = zds: xcxm(tbs - 2, 3) = zhgds
    xcxm(tbs - 2, 4) = yxm: xcxm(tbs - 2, 5) = yxmy: xcxm(tbs - 2, 6) = yds: xcxm(tbs - 2, 7) = yhgds

    '检查结果
    JCJG Val(tbs), 8, 10, Str$(xcxm(tbs - 2, 4))
    Selection.MoveRight Unit:=wdCharacter, Count:=10
    Selection.TypeText Text:=Str$(xcxm(tbs - 2, 4))
    Selection.MoveRight Unit:=wdCharacter, Count:=10
    Selection.TypeText Text:="/"
    '评定意见
    JCJG Val(tbs), 10, 8, Str$(xcxm(tbs - 2, 4))
    Selection.MoveRight Unit:=wdCharacter, Count:=12
    Selection.TypeText Text:=Str$(xcxm(tbs - 2, 5))
    
End Sub

Public Sub TB2_51(tbs)
    ReDim xc(15, 2) '1-主要项目 2－一般项目
    Set tabx = wD.ActiveDocument.Tables(tbs)

    TBbt tbs '标题栏

    '项目
    If Chk_SZJ.Value Then
        '1、△始装节管口里程
        yxpc = 4 '允许偏差
        xc(0, 0) = 1