first.frm

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

      Width           =   285
   End
   Begin VB.Image imgTitleMain 
      Height          =   450
      Left            =   6360
      Picture         =   "first.frx":4BA0
      Stretch         =   -1  'True
      Top             =   480
      Width           =   285
   End
   Begin VB.Image imgWindowBottomRight 
      Height          =   450
      Left            =   7440
      Picture         =   "first.frx":52EA
      Top             =   0
      Width           =   285
   End
End
Attribute VB_Name = "frmMainCode"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public JType As Integer '计算类型 单值计算 自动计算
Public X1, Line2 As Integer '输入数据行数 中间数组行数
Public CS As Integer  '循环次数
Public BLJ As Single '断面转化的临界平均宽度
Public Kill As Integer '控制计算次数，防止程序不响应
'定义EXCEL对象
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Private Sub Check1_Click()
'将程序置于最上的控制
If Check1.Value = Checked Then
    AlwaysOnTop Me, True
Else
    AlwaysOnTop Me, False
End If
End Sub
Private Sub Command7_Click()
    Form1.Show
End Sub
'利用Excel进行绘图
Private Sub CmdDraw_Click()
Dim Path1 As String
Dim ExcelOut() As String
Dim AreaStr As String
CmdDraw.Enabled = False

LbMsg.Caption = "即时提示：请稍候，正在进行绘图计算……"
If List3.ListCount = 0 Then
    Dim ret3 As VbMsgBoxResult
    ret3 = MsgBox("没有数据可用于绘图，请先选择计算！", vbInformation, "友好提示")
    Exit Sub
End If
If Right(App.Path, 1) = "\" Then
    Path1 = App.Path
Else
    Path1 = App.Path + "\"
End If
If Dir(Path1 + "OUT.xls") = "" Then
   Open Path1 + "OUT.xls" For Output As 10#
    Close 10#
End If
If Dir(Path1 + "excel.bz") = "" Then '判断EXCEL是否打开
    Set xlApp = CreateObject("Excel.Application") '创建EXCEL应用类
    Set xlBook = xlApp.Workbooks.Open(Path1 + "OUT.xls") '打开EXCEL工作簿
    Set xlSheet = xlBook.Worksheets(1) '打开EXCEL工作表
    'xlApp.Visible = True '设置EXCEL可见
    xlSheet.Activate '激活工作表
    xlSheet.Cells(1, 1) = "截流水力参数计算" '给单元格1行驶列赋值
    xlSheet.Cells(2, 1) = "龙口平均宽度"
    xlSheet.Cells(2, 2) = "上游水位"
    xlSheet.Cells(2, 3) = "龙口流量"
    xlSheet.Cells(2, 4) = "龙口平均流速"
    xlSheet.Cells(2, 5) = "单宽流量"
    xlSheet.Cells(2, 6) = "落差"
    xlSheet.Cells(2, 7) = "单宽功率"
    '输出计算结果
    For i = 0 To List3.ListCount - 1
        ExcelOut = Split(List3.List(i), ",")
        For j = 1 To 7
            xlSheet.Cells(i + 3, j) = ExcelOut(j - 1)
        Next j
    Next i
    '对齐及底色设置
    xlApp.ActiveSheet.Rows.HorizontalAlignment = xlVAlignCenter
    xlApp.ActiveSheet.Rows.VerticalAlignment = xlVAlignCenter '上下、左右居中
    Range("A1:G1").Select
    With Selection.Interior
        .ColorIndex = 36
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    Range("A20").Select
    Charts.Add
    ActiveChart.ChartType = xlXYScatterSmooth
    ActiveChart.SetSourceData Source:=Sheets("OUT").Range("A20"), PlotBy:= _
        xlColumns
    
    '添加系列
    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.SeriesCollection.NewSeries
    'ActiveChart.SeriesCollection.NewSeries
    '生成绘图数据源
    i = 3
    j = i + Val(List3.ListCount) - 1
    AreaStr = "=OUT!R" & STR(i) & "C1:R" & STR(j) & "C1"
    AreaStr = Replace(AreaStr, " ", "")
    ActiveChart.SeriesCollection(1).XValues = AreaStr
    AreaStr = "=OUT!R" + STR(i) + "C4:R" + STR(j) + "C4"
    AreaStr = Replace(AreaStr, " ", "")
    ActiveChart.SeriesCollection(1).Values = AreaStr
    ActiveChart.SeriesCollection(1).Name = "=""平均流速"""
    
    AreaStr = "=OUT!R" + STR(i) + "C1:R" + STR(j) + "C1"
    AreaStr = Replace(AreaStr, " ", "")
    ActiveChart.SeriesCollection(2).XValues = AreaStr
    AreaStr = "=OUT!R" + STR(i) + "C5:R" + STR(j) + "C5"
    AreaStr = Replace(AreaStr, " ", "")
    ActiveChart.SeriesCollection(2).Values = AreaStr
    ActiveChart.SeriesCollection(2).Name = "=""单宽流量"""
    
    AreaStr = "=OUT!R" + STR(i) + "C1:R" + STR(j) + "C1"
    AreaStr = Replace(AreaStr, " ", "")
    ActiveChart.SeriesCollection(3).XValues = AreaStr
    AreaStr = "=OUT!R" + STR(i) + "C6:R" + STR(j) + "C6"
    AreaStr = Replace(AreaStr, " ", "")
    ActiveChart.SeriesCollection(3).Values = AreaStr
    ActiveChart.SeriesCollection(3).Name = "=""落差"""
    
    AreaStr = "=OUT!R" + STR(i) + "C1:R" + STR(j) + "C1"
    AreaStr = Replace(AreaStr, " ", "")
    ActiveChart.SeriesCollection(4).XValues = AreaStr
    AreaStr = "=OUT!R" + STR(i) + "C7:R" + STR(j) + "C7"
    AreaStr = Replace(AreaStr, " ", "")
    ActiveChart.SeriesCollection(4).Values = AreaStr
    ActiveChart.SeriesCollection(4).Name = "=""单宽功率"""
    
    'ActiveChart.SeriesCollection(5).XValues = "=OUT!R3C1:R17C1"
    'ActiveChart.SeriesCollection(5).Values = "=OUT!R3C3:R17C3"
    'ActiveChart.SeriesCollection(5).Name = "=""龙口流量"""
    ActiveChart.Location Where:=xlLocationAsObject, Name:="OUT"
    With ActiveChart
        .HasTitle = True
        .ChartTitle.Characters.Text = "截流水力参数变化曲线"
        .Axes(xlCategory, xlPrimary).HasTitle = True
        .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "龙口平均宽度"
        .Axes(xlValue, xlPrimary).HasTitle = True
        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "各水力参数"
    End With
    '缩放控制
    ActiveSheet.Shapes("图表 1").ScaleWidth 2, msoFalse, msoScaleFromTopLeft
    ActiveSheet.Shapes("图表 1").ScaleHeight 2, msoFalse, msoScaleFromTopLeft
    '标题字体控制
    ActiveChart.ChartTitle.Select
    Selection.AutoScaleFont = True
    With Selection.Font
        .Name = "宋体"
        .FontStyle = "加粗"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .Background = xlAutomatic
    End With
    ActiveChart.ChartArea.Select
    ActiveChart.ChartTitle.Select
    Windows("OUT.xls").ScrollRow = 3
    ActiveChart.Legend.Select
    Selection.AutoScaleFont = True
    With Selection.Font
        .Name = "宋体"
        .FontStyle = "加粗"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .Background = xlAutomatic
    End With
    Windows("OUT.xls").ScrollRow = 8
    Windows("OUT.xls").ScrollRow = 10
    ActiveChart.Axes(xlCategory).AxisTitle.Select
    Selection.AutoScaleFont = True
    With Selection.Font
        .Name = "宋体"
        .FontStyle = "加粗"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .Background = xlAutomatic
    End With
    ActiveChart.Axes(xlValue).AxisTitle.Select
    Selection.AutoScaleFont = True
    With Selection.Font
        .Name = "宋体"
        .FontStyle = "加粗"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .Background = xlAutomatic
    End With
    ActiveChart.Axes(xlValue).Select
    Selection.TickLabels.AutoScaleFont = True
    With Selection.TickLabels.Font
        .Name = "宋体"
        .FontStyle = "常规"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .Background = xlAutomatic
    End With
    Windows("OUT.xls").ScrollRow = 13
    ActiveChart.Axes(xlCategory).Select
    Selection.TickLabels.AutoScaleFont = True
    With Selection.TickLabels.Font
        .Name = "宋体"
        .FontStyle = "常规"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .Background = xlAutomatic
    End With
    xlApp.Visible = True '设置EXCEL可见
    xlBook.RunAutoMacros (xlAutoOpen) '运行EXCEL中的启动宏
    LbMsg.Caption = "即时提示：绘图完毕，请注意保存"
   ' xlApp.Quit
    'Set xlApp = Nothing '释放EXCEL对象
  If Dir(Path1 + "excel.bz") <> "" Then '由VB关闭EXCEL
    xlBook.RunAutoMacros (xlAutoClose) '执行EXCEL关闭宏
    xlBook.Close (True) '关闭EXCEL工作簿
    xlApp.Quit '关闭EXCEL
  End If
  Set xlApp = Nothing '释放EXCEL对象
  End
    
  Else
    MsgBox ("EXCEL已打开")
  End If
End Sub

Private Sub CmdHelp_Click()
FrmHelp.Show
End Sub

Private Sub Form_Load()
On Error Resume Next
'程序最后修改于2005-7-11
Dim BeErr As Boolean
Dim Last() As String
BeErr = False
JType = 1
    MakeWindow Me, False
    imgTitleMaxRestore.Picture = imgTitleMaximize.Picture
    LoadSkinz Me
    List1.AddItem ("格式为：水位,流量")
'AlwaysOnTop Me, True
Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2
LbMsg.Caption = "即时提示：先输入分流能力数据或查看帮助"
CmdDraw.Enabled = True
If Right(App.Path, 1) = "\" Then
    Path1 = App.Path
Else
    Path1 = App.Path + "\"
End If
ReDim Last(8)
Timer1.Enabled = True
End Sub
Private Sub Command1_Click()
'输入分流能力数据文件
On Error Resume Next
Dim File1 As String
Dim LineIn As String
filenum = FreeFile
CD1.DialogTitle = "打开分流能力文件"
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
    LbMsg.Caption = "即时提示：请设置计算参数或查看帮助"
Else
    Exit Sub
End If
End Sub
Private Sub Command2_Click()
'保存中间数据
On Error Resume Next
Dim File2 As String
If List2.ListCount = 0 Then
    Dim ret2 As VbMsgBoxResult
    ret2 = MsgBox("没有数据需要保存，请先计算！", vbInformation, "友好提示")
    Exit Sub
End If
CD2.DialogTitle = "保存计算结果"
CD2.Filter = "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"
CD2.ShowSave
filenum = FreeFile
If CD2.FileName <> "" Then
    File2 = CDSave.FileName
    Open File2 For Output As #filenum
    Write #filenum, "龙口泄流能力数据"
    Write #filenum, "上游水位(m)  下泄流量(m3/s)"
    For i = 0 To List2.ListCount - 1
        Print #filenum, List2.List(i)
    Next i
    Close #filenum
Else
    Exit Sub
End If
End Sub
'求临界水深
Function FHK(ByVal B As Single, ByVal Q As Single, ByVal M As Single, ByVal EPS As Single) As Single
If B < BLJ Then '三角形断面
    
    FHK = (2 * Q ^ 2 * M ^ 2 / 9.8) ^ 0.2
    
Else '梯形断面
    X1 = 0.0001: X2 = 20
    If B <> 0 Then
        FLine1 = (X1 * B) ^ 3 - (B + X1 / M) * Q ^ 2 / 9.8
        FX2 = (X2 * B) ^ 3 - (B + X2 / M) * Q ^ 2 / 9.8
        Do While FLine1 * FX2 > 0
            X2 = X2 + 2
            FX2 = (X2 * B) ^ 3 - (B + X2 / M) * Q ^ 2 / 9.8
        Loop
        Line15 = (X1 + X2) / 2
        FLine15 = (Line15 * B) ^ 3 - (B + Line15 / M) * Q ^ 2 / 9.8
        Do While Abs(FLine15) >= EPS
            If Sgn(FLine15) = Sgn(FX2) Then
                X2 = Line15
            ElseIf Sgn(FLine15) = 0 Then
                FHK = FLine15
            Else
                X1 = Line15
            End If
            FLine1 = (X1 * B) ^ 3 - (B + X1 / M) * Q ^ 2 / 9.8
            FX2 = (X2 * B) ^ 3 - (B + X2 / M) * Q ^ 2 / 9.8
            Line15 = (X1 + X2) / 2
            FLine15 = (Line15 * B) ^ 3 - (B + Line15 / M) * Q ^ 2 / 9.8
        Loop
        FHK = FLine15
    Else
        BeErr = True
    End If
    
End If
End Function

Private Sub Command3_Click()
On Error Resume Next
'读入文件并保存在数组中
Dim B, B1, B2, Hx, M, Hjz, Hd, Hhd As Single '龙口宽度 下游水位 流量系数 基准高程
Dim Hs, Bp, Hdd 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, OutString As String
Dim WZ As Integer
Dim BZ As Single '淹没标准
Dim Z1, N As Single '落差 单宽功率
Dim File1 As String
Dim H0 As Single '龙口上游水头
Dim H, Hlk, V As Single '上游水位 龙口水深 龙口平均流速
Dim H1, H2, H15 As Single
Dim Q11, Q12, Q21, Q22, Q15, Q151, Q152 As Single
Dim DkQ As Single '单宽流量
Dim Path1 As String
File1 = TextQH(1).Text