form1.frm

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

Attribute VB_Exposed = False
Public JType As Integer
Public X1 As Integer
Public Line2 As Integer
Public CS As Integer  '循环次数


Private Sub Command1_Click()
On Error Resume Next
Dim File1 As String
Dim LineIn As String
filenum = FreeFile
CD1.DialogTitle = "打开1#隧洞泄流能力文件"
CD1.Filter = "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"
CD1.ShowOpen
TextQH(1).Text = CD1.FileName
If CD1.FileName <> "" Then

    File1 = CD1.FileName
    List1.Clear
    Open File1 For Input As #filenum
    Do While Not EOF(filenum)
        Line Input #filenum, LineIn
        List1.AddItem LineIn
        X1 = X1 + 1
    Loop
    Close #filenum
Else
    Exit Sub
End If
End Sub

Private Sub Command2_Click()
On Error Resume Next
Dim File2 As String
Dim LineIn As String
filenum = FreeFile
CD2.DialogTitle = "打开2#隧洞泄流能力文件"
CD2.Filter = "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"
CD2.ShowOpen
TextQH(2).Text = CD2.FileName
If CD2.FileName <> "" Then
    File2 = CD2.FileName
    List2.Clear
    Open File2 For Input As #filenum
    Do While Not EOF(filenum)
        Line Input #filenum, LineIn
        List2.AddItem LineIn
        Line2 = Line2 + 1
    Loop
Else
    Exit Sub
End If
Close #filenum
End Sub

Private Sub Command3_Click()
On Error Resume Next
'读入文件并保存在数组中
Dim H, H1, H2 As Single
Dim Q, Q1, Q2, QZ As Single
Dim K1, K2 As Single
Dim WC As Single
Dim QH1(), QH2(), QH3() As Single
Dim Lenth As Integer
Dim LineString As String
Dim WZ As Integer
WC = Val(TextWC.Text)
Dim File1, File2 As String
File1 = TextQH(1).Text
File2 = TextQH(2).Text

'重新定义数组
ReDim QH1(X1, 2)
ReDim QH2(Line2, 2)
'赋值
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
Open File2 For Input As #2
For i = 1 To Line2
    Line Input #2, LineString
    Lenth = Len(LineString)
    WZ = InStr(1, LineString, ",")
    QH2(i, 0) = Left(LineString, WZ - 1)
    QH2(i, 1) = Mid(LineString, WZ + 1, Lenth - WZ)
Next i
Close #2
'分别计算
'计算类型为单值计算时
If JType = 1 Then
    '简单的输入检查
    If TextQH(1).Text = "" Or TextQH(2).Text = "" Or TextQ.Text = "" Or TextWC.Text = "" Then
    Dim ret1 As VbMsgBoxResult
    ret1 = MsgBox("您还有必需的数据没有输入", vbInformation, "提示")
    Exit Sub
    End If
    H = 0
    Q = Val(TextQ.Text)
    Q1 = Q / 2
    Q2 = Q / 2
    For i = 1 To X1 - 1
        If Q1 >= Val(QH1(i, 0)) And Q1 <= Val(QH1(i + 1, 0)) Then
            K1 = (QH1(i + 1, 1) - QH1(i, 1)) / (QH1(i + 1, 0) - QH1(i, 0))
            H1 = K1 * (Q1 - QH1(i, 0)) + QH1(i, 1)
            Exit For
        End If
    Next i
    For i = 1 To Line2 - 1
        If Q2 >= Val(QH2(i, 0)) And Q2 <= Val(QH2(i + 1, 0)) Then
            K2 = (QH2(i + 1, 1) - QH2(i, 1)) / (QH2(i + 1, 0) - QH2(i, 0))
            H2 = K2 * (Q2 - QH2(i, 0)) + QH2(i, 1)
            Exit For
        End If
    Next i
    Do While (Abs(H2 - H1) > WC)
        If H2 > H1 Then
            Q2 = Q2 - 0.5
            Q1 = Q1 + 0.5
        ElseIf H1 > H2 Then
            Q2 = Q2 + 0.5
            Q1 = Q1 - 0.5
        End If
        For i = 1 To X1 - 1
        If Q1 >= Val(QH1(i, 0)) And Q1 <= Val(QH1(i + 1, 0)) Then
            K1 = (QH1(i + 1, 1) - QH1(i, 1)) / (QH1(i + 1, 0) - QH1(i, 0))
            H1 = K1 * (Q1 - QH1(i, 0)) + QH1(i, 1)
            Exit For
        End If
        Next i
        For i = 1 To Line2 - 1
        If Q2 >= Val(QH2(i, 0)) And Q2 <= Val(QH2(i + 1, 0)) Then
            K2 = (QH2(i + 1, 1) - QH2(i, 1)) / (QH2(i + 1, 0) - QH2(i, 0))
            H2 = K2 * (Q2 - QH2(i, 0)) + QH2(i, 1)
            Exit For
        End If
        Next i
    Loop
    H = (H1 + H2) / 2
    WZ = InStr(1, CStr(H), ".")
    If WZ <> 0 Then
        H = Val(Left(H, WZ + 3))
    End If
    TextH.Text = CStr(H)
    OutString = CStr(Q) + "," + CStr(H) + "," + CStr(Q1) + "," + CStr(Q2)
    List3.AddItem (OutString)
'计算类型为自动计算时
ElseIf JType = 2 Then
    '简单的数据检查
    If TextQH(1).Text = "" Or TextQH(2).Text = "" Or TextQ1.Text = "" Or TextQ2.Text = "" Or TextZ.Text = "" Or TextWC.Text = "" Then
    Dim ret2 As VbMsgBoxResult
    ret2 = MsgBox("您还有必需的数据没有输入", vbInformation, "提示")
    Exit Sub
    End If
    H = 0
    Qa = Val(TextQ1.Text)
    Qb = Val(TextQ2.Text)
    QZ = Val(TextZ.Text)
    CS = Int((Qb - Qa) / QZ) + 1
    ReDim QH3(CS, 4)
    For j = 0 To CS - 1
        Q = Qa + j * QZ
        Q1 = Q / 2
        Q2 = Q / 2
        For i = 1 To X1 - 1
            If Q1 >= Val(QH1(i, 0)) And Q1 <= Val(QH1(i + 1, 0)) Then
            K1 = (QH1(i + 1, 1) - QH1(i, 1)) / (QH1(i + 1, 0) - QH1(i, 0))
            H1 = K1 * (Q1 - QH1(i, 0)) + QH1(i, 1)
            Exit For
            End If
        Next i
    For i = 1 To Line2 - 1
        If Q2 >= Val(QH2(i, 0)) And Q2 <= Val(QH2(i + 1, 0)) Then
            K2 = (QH2(i + 1, 1) - QH2(i, 1)) / (QH2(i + 1, 0) - QH2(i, 0))
            H2 = K2 * (Q2 - QH2(i, 0)) + QH2(i, 1)
            Exit For
        End If
    Next i
    Do While (Abs(H2 - H1) > WC)
        If H2 > H1 Then
            Q2 = Q2 - 0.5
            Q1 = Q1 + 0.5
        ElseIf H1 > H2 Then
            Q2 = Q2 + 0.5
            Q1 = Q1 - 0.5
        End If
        For i = 1 To X1 - 1
        If Q1 >= Val(QH1(i, 0)) And Q1 <= Val(QH1(i + 1, 0)) Then
            K1 = (QH1(i + 1, 1) - QH1(i, 1)) / (QH1(i + 1, 0) - QH1(i, 0))
            H1 = K1 * (Q1 - QH1(i, 0)) + QH1(i, 1)
            Exit For
        End If
        Next i
        For i = 1 To Line2 - 1
        If Q2 >= Val(QH2(i, 0)) And Q2 <= Val(QH2(i + 1, 0)) Then
            K2 = (QH2(i + 1, 1) - QH2(i, 1)) / (QH2(i + 1, 0) - QH2(i, 0))
            H2 = K2 * (Q2 - QH2(i, 0)) + QH2(i, 1)
            Exit For
        End If
        Next i
    Loop
    H = (H1 + H2) / 2
        QH3(j, 0) = Q
        
        WZ = InStr(1, CStr(H), ".")
        If WZ <> 0 Then
            H = Val(Left(H, WZ + 3))
        End If
        QH3(j, 1) = H
        

        QH3(j, 2) = Q1
        
   
        QH3(j, 3) = Q2
        
        OutString = CStr(Q) + "," + CStr(H) + "," + CStr(Q1) + "," + CStr(Q2)
        List3.AddItem (OutString)
    Next j
    Dim File4 As String
    File4 = App.Path
    If Right(File4, 1) = "\" Then
        File4 = File4 + "XL.txt"
    Else
        File4 = File4 + "\XL.txt"
    End If
    Open File4 For Output As #10
    Write #10, "流量    水位"
    For k = 0 To CS - 1
        'Write #10, vbCrLf
        Write #10, QH3(k, 0), QH3(k, 1)
        'Write #10, Space(4)
        'Write #10, QH3(k, 1)
    
    Next k
Close #10
End If
End Sub

Private Sub Command4_Click()
On Error Resume Next
Dim QH3() As Single
If List3.ListCount = 0 Then
    Dim ret3 As VbMsgBoxResult
    ret3 = MsgBox("没有数据需要保存，请先计算！", vbInformation, "提示")
    Exit Sub
End If
CDSave.DialogTitle = "保存计算结果"
CDSave.Filter = "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"
CDSave.ShowSave
filenum = FreeFile
If CDSave.FileName <> "" Then
    File3 = CDSave.FileName
    Open File3 For Output As #filenum
    Write #filenum, "流量 水位 1#流量 2#流量"
    For i = 0 To List3.ListCount - 1
        Print #filenum, List3.List(i)
    Next i
    Close #filenum
Else
    Exit Sub
End If

End Sub

Private Sub Command5_Click()
List1.Clear
List2.Clear
List3.Clear
TextQH(1).Text = ""
TextQH(2).Text = ""
TextQ.Text = ""
TextQ1.Text = ""
TextQ2.Text = ""
TextZ.Text = ""
TextH.Text = ""

End Sub

Private Sub Command6_Click()
Dim ret As VbMsgBoxResult
ret = MsgBox("确实要退出吗？", vbYesNo, "注意保存结果")
If ret = vbYes Then
    End
Else
    Exit Sub
End If
End Sub

Private Sub Form_Load()
JType = 1
   
End Sub

Private Sub Option1_Click(Index As Integer)
If Option1(1).Value = True Then
    TextQ1.Enabled = True
    TextQ2.Enabled = True
    TextZ.Enabled = True
    TextQ1.BackColor = vbWhite
    TextQ2.BackColor = vbWhite
    TextZ.BackColor = vbWhite
    TextQ.Enabled = False
    TextQ.Text = ""
    TextQ.BackColor = &H8000000F
    TextH.Text = ""
    TextH.BackColor = &H8000000F
    JType = 2
ElseIf Option1(0).Value = True Then
    TextQ1.Enabled = False
    TextQ2.Enabled = False
    TextZ.Enabled = False
    TextQ1.Text = ""
    TextQ2.Text = ""
    TextZ.Text = ""
    TextQ1.BackColor = &H8000000F
    TextQ2.BackColor = &H8000000F
    TextZ.BackColor = &H8000000F
    TextQ.Enabled = True
    TextQ.BackColor = vbWhite
    TextH.BackColor = vbWhite
    JType = 1
End If
End Sub