'**********************************************************************************************************
'
'調洪演算雙輔助線法程序 2011.2.13
'
'作者：曉染霜林醉
'QQ：51817
'水利軟件開發研究群：39869071
'水利水電工程施工導截流方案輔助設計系統官方博客：http://www.cnblogs.com/DivClose/
'
'歡迎對源碼進行任何改編，作者不追究任何責任！
'
'***********************************************************************************************************

Public X1, X2, X3 As Integer

Private Sub Form_Load()

??? MakeWindow Me, False
??? imgTitleMaxRestore.Picture = imgTitleMaximize.Picture
??? LoadSkinz Me
??? List1.AddItem ("格式為：時段,來流量")
??? List2.AddItem ("格式為：水位,庫容")
??? List3.AddItem ("格式為：水位,泄流量")
End Sub

'輸入設計洪水過程
Private Sub Cmd1_Click()
On Error Resume Next
Dim File1 As String
Dim LineIn As String
filenum = FreeFile

CD1.DialogTitle = "打開設計洪水過程文件"
CD1.Filter = "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"
CD1.ShowOpen
Text1.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 Cmd2_Click()
On Error Resume Next
Dim File2 As String
Dim LineIn As String
filenum = FreeFile
CD2.DialogTitle = "打開水庫庫容曲線文件"
CD2.Filter = "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"
CD2.ShowOpen
Text2.Text = CD2.FileName
If CD1.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
??????? X2 = X2 + 1
??? Loop
??? Close #filenum
Else
??? Exit Sub
End If
End Sub

'輸入泄流能力曲線
Private Sub Cmd3_Click()
On Error Resume Next
Dim File3 As String
Dim LineIn As String
filenum = FreeFile
CD3.DialogTitle = "打開泄流能力曲線文件"
CD3.Filter = "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"
CD3.ShowOpen
Text3.Text = CD3.FileName
If CD3.FileName <> "" Then

??? File3 = CD3.FileName
??? List3.Clear
??? Open File3 For Input As #filenum
??? Do While Not EOF(filenum)
??????? Line Input #filenum, LineIn
??????? List3.AddItem LineIn
??????? X3 = X3 + 1
??? Loop
??? Close #filenum
Else
??? Exit Sub
End If
End Sub

'調洪演算計算核心代碼
Private Sub Command3_Click()
On Error Resume Next
'讀入文件并保存在數組中
Dim SD As Single? '時段長度
Dim WC, Hu1, Hu2, Z2, H, Q1 As Single
Dim LineString As String

Dim HS(), KR(), XL(), TH(), VTQ1(), VTQ2() As Single
Dim WZ, Lenth As Integer
WC = Val(TextWC.Text)
SD = Int(Val(TextSD.Text)) * 3600
Dim File1, File2, File3, File4 As String
File1 = Text1.Text
File2 = Text2.Text
File3 = Text3.Text
ReDim HS(X1 + 1, 2)
ReDim KR(X2 + 1, 2)
ReDim XL(X3 + 1, 2)
ReDim TH(X1 + 1, 3)
ReDim VTQ1(X1 + 1, 2)
ReDim VTQ2(X1 + 1, 2)
'讀洪水過程數據，保存數據于數組中
Open File1 For Input As #1
For i = 1 To X1
??? Line Input #1, LineString
??? Lenth = Len(LineString)
??? WZ = InStr(1, LineString, ",")
??? HS(i, 0) = Left(LineString, WZ - 1)
??? HS(i, 1) = Mid(LineString, WZ + 1, Lenth - WZ)
Next i
Close #1

'讀水庫庫容曲線并賦值
Open File2 For Input As #2
For i = 1 To X2
??? Line Input #2, LineString
??? Lenth = Len(LineString)
??? WZ = InStr(1, LineString, ",")
??? KR(i, 0) = Left(LineString, WZ - 1)
??? KR(i, 1) = Mid(LineString, WZ + 1, Lenth - WZ)
Next i
Close #2
'讀泄水能力曲線并賦值
Open File3 For Input As #3
For i = 1 To X3
??? Line Input #3, LineString
??? Lenth = Len(LineString)
??? WZ = InStr(1, LineString, ",")
??? XL(i, 0) = Left(LineString, WZ - 1)
??? XL(i, 1) = Mid(LineString, WZ + 1, Lenth - WZ)
Next i
Close #3
'計算起調水位Hu1
Dim VarHu1 As Single
For j = 1 To X3 - 1
??????? If HS(1, 1) >= Val(XL(j, 1)) And HS(1, 1) <= Val(XL(j + 1, 1)) Then
??????????? K = (XL(j + 1, 0) - XL(j, 0)) / (XL(j + 1, 1) - XL(j, 1))
??????????? VarHu1 = K * (HS(1, 1) - XL(j, 1)) + XL(j, 0)
???????????
??????????? Exit For
??????? End If
Next j

'生成數組VTQ1()和VTQ2()
For i = 1 To X2
??? Dim VarH, VarV, VarQ As Single
??? VarH = KR(i, 0)
??? '插值求庫容
??? For j = 1 To X2 - 1
??????? If VarH >= Val(KR(j, 0)) And VarH <= Val(KR(j + 1, 0)) Then
??????????? K = (KR(j + 1, 1) - KR(j, 1)) / (KR(j + 1, 0) - KR(j, 0))
??????????? VarV = K * (VarH - KR(j, 0)) + KR(j, 1)
??????????? Exit For
??????? End If
??? Next j
??? '插值求泄流量
??? For j = 1 To X3 - 1
??????? If VarH >= Val(XL(j, 0)) And VarH <= Val(XL(j + 1, 0)) Then
??????????? K = (XL(j + 1, 1) - XL(j, 1)) / (XL(j + 1, 0) - XL(j, 0))
??????????? VarQ = K * (VarH - XL(j, 0)) + XL(j, 1)
??????????? Exit For
??????? End If
??? Next j
??? '賦值到VTQ1()和VTQ2()
??? VarV = VarV * 10000 / SD
??? VarQ = VarQ / 2
??? VTQ1(i, 0) = VarH
??? VTQ1(i, 1) = VarV - VarQ
??? VTQ2(i, 0) = VarH
??? VTQ2(i, 1) = VarV + VarQ
Next i
'輸出數組VTQ1()和VTQ2()到文件
filenum = FreeFile
If Right(App.Path, 1) = "\" Then
??? File1 = App.Path + "pyeVTQ1.txt"
??? File2 = App.Path + "pyeVTQ2.txt"
Else
??? File1 = App.Path + "\pyeVTQ1.txt"
??? File2 = App.Path + "\pyeVTQ2.txt"
End If
??? Open File1 For Output As #filenum
??? Write #filenum, "時段 VTQ1"
??? For i = 1 To X2
??????? Write #filenum, Val(VTQ1(i, 0)), Val(VTQ1(i, 1))
??? Next i
??? Close #filenum
??? filenum = FreeFile
??? Open File2 For Output As #filenum
??? Write #filenum, "時段 VTQ2"
??? For i = 1 To X2
??????? Write #filenum, Val(VTQ2(i, 0)), Val(VTQ2(i, 1))
??? Next i
??? Close #filenum
'開始調洪演算，雙輔助線法計算
'賦初值
If TextHu1.Text = "" Then
??? Hu1 = VarHu1
Else
??? Hu1 = Val(TextHu1.Text)
End If
TH(1, 0) = 1
TH(1, 1) = Hu1
??? For j = 1 To X3 - 1
??????? If Hu1 >= Val(XL(j, 0)) And Hu1 <= Val(XL(j + 1, 0)) Then
??????????? K = (XL(j + 1, 1) - XL(j, 1)) / (XL(j + 1, 0) - XL(j, 0))
??????????? VarQ = K * (Hu1 - XL(j, 0)) + XL(j, 1)
??????????? Exit For
??????? End If
??? Next j
TH(1, 2) = VarQ
OutString = "時段??? 上游水位??? 下泄流量"
List4.AddItem (OutString)
OutString = CStr(TH(1, 0)) + " , " + CStr(TH(1, 1)) + " , " + CStr(TH(1, 2))
List4.AddItem (OutString)
Dim IPJ, VarVTQ1, VarVTQ2, VarHu2 As Single
'循環計算
For i = 2 To X1
??? TH(i, 0) = i
??? IPJ = (Val(HS(i, 1)) + Val(HS(i - 1, 1))) / 2 '平均入流量
??? For j = 1 To X2 - 1
??????? If TH(i - 1, 1) >= Val(VTQ1(j, 0)) And TH(i - 1, 1) <= Val(VTQ1(j + 1, 0)) Then
??????????? K = (VTQ1(j + 1, 1) - VTQ1(j, 1)) / (VTQ1(j + 1, 0) - VTQ1(j, 0))
??????????? VarVTQ1 = K * (TH(i - 1, 1) - VTQ1(j, 0)) + VTQ1(j, 1)
??????????? Exit For
??????? End If
??? Next j
??? VarVTQ2 = IPJ + VarVTQ1
??? For j = 1 To X2 - 1
??????? If VarVTQ2 >= Val(VTQ2(j, 1)) And VarVTQ2 <= Val(VTQ2(j + 1, 1)) Then
??????????? K = (VTQ2(j + 1, 0) - VTQ2(j, 0)) / (VTQ2(j + 1, 1) - VTQ2(j, 1))
??????????? VarHu2 = K * (VarVTQ2 - VTQ2(j, 1)) + VTQ2(j, 0)
??????????? Exit For
??????? End If
??? Next j
??? TH(i, 1) = VarHu2
??? For j = 1 To X3 - 1
??????? If VarHu2 >= Val(XL(j, 0)) And VarHu2 <= Val(XL(j + 1, 0)) Then
??????????? K = (XL(j + 1, 1) - XL(j, 1)) / (XL(j + 1, 0) - XL(j, 0))
??????????? VarQ = K * (VarHu2 - XL(j, 0)) + XL(j, 1)
??????????? Exit For
??????? End If
??? Next j
??? TH(i, 2) = VarQ
??? WZ = InStr(1, CStr(TH(i, 1)), ".")
??? If WZ <> 0 Then
??????? TH(i, 1) = Val(Left(TH(i, 1), WZ + 2))
??? End If
??? WZ = InStr(1, CStr(TH(i, 2)), ".")
??? If WZ <> 0 Then
??????? TH(i, 2) = Val(Left(TH(i, 2), WZ + 2))
??? End If
??? OutString = CStr(TH(i, 0)) + " , " + CStr(TH(i, 1)) + " , " + CStr(TH(i, 2))
??? List4.AddItem (OutString)
Next i

End Sub

'保存計算結果
Private Sub Command4_Click()
If List4.ListCount = 0 Then
??? Dim ret4 As VbMsgBoxResult
??? ret4 = MsgBox("沒有數據需要保存，請先計算！", vbInformation, "提示")
??? Exit Sub
End If
CDSave.DialogTitle = "保存計算結果"
CDSave.Filter = "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"
CDSave.ShowSave
filenum = FreeFile
If CDSave.FileName <> "" Then
??? File4 = CDSave.FileName
??? Open File4 For Output As #filenum
??? Write #filenum, "時段 上游水位 下泄流量"
??? For i = 1 To List4.ListCount - 1
??????? OUT = Split(List4.List(i), ",")
??????? Write #filenum, Val(OUT(0)), Val(OUT(1)), Val(OUT(2))
??? Next i
??? Close #filenum
??? ret4 = MsgBox("結果保存完畢！", vbInformation, "提示")
??? Exit Sub
Else
??? Exit Sub
End If
End Sub

'清空數據
Private Sub Command5_Click()
List1.Clear
List2.Clear
List3.Clear
List4.Clear
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
TextHu1.Text = ""
End Sub

Private Sub Command6_Click()
Mbox "確實要退出嗎？", vbInformation, "注意保存結果"

End Sub

'界面部分代碼（開始）
Private Sub imgTitleClose_Click()
??? Unload Me
End Sub
Private Sub imgTitleLeft_MouseDown(p_intButton As Integer, p_intShift As Integer, p_sngX As Single, p_sngY As Single)
??? DoDrag Me
End Sub
Private Sub imgTitleMain_MouseDown(p_intButton As Integer, p_intShift As Integer, p_sngX As Single, p_sngY As Single)
??? DoDrag Me
End Sub

Private Sub imgTitleMinimize_Click()
??? Me.WindowState = vbMinimized
End Sub

Private Sub imgTitleRight_MouseDown(p_intButton As Integer, p_intShift As Integer, p_sngX As Single, p_sngY As Single)
??? DoDrag Me
End Sub

Private Sub lblTitle_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
DoDrag Me
End Sub

'界面部分代碼（結束）

源代碼下載：

http://files.cnblogs.com/DivClose/%e8%b0%83%e6%b4%aa%e6%bc%94%e7%ae%97%e5%8f%8c%e8%be%85%e5%8a%a9%e7%ba%bf%e6%b3%95%e6%ba%90%e4%bb%a3%e7%a0%81%ef%bc%88%e6%99%93%e6%9f%93%e9%9c%9c%e6%9e%97%e9%86%89QQ%ef%bc%9a51817%ef%bc%89.rar

轉載于:https://www.cnblogs.com/DivClose/archive/2011/02/13/1953833.html

總結

以上是生活随笔為你收集整理的调洪演算双辅助线法程序（源代码），首次公开！的全部內容，希望文章能夠幫你解決所遇到的問題。

如果覺得生活随笔網站內容還不錯，歡迎將生活随笔推薦給好友。