'**********************************************************************************************************
'
'调洪演算双辅助线法程序 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
'界面部分代码（结束）
源代码下载：