form1.frm

铁路及公路中线坐标计算程序

If int4 = vbOK Then
24:  s3 = Right(x(3 * i), 16)
End If
End If
s5 = "*11" & s1 & "+" & s2 & " 81..00" & fh1 & s3 & " 82..00" & fh2 & s4 & " "
Print #2, s5
ElseIf Option7.Value Or Option8.Value Then
Dim s11 As String * 4
Dim s12 As String * 8
Dim s13 As String * 8
Dim s14 As String * 8
If i <= 9999 Then
s11 = 加0(4, i)
Else
If int1 = 1 Then GoTo 31
int1 = MsgBox("数据的数量大于9999，是否改变序号输出？", , "确定")
If int1 = vbOK Then
31: s11 = 9999
End If
End If
If Len(x(3 * i - 2)) <= 8 Then
s12 = 加0(8, x(3 * i - 2))
Else
If int2 = 1 Then GoTo 32
int2 = MsgBox("点的里程位数大于8，是否依然输出？", , "确定")
If int2 = vbOK Then
32: s12 = Right(x(3 * i - 2), 8)
End If
End If
If x(3 * i - 1) > 0 Then
fh1 = "+"
Else
fh1 = "-"
End If

x(3 * i - 1) = x(3 * i - 1) * 1000
If Len(x(3 * i - 1)) <= 8 Then
s14 = 加0(8, x(3 * i - 1))
Else
If int3 = 1 Then GoTo 33
int3 = MsgBox("点的X坐标位数大于8，是否依然输出？", , "确定")
If int3 = vbOK Then
33:  s14 = Right(x(3 * i - 1), 8)
End If
End If
If x(3 * i) > 0 Then
fh2 = "+"
Else
fh2 = "-"
End If
x(3 * i) = x(3 * i) * 1000
If Len(x(3 * i)) <= 8 Then
s13 = 加0(8, x(3 * i))
Else
If int4 = 1 Then GoTo 34
int4 = MsgBox("点的Y坐标位数大于8，是否依然输出？", , "确定")
If int4 = vbOK Then
34:  s13 = Right(x(3 * i), 8)
End If
End If
If Option7.Value Then
s5 = "11" & s11 & "+" & s12 & " 81..00" & fh1 & s13 & " 82..00" & fh2 & s14 & " "
ElseIf Option8.Value Then
s5 = "11" & s11 & "+" & s12 & " 81..10" & fh1 & s13 & " 82..10" & fh2 & s14 & " "
End If
Print #2, s5
ElseIf Option4.Value Then
Print #2, x(3 * i - 2) & ",," & x(3 * i) & "," & x(3 * i - 1) & ",0"
End If
Next
Close #2
ElseIf Option5.Value Then
CommonDialog1.ShowSave
Open CommonDialog1.FileName For Output As #2
For i = 1 To nn
Print #2, qxxx(6 * i - 5) & ","; qxxx(6 * i - 4) & ","; qxxx(6 * i - 3) & ","; qxxx(6 * i - 2) & ","; qxxx(6 * i - 1) & ","; qxxx(6 * i)
Next
Close #2
ElseIf Option9.Value Then
CommonDialog1.ShowSave
Open CommonDialog1.FileName For Output As #2
For i = 1 To wn
If i Mod 5 = 1 Then
Print #2, "第" & i \ 5 + 1 & "曲线五大桩："
End If
Print #2, wdzh(3 * i - 2) & "," & wdzh(3 * i - 1) & "," & wdzh(3 * i)
Next
Close #2
ElseIf Option10.Value Then

CommonDialog1.ShowSave
Open CommonDialog1.FileName For Output As #2

For i = 1 To wn / 5

Print #2, "第" & i & "切线坐标："

'zh坐标

lll(1) = wdzh(15 * i - 14)
xxx(1) = wdzh(15 * i - 13)
yyy(1) = wdzh(15 * i - 12)


'交点坐标
lll(2) = qxxx(6 * i - 3) '切线长
xxx(2) = qxxx(6 * i - 5)
yyy(2) = qxxx(6 * i - 4)


'hz坐标

lll(3) = wdzh(15 * i - 2)
xxx(3) = wdzh(15 * i - 1)
yyy(3) = wdzh(15 * i - 0)

Dim aaf1 As Double
Dim aaf2 As Double

aaf1 = af(xxx(1), yyy(1), xxx(2), yyy(2))
lll(0) = Int(lll(1) / 2) * 2
Do
lll(0) = lll(0) + 2
If lll(0) > lll(1) + lll(2) Then Exit Do

xxx(0) = xxx(1) + (lll(0) - lll(1)) * Cos(aaf1)
yyy(0) = yyy(1) + (lll(0) - lll(1)) * Sin(aaf1)
Print #2, "A" & Format(lll(0), "0.00") & "," & Format(yyy(0), "0.000") & "," & Format(xxx(0), "0.000")
Loop
aaf2 = af(xxx(3), yyy(3), xxx(2), yyy(2))
lll(0) = Int(lll(3) / 2) * 2
Do
lll(0) = lll(0) - 2
If lll(0) < lll(3) - lll(2) Then Exit Do
xxx(0) = xxx(3) + (lll(3) - lll(0)) * Cos(aaf2)
yyy(0) = yyy(3) + (lll(3) - lll(0)) * Sin(aaf2)
Print #2, "B" & Format(lll(0), "0.00") & "," & Format(yyy(0), "0.000") & "," & Format(xxx(0), "0.000")
Loop




Next
Close #2

End If
errorhandler:
If Err.Number = 75 Then
Exit Sub
End If
End Sub

Private Function 加0(n, s)
n1 = Len(s)
For i = 1 To n - n1
s = "0" & s
Next
加0 = s

End Function


Private Function 直线(x1, y1, l, jj, x2, y2)
a = xlu(x1, y1, x2, y2)
l1 = (Int(l / jj) + 1) * jj
s = Sqr((x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2))
n = Int((s - l1 + l) / jj) + 1
Dim x()
ReDim x(1 To 3 * n)
For i = 1 To n
x(3 * i - 2) = l1 + (i - 1) * jj
x(3 * i - 1) = x1 + (l1 - l + (i - 1) * jj) * Cos(a)
x(3 * i) = y1 + (l1 - l + (i - 1) * jj) * Sin(a)
Next
直线 = x()
End Function

Private Function 缓和曲线(x1, y1, x2, y2, l0, jj, lzh, l, r, m, p, a1, a2, w)
Dim x(), y(), xy()
lhz = lzh + l
qx = (Int(lzh / jj)) * jj
Do While li < l0
n1 = n1 + 1
ReDim Preserve x(1 To 3 * n1)
x(3 * n1 - 2) = qx + n1 * jj
li = x(3 * n1 - 2) - lzh
x(3 * n1 - 1) = xxh(li, l0, r)
If w = 2 Then
x(3 * n1) = -yyh(li, l0, r)        '如为左偏，Y取负值
ElseIf w = 1 Then
x(3 * n1) = yyh(li, l0, r)            '如为右偏，Y取正值
End If
Loop
n1 = n1 - 1
x11 = lzh + l0
x11 = Format(x11, "0.000")
x12 = xxh(l0, l0, r)
If w = 2 Then
x13 = -yyh(l0, l0, r)        '如为左偏，Y取负值
ElseIf w = 1 Then
x13 = yyh(l0, l0, r)            '如为右偏，Y取正值
End If

Do While li < l / 2
n1 = n1 + 1
ReDim Preserve x(1 To 3 * n1)
x(3 * n1 - 2) = qx + n1 * jj
li = x(3 * n1 - 2) - lzh
x(3 * n1 - 1) = xxy(li, l0, r, m)
If w = 2 Then
x(3 * n1) = -yyy(li, l0, r, p)
ElseIf w = 1 Then
x(3 * n1) = yyy(li, l0, r, p)
End If
Loop
n1 = n1 - 1
x21 = lzh + l / 2
x21 = Format(x21, "0.000")
x22 = xxy(l / 2, l0, r, m)
If w = 2 Then
x23 = -yyy(l / 2, l0, r, p)     '如为左偏，Y取负值
ElseIf w = 1 Then
x23 = yyy(l / 2, l0, r, p)         '如为右偏，Y取正值
End If

li = 0
zx = (Int(lhz / jj) + 1) * jj
Do While li < l0
n2 = n2 + 1
ReDim Preserve y(1 To 3 * n2)
y(3 * n2 - 2) = zx - n2 * jj
li = lhz - y(3 * n2 - 2)
y(3 * n2 - 1) = xxh(li, l0, r)
If w = 2 Then
y(3 * n2) = yyh(li, l0, r)
ElseIf w = 1 Then
y(3 * n2) = -yyh(li, l0, r)
End If
Loop
n2 = n2 - 1
y11 = lhz - l0
y11 = Format(y11, "0.000")
li = lhz - y11
y12 = xxh(l0, l0, r)
If w = 2 Then
y13 = yyh(l0, l0, r)
ElseIf w = 1 Then
y13 = -yyh(l0, l0, r)
End If

Do While li < l / 2
n2 = n2 + 1
ReDim Preserve y(1 To 3 * n2)
y(3 * n2 - 2) = zx - n2 * jj
li = lhz - y(3 * n2 - 2)
y(3 * n2 - 1) = xxy(li, l0, r, m)
If w = 2 Then
y(3 * n2) = yyy(li, l0, r, p)
ElseIf w = 1 Then
y(3 * n2) = -yyy(li, l0, r, p)
End If
Loop
n2 = n2 - 1
ReDim xy(1 To 3 * (n1 + n2 + 5))
For i = 1 To n1
xy(3 * i - 2) = x(3 * i - 2)
xy(3 * i - 1) = zbzhx(x(3 * i - 1), x(3 * i), x1, a1)
xy(3 * i) = zbzhy(x(3 * i - 1), x(3 * i), y1, a1)
Next
a2 = a2 - pi
If a2 < 0 Then a2 = a2 + 2 * pi

For i = 1 To n2
xy(3 * (i + n1) - 2) = y(3 * (n2 - i + 1) - 2)
xy(3 * (i + n1) - 1) = zbzhx(y(3 * (n2 - i + 1) - 1), y(3 * (n2 - i + 1)), x2, a2)
xy(3 * (i + n1)) = zbzhy(y(3 * (n2 - i + 1) - 1), y(3 * (n2 - i + 1)), y2, a2)
Next


xy(3 * (n1 + n2 + 1) - 2) = Format(lzh, "0.000")   '计算五大桩
xy(3 * (n1 + n2 + 1) - 1) = x1
xy(3 * (n1 + n2 + 1)) = y1

xy(3 * (n1 + n2 + 2) - 2) = Format(x11, "0.000")
xy(3 * (n1 + n2 + 2) - 1) = zbzhx(x12, x13, x1, a1)
xy(3 * (n1 + n2 + 2)) = zbzhy(x12, x13, y1, a1)

xy(3 * (n1 + n2 + 3) - 2) = Format(x21, "0.000")
xy(3 * (n1 + n2 + 3) - 1) = zbzhx(x22, x23, x1, a1)
xy(3 * (n1 + n2 + 3)) = zbzhy(x22, x23, y1, a1)

xy(3 * (n1 + n2 + 4) - 2) = Format(y11, "0.000")
xy(3 * (n1 + n2 + 4) - 1) = zbzhx(y12, y13, x2, a2)
xy(3 * (n1 + n2 + 4)) = zbzhx(y12, y13, y2, a2)

xy(3 * (n1 + n2 + 5) - 2) = Format(lhz, "0.000")
xy(3 * (n1 + n2 + 5) - 1) = x2
xy(3 * (n1 + n2 + 5)) = y2





缓和曲线 = xy()

End Function



Private Function xxh(li, l0, r)                '缓和曲线上的X坐标
x = li - li ^ 5 / (40 * r * r * l0 * l0) + li ^ 9 / (3456 * r ^ 4 * l0 ^ 4)
xxh = x
End Function

Private Function yyh(li, l0, r)                  '缓和曲线上的Y坐标
y = li ^ 3 / (6 * r * l0) - li ^ 7 / (336 * r ^ 3 * l0 ^ 3) + li ^ 11 / (42240 * r ^ 5 * l0 ^ 5)
yyh = y
End Function
Private Function xxy(li, l0, r, m)
x = r * Sin((li - 0.5 * l0) / r) + m              '圆曲线上的X坐标
xxy = x
End Function
Private Function yyy(li, l0, r, p)
y = r * (1 - Cos((li - 0.5 * l0) / r)) + p         '圆曲线上的Y坐标
yyy = y
End Function

Public Function zbzhx(x, y, x1, a)
s = x1 + x * Cos(a) - y * Sin(a)              'X坐标转换
zbzhx = s
End Function
Public Function zbzhy(x, y, y1, a)
s = y1 + x * Sin(a) + y * Cos(a)               'Y坐标转换
zbzhy = s
End Function




Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Option10_Click()

If Option10.Value Then
Option1.Enabled = False
Option2.Enabled = False
Option3.Enabled = False
Option6.Enabled = False
Option7.Enabled = False
Option8.Enabled = False
End If
End Sub


Private Sub Option4_Click()
If Option4.Value Then
Option1.Enabled = True
Option2.Enabled = True
Option3.Enabled = True
Option6.Enabled = True
Option7.Enabled = True
Option8.Enabled = True

End If
End Sub

Private Sub Option5_Click()
If Option5.Value Then
Option1.Enabled = False
Option2.Enabled = False
Option3.Enabled = False
Option6.Enabled = False
Option7.Enabled = False
Option8.Enabled = False

End If
End Sub
Private Sub Option9_Click()
If Option9.Value Then
Option1.Enabled = False
Option2.Enabled = False
Option3.Enabled = False
Option6.Enabled = False
Option7.Enabled = False
Option8.Enabled = False

End If
End Sub