first.frm

单戗堤截流图解法计算程序使用帮助 操作步骤： 一：输入分流能力数据文本文件 文件格式为上游水位

H1 = H2 = H15 = 0#
Kill = 0
CmdDraw.Enabled = True
Dim ret1, ret2 As VbMsgBoxResult
'重新定义数组
ReDim QH1(X1, 2)
If File1 = "" Then
    ret1 = MsgBox("您还有必需的数据没有输入", vbInformation, "提示")
    Exit Sub
End If

'赋值 分流能力数组
Open File1 For Input As #1
For i = 1 To X1
    Line Input #1, LineString
    Lenth = Len(LineString)
    WZ = InStr(1, LineString, ",")
    QH1(i, 0) = Left(LineString, WZ - 1)
    QH1(i, 1) = Mid(LineString, WZ + 1, Lenth - WZ)
Next i
Close #1
LbMsg.Caption = "即时提示：正在进行计算……"

'分别计算
'/////////////////////////////////////////////////////////////
'计算类型为单值计算时
If JType = 1 Then
    '简单的输入检查
    If TextB.Text = "" Or TextQ.Text = "" Or TextHx.Text = "" Or TextWC.Text = "" Then
        ret1 = MsgBox("您还有必需的数据没有输入", vbInformation, "提示")
        Exit Sub
    End If
    '赋计算参数
    LbMsg.Caption = "即时提示：正在进行赋值"
    Q = Val(TextQ.Text) '截流设计流量
    Hx = Val(TextHx.Text) '下游水位
    B = Val(TextB.Text) '龙口平均宽度
    WC = Val(TextWC.Text) '误差
    Hd = Val(TextHd.Text) '河底高程
    Hdd = Val(TextHdd.Text) '堤顶高程
    Hhd = Val(TextHhd.Text) '护坡厚度
    Bp = Val(Text1.Text) / Val(Text2.Text) '边坡
    BLJ = (Hdd - Hd - Hhd) / Bp '临界平均宽度
    LbMsg.Caption = "即时提示：正在进行数据检查"
    '数据检查
    Check (TextB.Text)
    Check (TextQ.Text)
    Check (TextHx.Text)
    Check (TextWC.Text)
    Check (TextHd.Text)
    Check (TextHdd.Text)
    Check (TextHhd.Text)
    Check (Bp)
    If BeErr = True Then
        ret3 = MsgBox("请检查您所输入的数据的合理性，再选择计算。", vbInformation, "友好提示")
        Exit Sub
    End If
    LbMsg.Caption = "即时提示：正在执行计算，请稍候……"
     '生成数组QH2()并输出
    If TextM.Text = "" Then
        M = 0.35 '设定流量系数
    Else
        M = Val(TextM.Text)
    End If
    Line2 = (Hdd - Hjz) * 10 + 2
    ReDim QH2(Line2, 2)
    j = 0
    List2.Clear
    OutString = "龙口平均宽度B=" + CStr(B) + "米"
    List2.AddItem OutString
    QH2(j, 0) = Hjz
    QH2(j, 1) = 0
    OutString = CStr(QH2(j, 0)) + ", " + CStr(QH2(j, 1))
    List2.AddItem OutString
    j = 1
    'Hjz为基准高程
    For i = Int(Hjz) + 1 To Int(Hdd) Step 0.1
        QH2(j, 0) = i
        QH2(j, 1) = M * B * 19.6 ^ 0.5 * (i - Hjz) ^ 1.5
        WZ = InStr(1, CStr(QH2(j, 1)), ".")
        If WZ <> 0 Then
            QH2(j, 1) = Val(Left(QH2(j, 1), WZ + 3))
        End If
        OutString = CStr(QH2(j, 0)) + ", " + CStr(QH2(j, 1))
        List2.AddItem OutString
        j = j + 1
    Next i
    QH2(j, 0) = Hdd
    QH2(j, 1) = M * B * 19.6 ^ 0.5 * (Hdd - Hjz) ^ 1.5
    WZ = InStr(1, CStr(QH2(j, 1)), ".")
        If WZ <> 0 Then
            QH2(j, 1) = Val(Left(QH2(j, 1), WZ + 3))
        End If
    OutString = CStr(QH2(j, 0)) + ", " + CStr(QH2(j, 1))
    List2.AddItem OutString
    '假设三角形断面时为淹没流，计算临界宽度BLJ
    Hjz = Hd + Hhd
    Hs = Hx - Hjz
    BLJ = Hs / Bp
    H = Hs / 0.7 + Hd
    If H < Val(QH1(1, 0)) Then
    Q1 = 0
Else
    For i = 1 To X1 - 1
        If H >= Val(QH1(i, 0)) And H <= Val(QH1(i + 1, 0)) Then
            K1 = (QH1(i + 1, 1) - QH1(i, 1)) / (QH1(i + 1, 0) - QH1(i, 0))
            Q1 = K1 * (H - QH1(i, 0)) + QH1(i, 1)
            Exit For
        End If
    Next i
End If
    For i = 0 To Line2 - 1
        If H >= Val(QH2(i, 0)) And H <= Val(QH2(i + 1, 0)) Then
            K2 = (QH2(i + 1, 1) - QH2(i, 1)) / (QH2(i + 1, 0) - QH2(i, 0))
            Q2 = K2 * (H - QH2(i, 0)) + QH2(i, 1)
            Exit For
        End If
    Next i
    QX = Q1 + Q2
    If QX >= Q Then
        BLJ = Hs / Bp
    Else
        Hlk = 0
    End If
    '判断断面形式 BZ为淹没标准/////////////////////////////
    If B > BLJ Then '梯形断面
        Hjz = Hd + Hhd
        BZ = 0.6
    ElseIf B = BLJ Then '临界断面
        Hjz = Hd + Hhd
        BZ = 0.7
    Else '三角形断面
        Hjz = Hd + Hhd + ((Hdd - Hd - Hhd) / Bp - B) * Bp
        BZ = 0.8
    End If
    Hs = Hx - Hjz '下游水深
'记录本次计算参数
If Right(App.Path, 1) = "\" Then
    Path1 = App.Path
Else
    Path1 = App.Path + "\"
End If
Open Path1 + "last.txt" For Output As 11#
OutStr2 = TextQ.Text + "#" + TextHhd.Text + "#" + TextM.Text + "#" + TextHx.Text + "#" + TextHdd.Text + "#" + TextHd.Text + "#" + Text1.Text + "#" + Text2.Text
Print #11, OutStr2
Close 11#
   
    '二分法计算上游水位H
'//////////////////////////////////////
'龙口宽度为0时，单独计算
If B = 0 Then
    Q2 = 0
    Q1 = Q - Q2
    '计算上游水位H1
    For i = 1 To X1 - 1
    If Q1 >= Val(QH1(i, 1)) And Q1 <= Val(QH1(i + 1, 1)) Then
        K1 = (QH1(i + 1, 0) - QH1(i, 0)) / (QH1(i + 1, 1) - QH1(i, 1))
        H1 = K1 * (Q1 - QH1(i, 1)) + QH1(i, 0)
        Exit For
    End If
    Next i
    Z1 = H1 - Hx '落差
    V = 0
    DkQ = 0
    N = 0
    '输出结果
    TextOUT.Text = CStr(H1)
    TextV.Text = CStr(V)
    WZ = InStr(1, CStr(H1), ".")
    If WZ <> 0 Then
        H1 = Val(Left(H1, WZ + 3))
    End If
    WZ = InStr(1, CStr(Z1), ".")
    If WZ <> 0 Then
        Z1 = Val(Left(Z1, WZ + 3))
    End If
    WZ = InStr(1, CStr(N), ".")
    If WZ <> 0 Then
       N = Val(Left(N, WZ + 3))
    End If
    WZ = InStr(1, CStr(DkQ), ".")
    If WZ <> 0 Then
       DkQ = Val(Left(DkQ, WZ + 3))
    End If
    OutString = CStr(B) + ", " + CStr(H1) + ", " + CStr(Q2) + ", " + CStr(V) + ", " + CStr(DkQ) + ", " + CStr(Z1) + ", " + CStr(N)
    List3.AddItem (OutString)
Else
'///////////////////////////////////////
'龙口宽度不为0时
    H1 = Hjz
    H2 = Hdd
    H15 = (H1 + H2) / 2
    '计算Q1
If H1 < Val(QH1(1, 0)) Then
    Q11 = 0
Else
    For i = 1 To X1 - 1
        If H1 >= Val(QH1(i, 0)) And H1 <= Val(QH1(i + 1, 0)) Then
            K1 = (QH1(i + 1, 1) - QH1(i, 1)) / (QH1(i + 1, 0) - QH1(i, 0))
            Q11 = K1 * (H1 - QH1(i, 0)) + QH1(i, 1)
            Exit For
        End If
    Next i
End If
    For i = 0 To Line2 - 1
        If H1 >= Val(QH2(i, 0)) And H1 <= Val(QH2(i + 1, 0)) Then
            K2 = (QH2(i + 1, 1) - QH2(i, 1)) / (QH2(i + 1, 0) - QH2(i, 0))
            Q12 = K2 * (H1 - QH2(i, 0)) + QH2(i, 1)
            Exit For
        End If
    Next i
    Q1 = Q11 + Q12

    '计算Q2
If H2 < Val(QH1(1, 0)) Then
    Q21 = 0
Else
    For i = 1 To X1 - 1
        If H2 >= Val(QH1(i, 0)) And H2 <= Val(QH1(i + 1, 0)) Then
            K1 = (QH1(i + 1, 1) - QH1(i, 1)) / (QH1(i + 1, 0) - QH1(i, 0))
            Q21 = K1 * (H2 - QH1(i, 0)) + QH1(i, 1)
            Exit For
        End If
    Next i
End If
    For i = 1 To Line2 - 1
        If H2 >= Val(QH2(i, 0)) And H2 <= Val(QH2(i + 1, 0)) Then
            K2 = (QH2(i + 1, 1) - QH2(i, 1)) / (QH2(i + 1, 0) - QH2(i, 0))
            Q22 = K2 * (H2 - QH2(i, 0)) + QH2(i, 1)
            Exit For
        End If
    Next i
    Q2 = Q21 + Q22

    '计算Q15
If H15 < Val(QH1(1, 0)) Then
    Q151 = 0
Else
    For i = 1 To X1 - 1
        If H15 >= Val(QH1(i, 0)) And H15 <= Val(QH1(i + 1, 0)) Then
            K1 = (QH1(i + 1, 1) - QH1(i, 1)) / (QH1(i + 1, 0) - QH1(i, 0))
            Q151 = K1 * (H15 - QH1(i, 0)) + QH1(i, 1)
            Exit For
        End If
    Next i
End If
    For i = 0 To Line2 - 1
        If H15 >= Val(QH2(i, 0)) And H15 <= Val(QH2(i + 1, 0)) Then
            K2 = (QH2(i + 1, 1) - QH2(i, 1)) / (QH2(i + 1, 0) - QH2(i, 0))
            Q152 = K2 * (H15 - QH2(i, 0)) + QH2(i, 1)
            Exit For
        End If
    Next i
    Q15 = Q151 + Q152

    '判断是否求出解
    If Abs(Q1 - Q) <= WC Then
        H = H1
        TextOUT.Text = H
        Exit Sub
    End If
    If Abs(Q2 - Q) <= WC Then
        H = H2
        TextOUT.Text = H
        Exit Sub
    End If
        If Abs(Q15 - Q) <= WC Then
        H = H15
        TextOUT.Text = H
        Exit Sub
    End If
    '//////////////////////////////////
    '未计算出结果开始循环
Do While Abs(Q15 - Q) > WC
    If Sgn(Q15 - Q) = Sgn(Q2 - Q) Then
        H2 = H15
    Else
        H1 = H15
    End If
    H15 = (H1 + H2) / 2
LbMsg.Caption = "即时提示：正在计算，请耐心等候……"
Kill = Kill + 1 '防止程序不响应
If Kill > 20000 Then
    retkill = MsgBox("无法计算结果，请检查数据或调整误差", vbInformation, "友好提示")
    Kill = 0
    Exit Sub
End If

    '计算Q1
If H1 < Val(QH1(1, 0)) Then
    Q11 = 0
Else
    For i = 1 To X1 - 1
        If H1 >= Val(QH1(i, 0)) And H1 <= Val(QH1(i + 1, 0)) Then
            K1 = (QH1(i + 1, 1) - QH1(i, 1)) / (QH1(i + 1, 0) - QH1(i, 0))
            Q11 = K1 * (H1 - QH1(i, 0)) + QH1(i, 1)
            Exit For
        End If
    Next i
End If
    For i = 0 To Line2 - 1
        If H1 >= Val(QH2(i, 0)) And H1 <= Val(QH2(i + 1, 0)) Then
            K2 = (QH2(i + 1, 1) - QH2(i, 1)) / (QH2(i + 1, 0) - QH2(i, 0))
            Q12 = K2 * (H1 - QH2(i, 0)) + QH2(i, 1)
            Exit For
        End If
    Next i
    Q1 = Q11 + Q12

    '计算Q2
If H2 < Val(QH1(1, 0)) Then
    Q21 = 0
Else
    For i = 1 To X1 - 1
        If H2 >= Val(QH1(i, 0)) And H2 <= Val(QH1(i + 1, 0)) Then
            K1 = (QH1(i + 1, 1) - QH1(i, 1)) / (QH1(i + 1, 0) - QH1(i, 0))
            Q21 = K1 * (H2 - QH1(i, 0)) + QH1(i, 1)
            Exit For
        End If
    Next i
End If
    For i = 0 To Line2 - 1
        If H2 >= Val(QH2(i, 0)) And H2 <= Val(QH2(i + 1, 0)) Then
            K2 = (QH2(i + 1, 1) - QH2(i, 1)) / (QH2(i + 1, 0) - QH2(i, 0))
            Q22 = K2 * (H2 - QH2(i, 0)) + QH2(i, 1)
            Exit For
        End If
    Next i
    Q2 = Q21 + Q22
    
    '计算Q15
If H15 < Val(QH1(1, 0)) Then
    Q151 = 0
Else
    For i = 1 To X1 - 1
        If H15 >= Val(QH1(i, 0)) And H15 <= Val(QH1(i + 1, 0)) Then
            K1 = (QH1(i + 1, 1) - QH1(i, 1)) / (QH1(i + 1, 0) - QH1(i, 0))
            Q151 = K1 * (H15 - QH1(i, 0)) + QH1(i, 1)
            Exit For
        End If
    Next i
End If
    For i = 0 To Line2 - 1
        If H15 >= Val(QH2(i, 0)) And H15 <= Val(QH2(i + 1, 0)) Then
            K2 = (QH2(i + 1, 1) - QH2(i, 1)) / (QH2(i + 1, 0) - QH2(i, 0))
            Q152 = K2 * (H15 - QH2(i, 0)) + QH2(i, 1)
            Exit For
        End If
    Next i
    Q15 = Q151 + Q152
Loop
LbMsg.Caption = "即时提示：计算完毕"
    H = H15
    '求龙口水深Hlk
    If (Hx - Hjz) / (H - Hjz) > BZ Then
        Hlk = Hx - Hjz '淹没时
    Else
        Hlk = FHK(B, Q152, Bp, 0.01) '非淹没时
    End If
    '求龙口平均流速V
    V = Q152 / (B * Hlk)
    '数据小数位数处理
    WZ = InStr(1, CStr(H), ".")
    If WZ <> 0 Then
        H = Val(Left(H, WZ + 3))
    End If
    WZ = InStr(1, CStr(Q152), ".")
    If WZ <> 0 Then
        Q152 = Val(Left(Q152, WZ + 3))
    End If
    WZ = InStr(1, CStr(V), ".")
    If WZ <> 0 Then
        V = Val(Left(V, WZ + 3))
    End If
    '输出结果
    TextOUT.Text = CStr(H)
    TextV.Text = CStr(V)
    DkQ = Q152 / B
    Z1 = H - Hx
    If Z1 < 0 Then
        Z1 = 0
    End If
    N = 1# * 9.8 * Z1
    '对Z1进行处理
    Z1 = CStr(Z1)
    If Right(CStr(Z1), 4) = "E-01" Then
       WZ = InStr(1, CStr(Z1), ".")
        If WZ <> 0 Then
            Z1 = Val(Left(Z1, WZ + 3))
        End If
        Z1 = Z1 / 10
    ElseIf Right(CStr(Z1), 4) = "E-02" Then
       WZ = InStr(1, CStr(Z1), ".")
        If WZ <> 0 Then
            Z1 = Val(Left(Z1, WZ + 3))
        End If
        Z1 = Z1 / 100
    ElseIf Right(CStr(Z1), 4) = "E-03" Then
       WZ = InStr(1, CStr(Z1), ".")
        If WZ <> 0 Then
            Z1 = Val(Left(Z1, WZ + 3))
        End If
        Z1 = Z1 / 1000
    Else
        WZ = InStr(1, CStr(Z1), ".")
        If WZ <> 0 Then
            Z1 = Val(Left(Z1, WZ + 3))
        End If
    End If