guochengji1.bas

用于公路、轻轨及铁路双线线间距工程计算的源程序。

Attribute VB_Name = "guochengji1"
Option Explicit
Dim pi As Double

'两点坐标→方位、距离子过程
'af为弧度(非度、度分秒)输出

Public Sub zb_fwju(x1 As Double, y1 As Double, x2 As Double, _
         y2 As Double, af As Double, dd As Double)
 pi = 4 * Atn(1)
If x2 - x1 = 0 Then
  If y2 - y1 > 0 Then af = pi / 2
  If y2 - y1 < 0 Then af = pi / 2 * 3
  If y2 - y1 = 0 Then af = 0
Else
  af = Atn((y2 - y1) / (x2 - x1))
  If y2 - y1 >= 0 And x2 - x1 < 0 Then af = af + pi
  If y2 - y1 < 0 And x2 - x1 < 0 Then af = af + pi
  If y2 - y1 <= 0 And x2 - x1 > 0 Then af = af + 2 * pi
End If
  dd = Sqr((x2 - x1) ^ 2 + (y2 - y1) ^ 2)
End Sub

'方位坐标计算子过程
'af0、aa、af为弧度(非度、度分秒)输入、输出
Public Sub fwzbjs(n As Integer, af0 As Double, x0 As Double, _
           y0 As Double, aa As Double, dd As Double, _
           af As Double, x As Double, y As Double)
 pi = 4 * Atn(1)
Select Case n
 Case 0
  af = af0 + pi - aa
 Case 1
  af = af0 + pi + aa
 End Select
 If af < 0 Then af = af + 2 * pi
 If af >= 2 * pi Then af = af - 2 * pi
 x = x0 + dd * Cos(af)
 y = y0 + dd * Sin(af)
End Sub

'两点坐标及各自边的方位→求交点坐标子过程
'af1、af2为弧度(非度、度分秒)输入
Public Sub zbfw_jdzb(af1 As Double, x1 As Double, y1 As Double, af2 As Double, _
          x2 As Double, y2 As Double, x As Double, y As Double)
          
   Dim k1 As Double, k2 As Double
   pi = 4 * Atn(1)
          
 If (af1 <> pi / 2 And af1 <> pi / 2 * 3) And (af2 <> pi / 2 And af2 <> pi / 2 * 3) Then
  k1 = Tan(af1)
  k2 = Tan(af2)
  x = (k2 * x2 - k1 * x1 + y1 - y2) / (k2 - k1)
  y = k2 * (x - x2) + y2
 End If
 If (af1 = pi / 2 Or af1 = pi / 2 * 3) And (af2 <> pi / 2 And af2 <> pi / 2 * 3) Then
  k2 = Tan(af2)
  x = x1
  y = k2 * (x - x2) + y2
 End If
 If (af1 <> pi / 2 And af1 <> pi / 2 * 3) And (af2 = pi / 2 Or af2 = pi / 2 * 3) Then
  k1 = Tan(af1)
  x = x2
  y = k1 * (x - x1) + y1
 End If
End Sub

'直角坐标转化大地坐标
'af0为弧度(非度、度分秒)输入
Public Sub zhijiao_dadi(x1 As Double, y1 As Double, af0 As Double, n0 As Double, _
         e0 As Double, n1 As Double, e1 As Double)
   
   Dim Ay As Double
   Dim af As Double
   Dim dd As Double
   Dim af1 As Double
   pi = 4 * Atn(1)
   Call zb_fwju(0, 0, x1, y1, af, dd)
   Ay = pi / 2 + pi - af
   If Ay < 0 Then Ay = Ay + 2 * pi
   If Ay >= 2 * pi Then Ay = Ay - 2 * pi
   Call fwzbjs(0, af0, n0, e0, Ay, dd, af1, n1, e1)
End Sub
'曲线基本资料计算
Public Sub jisuan_qxzl(a As Double, r As Double, s As Double, _
           m As Double, p As Double, q As Double, _
           w As Double, t As Double)
  m = s / 2 - s ^ 3 / 240 / r / r
  p = s * s / 24 / r
  q = s / 2 / r
  w = Abs(a) * r + s
  t = (r + p) * Tan(Abs(a) / 2) + m
End Sub


 '对称单曲线基本资料计算
Public Sub jisuan_qxzl1(a As Double, r As Double, s As Double, m As Double, p As Double, _
              t As Double, w As Double, e As Double, a0 As Double)
  
  m = s / 2 - s ^ 3 / 240 / r / r
  p = s * s / 24 / r
  t = (r + p) * Tan(a / 2) + m
  w = a * r + s
  e = (r + p) / Cos(a / 2) - r
  
  a0 = s / (2 * r)

  
End Sub
 '非对称单曲线基本资料计算
Public Sub jisuan_qxzl2(a As Double, r As Double, s1 As Double, s2 As Double, m1 As Double, _
             m2 As Double, p1 As Double, p2 As Double, t1 As Double, t2 As Double, _
             a1 As Double, a2 As Double, w As Double, e As Double)
  m1 = s1 / 2 - s1 ^ 3 / 240 / r / r
  m2 = s2 / 2 - s2 ^ 3 / 240 / r / r
  p1 = s1 * s1 / 24 / r
  p2 = s2 * s2 / 24 / r
  
  t1 = (r + p1) * Tan(a / 2) + m1 + (p2 - p1) / Sin(a)
  't2 = (r + p1) * Tan(a / 2) + m2 - (p2 - p1) / Tan(a)
  't1 = (r + p2) * Tan(a / 2) + m1 + (p2 - p1) / Tan(a)
  t2 = (r + p2) * Tan(a / 2) + m2 - (p2 - p1) / Sin(a)
  
  
  a1 = Atn((r + p1) / (t1 - m1))
  a2 = Atn((r + p2) / (t2 - m2))
  
  w = a * r + (s1 + s2) / 2
  
  e = (r + p1) / Sin(a1) - r
  
  
End Sub

'美化退出
Public Sub MHexit(frmMe As Form)
Dim GotoVal As Double
Dim gointo As Integer
GotoVal = frmMe.Height / 2

For gointo = 1 To GotoVal
    
    DoEvents
        frmMe.Height = frmMe.Height - 10
        frmMe.Top = (Screen.Height - frmMe.Height) \ 2
        If frmMe.Height < 11 Then GoTo horiz
    Next gointo

    'This is the width part of the same sequence above
horiz:
    frmMe.Height = 30
    GotoVal = frmMe.Width / 2

    For gointo = 1 To GotoVal
         DoEvents
            frmMe.Width = frmMe.Width - 10
            frmMe.Left = (Screen.Width - frmMe.Width) \ 2
            If frmMe.Width < 11 Then Exit Sub
    Next gointo
    
    Unload frmMe
    
End Sub



'限制使用次数

Public Sub H_cishu(frmMe As Form)

  Dim RemainDay As Long
 
  RemainDay = GetSetting("我的计算器", "set", "times", 0)
  
  If RemainDay >= 3000 Then
   MsgBox "试用次数已满，请……"
   Unload frmMe
  End If
  
  MsgBox "现在剩下：" & 3000 - RemainDay & "试用次数，好好珍惜！"
  RemainDay = RemainDay + 1
  SaveSetting "我的计算器", "set", "times", RemainDay
  
End Sub