dlzdm.bas

行业软件,该源代码为道路设计纵断面典型的计算程序,该程序界面友好,计算准确,值得借鉴

Attribute VB_Name = "DlZdm"
Option Base 1
Public isTrue As Boolean
Public strXiangMu As String
Public HxBl As Integer
Public ZxBl As Integer
Public GcBcLow As Integer
Public GcBcHigh As Integer
Public DmSzNums As Long
Public ZhuangHaoS() As Single
Public DmBgS() As Single
Public SjNums As Integer
Public SjZhS() As Single
Public SjBgS() As Single
Public SjRs() As Single
Public SjGcTs() As Double
Public SjGcEs() As Double
Public SjGcis() As Single
Public SjGcLs() As Single
Public SjGcBulge() As Double
Public IsUp() As Boolean
Public Const PI = 3.14159265359
 
Public Sub GetZtxx()
'赋值给变量
On Error GoTo ERRORHANDER
Dim strSm As String
strXiangMu = frmZdm.txtPrj.Text
Close #1
Open strXiangMu For Input As #1
Input #1, strSm
Input #1, HxBl
Input #1, ZxBl
Input #1, GcBcLow
Input #1, GcBcHigh
'将数据文件回显给frmZdm窗体
frmZdm.txtSm.Text = strSm
frmZdm.txtHxbl.Text = "1:" & HxBl
frmZdm.txtZxbl.Text = "1:" & ZxBl
frmZdm.txtGcBcLow.Text = GcBcLow
frmZdm.txtGcBcHigh.Text = GcBcHigh
'地面数据
DmSzNums = 0
Do

Dim ZhuangHao As String
Dim DmBg As String
Input #1, ZhuangHao
If Trim(ZhuangHao) = "/" Then Exit Do
Input #1, DmBg
DmSzNums = DmSzNums + 1
ReDim Preserve ZhuangHaoS(DmSzNums) As Single
ReDim Preserve DmBgS(DmSzNums) As Single
frmZdm.lstDm.AddItem CZhuangHao(ZhuangHao) & _
"," & CBg(DmBg)

ZhuangHaoS(DmSzNums) = ZhuangHao
DmBgS(DmSzNums) = DmBg
Loop

Dim PnlDm As StatusBar
Set PnlDm = frmZdm.StatusBar1.Item(2)
PnlDm.Panels.Item(1) = "地面数据个数： " & DmSzNums
'设计高程数据
SjNums = 0
Do
Dim SjZh As String
Dim SjBg As String
Dim R As Single
Input #1, SjZh
If Trim(SjZh) = "/" Then Exit Do
Input #1, SjBg
Input #1, R
SjNums = SjNums + 1
ReDim Preserve SjZhS(SjNums) As Single
ReDim Preserve SjBgS(SjNums) As Single
ReDim Preserve SjRs(SjNums) As Single
frmZdm.lstSj.AddItem CZhuangHao(SjZh) _
  & "," & CBg(SjBg) & "," & R
  SjZhS(SjNums) = SjZh
  SjBgS(SjNums) = SjBg
  SjRs(SjNums) = R
Loop
Set PnlDm = frmZdm.StatusBar1.Item(2)
PnlDm.Panels.Item(2) = "设计高程个数： " & SjNums
 ShuQuXian
 isTrue = True
Exit Sub
ERRORHANDER:
isTrue = False
Err.Clear
MsgBox "赋值时发生错误"
Exit Sub
End Sub

Public Function CZhuangHao(ZhuangHao As String)
On Error GoTo ERRORHANDER
CZhuangHao = Format(ZhuangHao, "#0+000.000")
Exit Function
ERRORHANDER:
    MsgBox ("数据错误")
    Exit Function
End Function
Public Function CBg(Bg As String)
On Error GoTo ERRORHANDER
CBg = Format(Bg, "#0.000")
Exit Function
ERRORHANDER:
    MsgBox ("数据错误")
    Exit Function
End Function

Public Function XzGc(ZhuangHao As Single)
On Error GoTo ERRORHANDER
Dim i As Long
i = 0
Do
  i = i + 1
  Loop Until (ZhuangHaoS(i + 1) >= ZhuangHao) _
  And (ZhuangHao >= ZhuangHaoS(i))
       
 XzGc = DmBgS(i) * (ZhuangHaoS(i + 1) - ZhuangHao)
 XzGc = XzGc + DmBgS(i + 1) * (ZhuangHao - ZhuangHaoS(i))
 XzGc = XzGc / (ZhuangHaoS(i + 1) - ZhuangHaoS(i))
 Exit Function
ERRORHANDER:
MsgBox ("数据错误")
Exit Function

End Function

'***********************



Public Sub ShuQuXian()
ReDim Preserve SjGcTs(SjNums) As Double
ReDim Preserve SjGcEs(SjNums) As Double
ReDim Preserve IsUp(2 To SjNums - 1) As Boolean
ReDim Preserve SjGcis(SjNums - 1) As Single
ReDim Preserve SjGcLs(SjNums - 1) As Single
ReDim Preserve SjGcBulge(SjNums) As Double
Dim k As Integer
SjGcTs(1) = 0: SjGcTs(SjNums) = 0
SjGcEs(1) = 0: SjGcEs(SjNums) = 0
SjGcBulge(1) = 0: SjGcBulge(SjNums) = 0
For k = 1 To SjNums - 2

SjGcLs(k) = SjZhS(k + 1) - SjZhS(k)
SjGcLs(k + 1) = SjZhS(k + 2) - SjZhS(k + 1)
SjGcis(k) = (SjBgS(k + 1) - SjBgS(k)) / SjGcLs(k)
SjGcis(k + 1) = (SjBgS(k + 2) - SjBgS(k + 1)) / SjGcLs(k + 1)
IsUp(k + 1) = IIf((SjGcis(k + 1) > SjGcis(k)), _
      True, False)
   Dim W As Double
W = Atn(SjGcis(k + 1)) - Atn(SjGcis(k))
SjGcBulge(k + 1) = (1 - Cos(W / 2)) / Sin(W / 2)
SjGcTs(k + 1) = Abs(SjRs(k + 1) * _
   Tan(W / 2))
SjGcEs(k + 1) = SjRs(k + 1) * _
   (1 / Cos(W / 2) - 1)
   Next
End Sub
'************
'设计高程


Public Function SjGc(ZhuangHao As Single)
Dim i As Integer
i = 0
On Error GoTo ERRORHANDER
Do
 i = i + 1
Loop Until (SjZhS(i) <= ZhuangHao) _
    And (ZhuangHao <= SjZhS(i + 1))
    Dim X As Single
    Dim Y As Single
Select Case ZhuangHao
    Case SjZhS(i) To SjZhS(i) + SjGcTs(i)
        If SjRs(i) = 0 Then
            Y = 0
        Else
            X = SjZhS(i) + SjGcTs(i) - ZhuangHao
            Y = X * X / 2 / SjRs(i) * _
                Sgn(SjGcis(i) - SjGcis(i - 1))
        End If
        SjGc = SjBgS(i) + SjGcis(i) * (ZhuangHao - SjZhS(i)) + Y
    Case SjZhS(i) + SjGcTs(i) To SjZhS(i + 1) - SjGcTs(i + 1)
        SjGc = SjBgS(i) + SjGcis(i) * (ZhuangHao - SjZhS(i))
    Case Else
       If SjRs(i + 1) = 0 Then
          Y = 0
        Else
         X = -SjZhS(i + 1) + SjGcTs(i + 1) + ZhuangHao
         Y = X * X / 2 / SjRs(i + 1) * _
                Sgn(SjGcis(i + 1) - SjGcis(i))
         SjGc = SjBgS(i) + SjGcis(i) * (ZhuangHao - SjZhS(i)) + Y
        End If
 End Select
 Exit Function
ERRORHANDER:
 MsgBox ("数据错误")
 Exit Function
        
End Function