xjjjs.frm

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

  Dim cz As Integer
  Dim zsds1 As Integer
  Dim zsds2 As Integer
  Dim cp As Integer
  Dim intvar  As Integer
  
  
  Dim H_xjj As Double, H_bpxjd As Double
  Dim H_af0 As Double
  Dim H_qdlc1 As Double, H_zhlc1 As Double, H_hzlc1 As Double
  Dim H_a1 As Double, H_r1 As Double, H_s1 As Double, H_t1 As Double, H_w1 As Double
  Dim H_qdlc2 As Double, H_zhlc2 As Double, H_hzlc2 As Double
  Dim H_a2 As Double, H_r2 As Double, H_s2 As Double, H_t2 As Double, H_w2 As Double
  
  Dim H_cz(500) As String
  Dim H_jslc1(500) As Double, H_n1(500) As Double, H_e1(500) As Double
  Dim H_jslc2(500) As Double, H_n2(500) As Double, H_e2(500) As Double
  Dim H_jsxjj(500) As Double

'Ⅰ线第一分段法线角及坐标计算
Sub l1_xyzb1(qdlc1 As Double, jslc1 As Double, bpxjd As Double, _
           xjj As Double, b1 As Double, x1 As Double, _
           y1 As Double)
  Dim l1#
  pi = 4 * Atn(1)
  l1 = Abs(jslc1 - qdlc1)
  b1 = bpxjd
  x1 = l1 * Cos(pi / 2 - b1) + xjj
  y1 = l1 * Sin(pi / 2 - b1)
End Sub
'Ⅰ线第二分段法线角及坐标计算
Sub l1_xyzb2(qdlc1 As Double, zhlc1 As Double, jslc1 As Double, _
         bpxjd As Double, xjj As Double, a1 As Double, r1 As Double, _
         s1 As Double, b1 As Double, x1 As Double, y1 As Double)
  Dim l1#, bb#, xx#, yy#, ww#
  pi = 4 * Atn(1)
  l1 = Abs(jslc1 - zhlc1)
  bb = l1 * l1 / (2 * r1 * s1)
  xx = l1 ^ 3 / (6 * r1 * s1)
  yy = l1 - l1 ^ 5 / (40 * r1 * r1 * s1 * s1)
  ww = Sqr(xx * xx + yy * yy)
  x1 = Abs(qdlc1 - zhlc1) * Cos(pi / 2 - bpxjd) + ww * Cos(pi / 2 - bpxjd - Sgn(a1) * Atn(xx / yy)) + xjj
  y1 = Abs(qdlc1 - zhlc1) * Sin(pi / 2 - bpxjd) + ww * Sin(pi / 2 - bpxjd - Sgn(a1) * Atn(xx / yy))
  b1 = bpxjd + Sgn(a1) * bb
End Sub
'Ⅰ线第三分段法线角及坐标计算
Sub l1_xyzb3(qdlc1 As Double, zhlc1 As Double, jslc1 As Double, _
         bpxjd As Double, xjj As Double, a1 As Double, r1 As Double, _
         s1 As Double, m1 As Double, p1 As Double, q1 As Double, _
         b1 As Double, x1 As Double, y1 As Double)
  Dim l1#, bb#, xx#, yy#, ww#
  pi = 4 * Atn(1)
  l1 = Abs(jslc1 - zhlc1)
  bb = (l1 - s1) / r1 + q1
  xx = r1 * (1 - Cos(bb)) + p1
  yy = r1 * Sin(bb) + m1
  ww = Sqr(xx * xx + yy * yy)
  x1 = Abs(qdlc1 - zhlc1) * Cos(pi / 2 - bpxjd) + ww * Cos(pi / 2 - bpxjd - Sgn(a1) * Atn(xx / yy)) + xjj
  y1 = Abs(qdlc1 - zhlc1) * Sin(pi / 2 - bpxjd) + ww * Sin(pi / 2 - bpxjd - Sgn(a1) * Atn(xx / yy))
  b1 = bpxjd + Sgn(a1) * bb
End Sub
'Ⅰ线第四分段法线角及坐标计算
Sub l1_xyzb4(qdlc1 As Double, zhlc1 As Double, jslc1 As Double, _
         bpxjd As Double, xjj As Double, a1 As Double, r1 As Double, _
         s1 As Double, w1 As Double, t1 As Double, b1 As Double, _
         x1 As Double, y1 As Double)
  Dim b#, x#, y#, ww#
  pi = 4 * Atn(1)
  Call l_xyzb(zhlc1, jslc1, a1, r1, s1, w1, t1, b, x, y)
  ww = Sqr(x * x + y * y)
  x1 = Abs(qdlc1 - zhlc1) * Cos(pi / 2 - bpxjd) + ww * Cos(pi / 2 - bpxjd - Sgn(a1) * Atn(x / y)) + xjj
  y1 = Abs(qdlc1 - zhlc1) * Sin(pi / 2 - bpxjd) + ww * Sin(pi / 2 - bpxjd - Sgn(a1) * Atn(x / y))
  b1 = bpxjd + Sgn(a1) * b
End Sub
'Ⅰ线第五分段法线角及坐标计算
Sub l1_xyzb5(qdlc1 As Double, zhlc1 As Double, jslc1 As Double, _
         bpxjd As Double, xjj As Double, a1 As Double, r1 As Double, _
         s1 As Double, w1 As Double, t1 As Double, b1 As Double, _
         x1 As Double, y1 As Double)
  Dim l1#, bb#
  pi = 4 * Atn(1)
  l1 = Abs(jslc1 - zhlc1) - w1
  x1 = (Abs(qdlc1 - zhlc1) + t1) * Cos(pi / 2 - bpxjd) + (t1 + l1) * Cos(pi / 2 - bpxjd - a1) + xjj
  y1 = (Abs(qdlc1 - zhlc1) + t1) * Sin(pi / 2 - bpxjd) + (t1 + l1) * Sin(pi / 2 - bpxjd - a1)
  b1 = a1 + bpxjd
End Sub
'Ⅱ线第一分段法线角及坐标计算
Sub l2_xyzb1(qdlc2 As Double, jslc2 As Double, _
            b2 As Double, x2 As Double, y2 As Double)
  Dim l2#
  l2 = Abs(jslc2 - qdlc2)
  b2 = 0
  x2 = 0
  y2 = l2
End Sub
'Ⅱ线第二分段法线角及坐标计算
Sub l2_xyzb2(qdlc2 As Double, zhlc2 As Double, jslc2 As Double, _
         a2 As Double, r2 As Double, s2 As Double, _
         b2 As Double, x2 As Double, y2 As Double)
  Dim l2#, bb#
  l2 = Abs(jslc2 - zhlc2)
  bb = l2 * l2 / (2 * r2 * s2)
  x2 = l2 ^ 3 / (6 * r2 * s2) * Sgn(a2)
  y2 = Abs(qdlc2 - zhlc2) + l2 - l2 ^ 5 / (40 * r2 * r2 * s2 * s2)
  b2 = Sgn(a2) * bb
End Sub
'Ⅱ线第三分段法线角及坐标计算
Sub l2_xyzb3(qdlc2 As Double, zhlc2 As Double, jslc2 As Double, _
          a2 As Double, r2 As Double, s2 As Double, m2 As Double, _
          p2 As Double, q2 As Double, b2 As Double, x2 As Double, _
          y2 As Double)
  Dim l2#, bb#
  l2 = Abs(jslc2 - zhlc2)
  bb = (l2 - s2) / r2 + q2
  x2 = (r2 * (1 - Cos(bb)) + p2) * Sgn(a2)
  y2 = Abs(qdlc2 - zhlc2) + r2 * Sin(bb) + m2
  b2 = Sgn(a2) * bb
End Sub
'Ⅱ线第四分段法线角及坐标计算
Sub l2_xyzb4(qdlc2 As Double, zhlc2 As Double, jslc2 As Double, _
         a2 As Double, r2 As Double, _
         s2 As Double, w2 As Double, t2 As Double, b2 As Double, _
         x2 As Double, y2 As Double)
  Dim b#, x#, y#
  Call l_xyzb(zhlc2, jslc2, a2, r2, s2, w2, t2, b, x, y)
  x2 = x * Sgn(a2)
  y2 = y + Abs(qdlc2 - zhlc2)
  b2 = Sgn(a2) * b
End Sub
'Ⅱ线第五分段法线角及坐标计算
Sub l2_xyzb5(qdlc2 As Double, zhlc2 As Double, jslc2 As Double, _
         a2 As Double, r2 As Double, s2 As Double, w2 As Double, _
         t2 As Double, b2 As Double, x2 As Double, y2 As Double)
  Dim l2#
  pi = 4 * Atn(1)
  l2 = Abs(jslc2 - zhlc2) - w2
  b2 = a2
  x2 = (t2 + l2) * Cos(pi / 2 - Abs(a2)) * Sgn(a2)
  y2 = Abs(qdlc2 - zhlc2) + t2 + (t2 + l2) * Sin(pi / 2 - Abs(a2))
End Sub
'第二缓和曲线段在以ZH为坐标原点的坐标系中的法线角及坐标
Sub l_xyzb(zhlc As Double, jslc As Double, a As Double, r As Double, _
         s As Double, w As Double, t As Double, _
         b As Double, x As Double, y As Double)
  Dim l#, bb#, xx#, yy#, af#, ww#
  pi = 4 * Atn(1)
  l = w - Abs(jslc - zhlc)
  bb = l * l / (2 * r * s)
  xx = l ^ 3 / (6 * r * s)
  yy = l - l ^ 5 / (40 * r * r * s * s)
  af = -Abs(a) - pi / 2 + Atn(xx / yy)
  ww = Sqr(xx * xx + yy * yy)
  x = t * Cos(pi / 2 - Abs(a)) + ww * Cos(af)
  y = t + t * Sin(pi / 2 - Abs(a)) + ww * Sin(af)
  b = Abs(a) - bb
End Sub
'计算里程位于曲线那一分段计算
Sub jisuan_fdzl(zsds As Integer, qdlc As Double, zhlc As Double, _
         jslc As Double, s As Double, w As Double, fd As Integer)
 Select Case zsds
  Case 1
  If jslc >= qdlc And jslc <= zhlc Then fd = 1
  If jslc > zhlc And jslc <= zhlc + s Then fd = 2
  If jslc > zhlc + s And jslc <= zhlc + w - s Then fd = 3
  If jslc > zhlc + w - s And jslc <= zhlc + w Then fd = 4
  If jslc > zhlc + w Then fd = 5
  Case -1
  If jslc <= qdlc And jslc >= zhlc Then fd = 1
  If jslc < zhlc And jslc >= zhlc - s Then fd = 2
  If jslc < zhlc - s And jslc >= zhlc - w + s Then fd = 3
  If jslc < zhlc - w + s And jslc >= zhlc - w Then fd = 4
  If jslc < zhlc - w Then fd = 5
 End Select
End Sub
'判断弯道头尾里程输入是否正确
Sub panduan_zhlc(zsds As Integer, qdlc As Double, zhlc As Double, _
         zhlccw As Integer)
  Dim msg1$, msg2$, title$, style%
  
   msg1$ = "里程正算时，" & Chr(13) & "弯道头尾里程必须大于等于起点里程！" & _
       Chr(13) & "请重新输入弯道头尾里程！"
   msg2$ = "里程倒算时，" & Chr(13) & "弯道头尾里程必须小于等于起点里程！" & _
       Chr(13) & "请重新输入弯道头尾里程！"
  title$ = "敬请注意"
  style = vbOKOnly + vbExclamation + vbDefaultButton2
  
 Select Case zsds
  Case 1
   If zhlc < qdlc Then
    MsgBox msg1$, style, title$
    zhlccw = 1
   End If
  Case -1
   If zhlc > qdlc Then
    MsgBox msg2$, style, title$
    zhlccw = 1
   End If
  End Select
End Sub
'判断计算里程输入是否正确
Sub panduan_jslc(zsds As Integer, qdlc As Double, jslc As Double, _
         jslccw As Integer)
  Dim msg1$, msg2$, title$, style%
  msg1$ = "里程正算时，" & Chr(13) & "计算里程必须大于等于起点里程！" & _
       Chr(13) & "请重新输入计算里程！"
  msg2$ = "里程倒算时，" & Chr(13) & "计算里程必须小于等于起点里程！" & _
       Chr(13) & "请重新输入计算里程！"
  title$ = "敬请注意"
  style = vbOKOnly + vbExclamation + vbDefaultButton2
 
 Select Case zsds
  Case 1
   If jslc < qdlc Then
    MsgBox msg1$, style, title$
    jslccw = 1
   End If
  Case -1
   If jslc > qdlc Then
    MsgBox msg2$, style, title$
    jslccw = 1
   End If
 End Select
End Sub

 '计算
Private Sub Command1_Click()
   
   Dim jd As Double, xjj As Double, bpxjd As Double
   Dim af0 As Double, n0 As Double, e0 As Double
   Dim fd1 As Integer, qdlc1 As Double, zhlc1 As Double, jslc1 As Double
   Dim a1 As Double, r1 As Double, s1 As Double, m1 As Double, p1 As Double, q1 As Double
   Dim t1 As Double, w1 As Double, b1 As Double, x1 As Double, y1 As Double
   Dim fd2 As Integer, qdlc2 As Double, zhlc2 As Double, jslc2 As Double
   Dim a2 As Double, r2 As Double, s2 As Double, m2 As Double, p2 As Double, q2 As Double
   Dim t2 As Double, w2 As Double, b2 As Double, x2 As Double, y2 As Double
   Dim x0 As Double, y0 As Double, dd As Double, jsxjj As Double
   Dim n1 As Double, e1 As Double, n2 As Double, e2 As Double
   Dim zhlc1cw As Integer, jslc1cw As Integer, zhlc2cw As Integer, jslc2cw As Integer
   Dim cs As Integer
  
   pi = 4 * Atn(1)
   
   On Error GoTo ErrHandler
   
   jd = Val(Combo1.Text)
   xjj = Val(Text6.Text)
   bpxjd = dmsrad(Val(Text7.Text))
   af0 = dmsrad(Val(Text11.Text))
   n0 = Val(Text12.Text)
   e0 = Val(Text13.Text)
   
   qdlc1 = Val(Text1(0).Text)
   zhlc1 = Val(Text2(0).Text)
   a1 = dmsrad(Val(Text3(0).Text))
   r1 = Val(Text4(0).Text)
   s1 = Val(Text5(0).Text)
   qdlc2 = Val(Text1(1).Text)
   zhlc2 = Val(Text2(1).Text)
   a2 = dmsrad(Val(Text3(1).Text))
   r2 = Val(Text4(1).Text)
   s2 = Val(Text5(1).Text)
   
 '判断两线弯道头尾里程是否正确
   Call panduan_zhlc(zsds1, qdlc1, zhlc1, zhlc1cw)
    If zhlc1cw = 1 Then
     Text2(0).SetFocus
     Exit Sub
    End If
   Call panduan_zhlc(zsds2, qdlc2, zhlc2, zhlc2cw)
    If zhlc2cw = 1 Then
     Text2(1).SetFocus
    Exit Sub
   End If
   
 '因为线间距垂直一条线，另一条线计算里程可不输，让该计算里程
 '等于弯道头尾里程。并判断另一计算里程输入是否正确
  
  Select Case cz
   Case 1
    jslc1 = Val(Text8.Text)
    jslc2 = zhlc2
    Call panduan_jslc(zsds1, qdlc1, jslc1, jslc1cw)
    If jslc1cw = 1 Then
     Text8.SetFocus
     Exit Sub
    End If
   Case 2
    jslc2 = Val(Text9.Text)
    jslc1 = zhlc1
    Call panduan_jslc(zsds2, qdlc2, jslc2, jslc2cw)
    If jslc2cw = 1 Then
     Text9.SetFocus
     Exit Sub
    End If
   End Select
   
   
'先计算两线的曲线基本资料
   
   Call jisuan_qxzl(a1, r1, s1, m1, p1, q1, w1, t1)
   Call jisuan_qxzl(a2, r2, s2, m2, p2, q2, w2, t2)
Select Case cz
'垂直Ⅰ线时,Ⅰ线计算里程固定。计算出Ⅱ线计算点到过Ⅰ线计算里程点的法线的垂直距离，
'Ⅱ线计算里程根据这个距离不断递增或递减
 Case 1
    Call jisuan_fdzl(zsds1, qdlc1, zhlc1, jslc1, s1, w1, fd1)
   Select Case fd1
    Case 1
    Call l1_xyzb1(qdlc1, jslc1, bpxjd, xjj, b1, x1, y1)
    Case 2
    Call l1_xyzb2(qdlc1, zhlc1, jslc1, bpxjd, xjj, a1, r1, s1, b1, x1, y1)
    Case 3
    Call l1_xyzb3(qdlc1, zhlc1, jslc1, bpxjd, xjj, a1, r1, s1, m1, p1, q1, b1, x1, y1)
    Case 4
    Call l1_xyzb4(qdlc1, zhlc1, jslc1, bpxjd, xjj, a1, r1, s1, w1, t1, b1, x1, y1)
    Case 5
    Call l1_xyzb5(qdlc1, zhlc1, jslc1, bpxjd, xjj, a1, r1, s1, w1, t1, b1, x1, y1)
   End Select
    If Abs(b1) > pi / 2 Then cs = (-1) * zsds2
    If Abs(b1) = pi / 2 Then cs = Sgn(b1) * zsds2
    If Abs(b1) < pi / 2 Then cs = 1 * zsds2
  Do
    Call jisuan_fdzl(zsds2, qdlc2, zhlc2, jslc2, s2, w2, fd2)
   Select Case fd2
    Case 1
    Call l2_xyzb1(qdlc2, jslc2, b2, x2, y2)
    Case 2
    Call l2_xyzb2(qdlc2, zhlc2, jslc2, a2, r2, s2, b2, x2, y2)
    Case 3
    Call l2_xyzb3(qdlc2, zhlc2, jslc2, a2, r2, s2, m2, p2, q2, b2, x2, y2)
    Case 4
    Call l2_xyzb4(qdlc2, zhlc2, jslc2, a2, r2, s2, w2, t2, b2, x2, y2)
    Case 5
    Call l2_xyzb5(qdlc2, zhlc2, jslc2, a2, r2, s2, w2, t2, b2, x2, y2)
   End Select
   If Abs(b1) <> pi / 2 Then
     y0 = (x2 - x1) * Tan(pi - b1) + y1
     
    'dd为Ⅱ线计算点(x2,y2)到Ⅰ线的法线(该法线过Ⅰ线计算里程点)的垂直距离
     
    dd = Abs(Tan(pi - b1) * x2 - y2 - Tan(pi - b1) * x1 + y1) / Sqr(Tan(pi - b1) ^ 2 + 1)
     
    If dd >= jd Then
     jslc2 = jslc2 + dd * Sgn(y0 - y2) * cs
    Else
     Exit Do
    End If
   Else
    x0 = x1
    dd = Abs(x2 - x1)
    If dd >= jd Then
     jslc2 = jslc2 + dd * Sgn(x0 - x2) * cs
    Else
     Exit Do
    End If
   End If
  Loop
  
 '垂直Ⅱ线时,Ⅱ线计算里程固定。计算出Ⅰ线计算点到过Ⅱ线计算里程点的法线的垂直距离，
 ' Ⅰ线计算里程根据这个距离不断递增或递减
  
 Case 2
    Call jisuan_fdzl(zsds2, qdlc2, zhlc2, jslc2, s2, w2, fd2)
   Select Case fd2
    Case 1
    Call l2_xyzb1(qdlc2, jslc2, b2, x2, y2)
    Case 2
    Call l2_xyzb2(qdlc2, zhlc2, jslc2, a2, r2, s2, b2, x2, y2)
    Case 3
    Call l2_xyzb3(qdlc2, zhlc2, jslc2, a2, r2, s2, m2, p2, q2, b2, x2, y2)