module1.bas

此程序用于道路放样的曲线要素的计算简单而方便

Attribute VB_Name = "Module1"
Option Explicit

Public Type Angle
    Degree As Integer
    Minutes As Integer
    Seconds As Single
End Type

Public Type Detail
    Ang As Angle
    pn As String
End Type

Const PI As Double = 3.14159265358979
Const Ro As Double = 180# * 3600# / PI

Public R As Double
Public Alpha As Double
Public L0 As Double

Public C As Integer
Public QZ As Double
Public JD As Double
Public ZH As Double
Public HY As Double
Public YH As Double
Public HZ As Double

Public T As Double
Public L As Double
Public E As Double
Public q As Double
Public X0 As Double
Public Y0 As Double
Public DetailH() As Detail
Public DetailY() As Detail
Public UB As Integer

Public BT As Double
Public I0 As Double
Public HYBS As Double

Public Function Radian(deg, min, sec) As Double
    Dim Rad As Double
    Rad = (deg * 360000# + min * 6000# + sec * 100#)
    Rad = Rad / Ro / 100
    Radian = Rad
End Function

Public Function SecToAng(sec As Double) As Angle
    Dim Ang As Angle
    Dim deg_1 As Double
    deg_1 = sec / 3600#
    Ang.Degree = Int(deg_1)
    Ang.Minutes = Int((deg_1 - Ang.Degree) * 60#)
    Ang.Seconds = (deg_1 - Ang.Degree - Ang.Minutes / 60#) * 3600#
    Ang.Seconds = Format(Ang.Seconds, "0.0000")
    SecToAng = Ang
    
End Function
Public Sub SetDetailsValue(details() As Detail, pn As String, Ang As Double)
    details(UB).Ang = SecToAng(Ang)
    details(UB).pn = pn
End Sub

Public Sub MainPtCalcu()
    Dim M As Double
    Dim p As Double
    

    BT = L0 / (2# * R)
    M = L0 / 2# - L0 * L0 * L0 / (240# * R * R)
    p = L0 * L0 / (24# * R)
    I0 = L0 / (6# * R)
    T = M + (R + p) * Tan(Alpha / 2#)
    L = Alpha * R + L0
    E = (R + p) / Cos(Alpha / 2#) - R
    
    q = 2 * T - L
    X0 = L0 - L0 * L0 * L0 / (40# * R * R)
    Y0 = L0 * L0 / (6# * R)
    
    ZH = JD - T
    HY = ZH + L0
    QZ = ZH + L / 2#
    HZ = QZ + L / 2#
    YH = HZ - L0
    
End Sub
Public Sub DetailCalcu()
    Dim i As Integer
    Dim j As Double
    Dim k As Integer
    Dim ii As Double
    Dim PTmp As Double
    Dim LTmp As Double
    Dim LTmp2 As Double
    Dim Delta As Double
    Dim Delta0 As Double
    Dim pn As Double
    UB = 0
    j = ZH \ 100
    PTmp = ZH + C
    LTmp = C
    
    '缓和曲线计算
    While PTmp < HY
        If PTmp \ 100 > j Then
            j = PTmp \ 100
            ReDim Preserve DetailH(UB)
            LTmp2 = j * 100# - ZH
            ii = LTmp2 * LTmp2 * Ro / (6# * R * L0)
            SetDetailsValue DetailH(), (UB + 1) & "   " & Format(j * 100, "0.00"), ii  '百米桩
            If PTmp / 100 > j Then
                UB = UB + 1
            End If
        End If
        ii = LTmp * LTmp * Ro / (6# * R * L0)
        pn = PTmp
        ReDim Preserve DetailH(UB)
        SetDetailsValue DetailH(), (UB + 1) & "   " & Format(pn, "0.00"), ii
        PTmp = PTmp + C
        LTmp = LTmp + C
        UB = UB + 1
    Wend
    LTmp = HY - ZH
    ii = LTmp * LTmp * Ro / (6# * R * L0)
    ReDim Preserve DetailH(UB)
    SetDetailsValue DetailH(), (UB + 1) & Format(HY, "0.00"), ii
    
    '圆曲线计算
    Delta = C / (2# * R) * Ro
    UB = 0
    PTmp = (PTmp \ C) * C
    Delta0 = (PTmp - HY) * Ro / (2# * R)
    HYBS = PI * 2# * Ro - (BT * Ro - I0 * Ro + Delta0)
    pn = PTmp
    ReDim Preserve DetailY(UB)
    SetDetailsValue DetailY(), (UB + 1) & "   " & Format(pn, "0.00"), 0
    ii = 0
    PTmp = PTmp + C
    UB = UB + 1
    While PTmp < QZ
        ii = ii + Delta
        pn = PTmp
        ReDim Preserve DetailY(UB)
        SetDetailsValue DetailY(), (UB + 1) & "   " & Format(pn, "0.00"), ii
        PTmp = PTmp + C
        UB = UB + 1
    Wend
    PTmp = (PTmp \ C - 1) * C
    Delta0 = (QZ - PTmp) * Ro / (2# * R)
    ii = ii + Delta0
    ReDim Preserve DetailY(UB)
    SetDetailsValue DetailY(), (UB + 1) & "   " & Format(HY, "0.00"), ii
    
End Sub