曲线任意里程中边桩坐标正反算

曲线任意里程中边桩坐标正反算(VB6.0)函数(5节点法提供测试程序代码）
使用说明：
1. 在VA或VAB中添加一个窗体，并将其"Caption"属性改为
    "曲线任意里程中边桩坐标正反算(VB6.0)  函数"
2. 在窗体上添加一个文本框，并将其下列属性更改为：
     名称                    txt1   
      MultiLine          True
      ScrollBars          3  Both
3. 在窗体上添加三个命令按钮，并将它们的下列属性更改为：
     按钮一
     名称                    Cmd1
     Caption                正算
     按钮二
     名称                    Cmd2
     Caption                反算
     按钮三
     名称                    Cmd3
     Caption                结束
4. 将以下程序复制到VA或VBA的代码窗口内，点击运行命令即进行测试。
Private Const pi As Double = 3.14159265358979
Private Const pi As Double = 3.14159265358979
Public Function qxzs(xyb() As Double, sz() As Double, fhz() As Double)
’正算函数(由里程和边距计算坐标)
’入口参数线元要素xyb()及sz()为:
’xyb(1)=线元起点里程  xyb(2)=线元起点X坐标 xyb(3)=线元起点Y坐标 xyb(4)=线元起点切线方位角(以弧度为单位)
’xyb(5)=线元长度  xyb(6)=线元起点曲率半径 xyb(7)=线元止点曲率半径 xyb(8)=线元偏向标志
’sz(1)=要计算点的中线里程 sz(2)=要计算点距中线的边距
’返回值fhz()为：
’fhz(1)=所求点的X坐标 fhz(2)=所求点的Y坐标 fhz(3)=所求点对应中线点向右的法线方位角
   Dim f0 As Double
   Dim q As Double
   Dim c As Double
   Dim d As Double
   Dim rr(5) As Double
   Dim vv(5) As Double
   Dim i As Integer
   Dim w As Double
   Dim xs As Double
   Dim ys As Double
   Dim ff As Double
   
   f0 = xyb(4): q = xyb(8)
   c = 1# / xyb(6)
   d = (xyb(6) - xyb(7)) / 2# / xyb(5) / xyb(6) / xyb(7)
   rr(1) = 0.1184634425: rr(2) = 0.2393143352
   rr(3) = 0.2844444444: rr(4) = rr(2): rr(5) = rr(1)
   vv(1) = 0.046910077: vv(2) = 0.2307653449
   vv(3) = 0.5: vv(4) = 1# - vv(2): vv(5) = 1# - vv(1)
   w = Abs(sz(1) - xyb(1))
   
   xs = 0: ys = 0
   For i = 1 To 5
       ff = f0 + q * vv(i) * w * (c + vv(i) * w * d)
       xs = xs + rr(i) * Cos(ff)
       ys = ys + rr(i) * Sin(ff)
   Next i
   
   fhz(3) = f0 + q * w * (c + w * d) + 0.5 * pi
   fhz(1) = xyb(2) + w * xs + sz(2) * Cos(fhz(3))
   fhz(2) = xyb(3) + w * ys + sz(2) * Sin(fhz(3))
      
End Function--------------------------------------------------------------------------------
Public Function qxfs(xyb() As Double, xpt() As Double, fhb() As Double)
’反算函数(由坐标计算里程和边距)
’入口参数线元要素xyb()及xpt()为:
’xyb(1)=线元起点里程  xyb(2)=线元起点X坐标 xyb(3)=线元起点Y坐标 xyb(4)=线元起点切线方位角(以弧度为单位)
’xyb(5)=线元长度  xyb(6)=线元起点曲率半径 xyb(7)=线元止点曲率半径 xyb(8)=线元偏向标志
’xpt(1)=要计算点的X坐标 xpt(2)=要计算点的Y坐标
’返回值fhb()为：
’fhb(1)=所求点的中线里程 fhb(2)=所求点距中线的边距
  Dim f0 As Double
   Dim q As Double
   Dim c As Double
   Dim d As Double
   Dim rr(4) As Double
   Dim vv(4) As Double
   Dim i As Integer
   Dim w As Double
   Dim xs As Double
   Dim ys As Double
   Dim ff As Double
   Dim z As Double
   Dim sz(2) As Double
   
   f0 = xyb(4): q = xyb(8)
   c = 1# / xyb(6)
   d = (xyb(6) - xyb(7)) / 2# / xyb(5) / xyb(6) / xyb(7)
   ft = f0 - 0.5 * pi
   w = Abs((xpt(2) - xyb(3)) * Cos(ft) - (xpt(1) - xyb(2)) * Sin(ft))
   z = 1
   
   ’Txt1.Text = Txt1.Text + "S0=" + Str(xyb(1)) + Chr(13) + Chr(10)
   
   Do While Abs(z) > 0.000001
      sz(1) = xyb(1) + w: sz(2) = z
      Call qxzs(xyb(), sz(), fhb())
      ff = ft + q * w * (c + w * d)
      z = (xpt(2) - fhb(2)) * Cos(ff) - (xpt(1) - fhb(1)) * Sin(ff)
      w = w + z
   Loop
   
    sz(1) = xyb(1) + w: sz(2) = 0
    Call qxzs(xyb(), sz(), fhb())
     
    fhb(1) = xyb(1) + w
    fhb(2) = (xpt(2) - fhb(2)) / Sin(fhb(3))
     
End Function--------------------------------------------------------------------------------
Private Sub Cmd1_Click()
   ’正算测试程序
   Dim qxxy(100, 8) As Double
   Dim xsz(100, 3) As Double
      
   ’线元要素表存入数组qxxy中，切线方位角以弧度为单位
   ’可采用读文本文件、Excel数据表中的数据或其它方式读入数据替代以下直接赋值方式
   qxxy(1, 1) = 500: qxxy(1, 2) = 19942.837: qxxy(1, 3) = 28343.561: qxxy(1, 4) = 2.186466069
   qxxy(1, 5) = 269.256: qxxy(1, 6) = 1E+45: qxxy(1, 7) = 1E+45: qxxy(1, 8) = 0
   
   qxxy(2, 1) = 769.256: qxxy(2, 2) = 19787.34: qxxy(2, 3) = 28563.378: qxxy(2, 4) = 2.186466069
   qxxy(2, 5) = 37.492: qxxy(2, 6) = 1E+45: qxxy(2, 7) = 221.75: qxxy(2, 8) = -1
   
   qxxy(3, 1) = 806.748: qxxy(3, 2) = 19766.566: qxxy(3, 3) = 28594.574: qxxy(3, 4) = 2.101929446
   qxxy(3, 5) = 112.779:  qxxy(3, 6) = 221.75: qxxy(3, 7) = 221.75: qxxy(3, 8) = -1
   
   qxxy(4, 1) = 919.527: qxxy(4, 2) = 19736.072: qxxy(4, 3) = 28701.893: qxxy(4, 4) = 1.593343217
   qxxy(4, 5) = 80.285: qxxy(4, 6) = 221.75: qxxy(4, 7) = 9579.228: qxxy(4, 8) = -1
   
   qxxy(5, 1) = 999.812: qxxy(5, 2) = 19744.038: qxxy(5, 3) = 28781.659: qxxy(5, 4) = 1.408141337
   qxxy(5, 5) = 100#: qxxy(5, 6) = 1E+45: qxxy(5, 7) = 1E+45: qxxy(5, 8) = 0
   
   ’将要计算坐标的里程桩号及距中线距离存入数组xsz中
   xsz(1, 1) = 700: xsz(1, 2) = -5
   xsz(2, 1) = 700: xsz(2, 2) = 0
   xsz(3, 1) = 700: xsz(3, 2) = 5
   
   xsz(4, 1) = 780: xsz(4, 2) = -5
   xsz(5, 1) = 780: xsz(5, 2) = 0
   xsz(6, 1) = 780: xsz(6, 2) = 5
   
   xsz(7, 1) = 870: xsz(7, 2) = -5
   xsz(8, 1) = 870: xsz(8, 2) = 0
   xsz(9, 1) = 870: xsz(9, 2) = 5
   
   xsz(10, 1) = 940: xsz(10, 2) = -5.123
   xsz(11, 1) = 940: xsz(11, 2) = 0
   xsz(12, 1) = 940: xsz(12, 2) = 3.009
   Dim i As Integer
   Dim j As Integer
   Dim k As Integer
   Dim ysb(8) As Double
   Dim wzb(3) As Double
   Dim jgb(3) As Double
   
   Txt1.Text = ""
   For i = 1 To 12
       For j = 1 To 5
           If qxxy(j, 1) <= xsz(i, 1) And xsz(i, 1) <= qxxy(j, 1) + qxxy(j, 5) Then
              For k = 1 To 8: ysb(k) = qxxy(j, k): Next k
              For k = 1 To 2: wzb(k) = xsz(i, k): Next k
              ’调用正算函数
              Call qxzs(ysb(), wzb(), jgb())
              Txt1.Text = Txt1.Text + Str(wzb(1)) + "  " + Str(wzb(2)) + Chr(13) + Chr(10)
              For k = 1 To 3
                 Txt1.Text = Txt1.Text + Str(jgb(k)) + Chr(13) + Chr(10)
              Next k
              Txt1.Text = Txt1.Text + Chr(13) + Chr(10)
              Exit For
           End If
        Next j
   Next i
   
End Sub--------------------------------------------------------------------------------
Private Sub Cmd2_Click()
   ’反算测试程序
   Dim qxxy(100, 8) As Double
   Dim xsz(100, 3) As Double
      
   ’线元要素表存入数组qxxy中，切线方位角以弧度为单位
   ’可采用读文本文件、Excel数据表中的数据或其它方式读入数据替代以下直接赋值方式
   qxxy(1, 1) = 500: qxxy(1, 2) = 19942.837: qxxy(1, 3) = 28343.561: qxxy(1, 4) = 2.186466069
   qxxy(1, 5) = 269.256: qxxy(1, 6) = 1E+45: qxxy(1, 7) = 1E+45: qxxy(1, 8) = 0
   
   qxxy(2, 1) = 769.256: qxxy(2, 2) = 19787.34: qxxy(2, 3) = 28563.378: qxxy(2, 4) = 2.186466069
   qxxy(2, 5) = 37.492: qxxy(2, 6) = 1E+45: qxxy(2, 7) = 221.75: qxxy(2, 8) = -1
   
   qxxy(3, 1) = 806.748: qxxy(3, 2) = 19766.566: qxxy(3, 3) = 28594.574: qxxy(3, 4) = 2.101929446
   qxxy(3, 5) = 112.779:  qxxy(3, 6) = 221.75: qxxy(3, 7) = 221.75: qxxy(3, 8) = -1
   
   qxxy(4, 1) = 919.527: qxxy(4, 2) = 19736.072: qxxy(4, 3) = 28701.893: qxxy(4, 4) = 1.593343217
   qxxy(4, 5) = 80.285: qxxy(4, 6) = 221.75: qxxy(4, 7) = 9579.228: qxxy(4, 8) = -1
   
   qxxy(5, 1) = 999.812: qxxy(5, 2) = 19744.038: qxxy(5, 3) = 28781.659: qxxy(5, 4) = 1.408141337
   qxxy(5, 5) = 100#: qxxy(5, 6) = 1E+45: qxxy(5, 7) = 1E+45: qxxy(5, 8) = 0
   
   ’将要反算里程桩号及距中线距离的点坐标存入数组xsz中
   ’由于没有提供判断点与线元关系的函数据，以下数据中的
   ’第一个数为里程桩号，用于确定所求点所在的线元
   xsz(1, 1) = 501: xsz(1, 2) = 19831.418: xsz(1, 3) = 28509.726
   xsz(2, 1) = 501: xsz(2, 2) = 19827.336: xsz(2, 3) = 28506.838
   xsz(3, 1) = 500: xsz(3, 2) = 19823.25398: xsz(3, 3) = 28503.95084
   
   xsz(4, 1) = 770: xsz(4, 2) = 19785.25749: xsz(4, 3) = 28575.0227
   xsz(5, 1) = 770: xsz(5, 2) = 19781.15561: xsz(5, 3) = 28572.16358
   xsz(6, 1) = 770: xsz(6, 2) = 19777.05373: xsz(6, 3) = 28569.30446
   
   xsz(7, 1) = 807: xsz(7, 2) = 19747.536: xsz(7, 3) = 28654.131
   xsz(8, 1) = 807: xsz(8, 2) = 19742.686: xsz(8, 3) = 28652.914
   xsz(9, 1) = 807: xsz(9, 2) = 19737.837: xsz(9, 3) = 28651.697
   
   xsz(10, 1) = 920: xsz(10, 2) = 19741.5912: xsz(10, 3) = 28722.058
   xsz(11, 1) = 920: xsz(11, 2) = 19736.4769: xsz(11, 3) = 28722.3564
   xsz(12, 1) = 920: xsz(12, 2) = 19733.473: xsz(12, 3) = 28722.5317

   Dim i As Integer
   Dim j As Integer
   Dim k As Integer
   Dim ysb(8) As Double
   Dim wzb(3) As Double
   Dim jgb(3) As Double
   
   Txt1.Text = ""
   For i = 1 To 12
       For j = 1 To 5
           If qxxy(j, 1) <= xsz(i, 1) And xsz(i, 1) < qxxy(j, 1) + qxxy(j, 5) Then
              For k = 1 To 8: ysb(k) = qxxy(j, k): Next k
              For k = 1 To 2: wzb(k) = xsz(i, k + 1): Next k
              ’调用反算函数
              Call qxfs(ysb(), wzb(), jgb())
              Txt1.Text = Txt1.Text + Str(wzb(1)) + "  " + Str(wzb(2)) + Chr(13) + Chr(10)
              For k = 1 To 3
                 Txt1.Text = Txt1.Text + Str(jgb(k)) + Chr(13) + Chr(10)
              Next k
              Txt1.Text = Txt1.Text + Chr(13) + Chr(10)
              Exit For
           End If
        Next j
   Next i
End Sub--------------------------------------------------------------------------------
Private Sub Cmd3_Click()
  End
End Sub