📄 横净距计算.frm
字号:
VERSION 5.00
Begin VB.Form frmhjinj
BorderStyle = 1 'Fixed Single
Caption = "横净距计算"
ClientHeight = 4395
ClientLeft = 45
ClientTop = 345
ClientWidth = 4905
Icon = "横净距计算.frx":0000
KeyPreview = -1 'True
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4395
ScaleWidth = 4905
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton Command2
Caption = "关闭"
Height = 375
Left = 3840
TabIndex = 9
Top = 1680
Width = 975
End
Begin VB.CommandButton Command1
Caption = "计算"
Height = 375
Left = 2760
TabIndex = 7
Top = 1680
Width = 975
End
Begin VB.Frame Frame3
Caption = "中桩桩号"
Height = 615
Left = 0
TabIndex = 17
Top = 1440
Width = 2535
Begin VB.TextBox Text7
Height = 270
Left = 1440
TabIndex = 8
Text = "Text7"
Top = 240
Width = 975
End
Begin VB.Label Label7
Caption = "中桩桩号JZ＝"
Height = 255
Left = 120
TabIndex = 18
Top = 240
Width = 1215
End
End
Begin VB.Frame Frame2
Caption = "计算结果"
Height = 2175
Left = 0
TabIndex = 10
Top = 2160
Width = 4815
Begin VB.ListBox List1
Height = 1860
Left = 120
TabIndex = 19
Top = 240
Width = 4575
End
End
Begin VB.Frame Frame1
Caption = "原始数据"
Height = 1335
Left = 0
TabIndex = 1
Top = 0
Width = 4815
Begin VB.TextBox Text6
Height = 270
Left = 3720
TabIndex = 6
Text = "Text6"
Top = 960
Width = 975
End
Begin VB.TextBox Text5
Height = 270
Left = 3720
TabIndex = 5
Text = "Text5"
Top = 600
Width = 975
End
Begin VB.TextBox Text4
Height = 270
Left = 3720
TabIndex = 4
Text = "Text4"
Top = 240
Width = 975
End
Begin VB.TextBox Text3
Height = 270
Left = 1440
TabIndex = 3
Text = "Text3"
Top = 960
Width = 975
End
Begin VB.TextBox Text2
Height = 270
Left = 1440
TabIndex = 2
Text = "Text2"
Top = 600
Width = 975
End
Begin VB.TextBox Text1
Height = 270
Left = 1440
TabIndex = 0
Text = "Text1"
Top = 240
Width = 975
End
Begin VB.Label Label6
Caption = "视距长度S ＝"
Height = 255
Left = 2520
TabIndex = 16
Top = 960
Width = 1095
End
Begin VB.Label Label5
Caption = "路面宽度BB＝"
Height = 255
Left = 2520
TabIndex = 15
Top = 600
Width = 1335
End
Begin VB.Label Label4
Caption = "交点桩号JD＝"
Height = 255
Left = 2520
TabIndex = 14
Top = 240
Width = 1455
End
Begin VB.Label Label3
Caption = "缓和曲线长LS＝"
Height = 255
Left = 120
TabIndex = 13
Top = 960
Width = 1335
End
Begin VB.Label Label2
Caption = "中线半径 R ＝"
Height = 255
Left = 120
TabIndex = 12
Top = 600
Width = 1335
End
Begin VB.Label Label1
Caption = "偏角角度 PJ＝"
Height = 255
Left = 120
TabIndex = 11
Top = 240
Width = 1335
End
End
End
Attribute VB_Name = "frmhjinj"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim xsa(3000), ysa(3000) As Single
Const pi = 3.1415927
Dim pd As Integer, pj As Single, r0 As Single, ls0 As Single, bb As Single
Dim jd0 As Single, b As Single, S As Single, lz As Single, lq As Single
Dim t0 As Single, zh0 As Single, hy0 As Single, QZ0 As Single, yh0 As Single, hz0 As Single
Dim t1 As Single, zh1 As Single, hy1 As Single, qz1 As Single, yh1 As Single, hz1 As Single, jd1 As Single, r1 As Single, ls1 As Single
Private Sub Command1_Click()
'计算
On Error GoTo handlerror
If pd = 1 Then
jp = Val(Text1.Text)
Call dh(pj, jp)
r0 = Val(Text2.Text)
ls0 = Val(Text3.Text)
jd0 = Val(Text4.Text)
bb = Val(Text5.Text)
S = Val(Text6.Text)
'求路中线曲线要素
Call qxys(t0, zh0, hy0, QZ0, yh0, hz0, jd0, r0, ls0, pj)
List1.Clear
List1.AddItem ""
List1.AddItem "交点桩号 JD＝" + Str(jd0)
List1.AddItem "路线偏角 PJ＝" + Str(jp)
List1.AddItem "路中线半径 R ＝" + Str(r0)
List1.AddItem "缓和曲线长 LS＝" + Str(ls0)
List1.AddItem " ZH＝" + Str(Int(zh0 * 1000 + 0.5) / 1000)
List1.AddItem " HY＝" + Str(Int(hy0 * 1000 + 0.5) / 1000)
List1.AddItem " QZ＝" + Str(Int(QZ0 * 1000 + 0.5) / 1000)
List1.AddItem " YH＝" + Str(Int(yh0 * 1000 + 0.5) / 1000)
List1.AddItem " HZ＝" + Str(Int(hz0 * 1000 + 0.5) / 1000)
r1 = r0 - bb / 2 + 1.5
t = t0 - (bb / 2 - 1.5) * Tan(pj / 2)
ls = ls0
'迭代法求行车轨迹缓和曲线长
Do Until Abs(ls - ls1) < 0.01
ls1 = 2 * (t + ls ^ 3 / 240 / r1 / r1 - (r1 + ls * ls / 24 / r1) * Tan(pj / 2))
ls = ls1
Loop
jd1 = jd0 - (bb / 2 - 1.5) * Tan(pj / 2)
'求行车轨迹曲线要素
Call qxys(t1, zh1, hy1, qz1, yh1, hz1, jd1, r1, ls1, pj)
List1.AddItem ""
List1.AddItem "行车轨迹曲线交点桩号 JD1＝" + Str(Int(jd1 * 1000 + 0.5) / 1000)
List1.AddItem " 曲线半径 RS ＝" + Str(Int(r1 * 1000 + 0.5) / 1000)
List1.AddItem " 缓和曲线长 LS1＝" + Str(Int(ls1 * 1000 + 0.5) / 1000)
List1.AddItem " ZH1＝" + Str(Int(zh1 * 1000 + 0.5) / 1000)
List1.AddItem " HY1＝" + Str(Int(hy1 * 1000 + 0.5) / 1000)
List1.AddItem " QZ1＝" + Str(Int(qz1 * 1000 + 0.5) / 1000)
List1.AddItem " YH1＝" + Str(Int(yh1 * 1000 + 0.5) / 1000)
List1.AddItem " HZ1＝" + Str(Int(hz1 * 1000 + 0.5) / 1000)
lq = zh1 - S
lz = hz1 + S
n = 1
l1 = lq
'求视线端点坐标、相邻视线交点坐标XS、YS，形成视距曲线点集xsa(N)、ysa(N)
Do
Call lxy(x11, y11, l1, zh1, yh1, hz1, r1, ls1, t1)
l2 = l1 + S
l3 = l1 + 1
l4 = l3 + S
Call lxy(x22, y22, l2, zh1, yh1, hz1, r1, ls1, t1)
Call lxy(x33, y33, l3, zh1, yh1, hz1, r1, ls1, t1)
Call lxy(x44, y44, l4, zh1, yh1, hz1, r1, ls1, t1)
Call lds(xs, ys, x11, y11, x22, y22, x33, y33, x44, y44)
ys = ys + bb / 2 - 1.5
' MsgBox Str(Int(l1 * 100 + 0.5) / 100) + " " + Str(Int(xs * 100 + 0.5) / 100) + " " + Str(Int(ys * 100 + 0.5) / 100)
' MsgBox Str(Int(l1 * 100 + 0.5) / 100) & vbCrLf & Str(Int(x11 * 100 + 0.5) / 100) + " " + Str(Int(y11 * 100 + 0.5) / 100) & vbCrLf & Str(Int(x33 * 100 + 0.5) / 100) + " " + Str(Int(y33 * 100 + 0.5) / 100) & vbCrLf & Str(Int(x22 * 100 + 0.5) / 100) + " " + Str(Int(y22 * 100 + 0.5) / 100) & vbCrLf & Str(Int(x44 * 100 + 0.5) / 100) + " " + Str(Int(y44 * 100 + 0.5) / 100) & vbCrLf & Str(Int(xs * 100 + 0.5) / 100) + " " + Str(Int(ys * 100 + 0.5) / 100)
xsa(n) = xs
ysa(n) = ys
n = n + 1
l1 = l1 + 1
Loop While l4 <= lz
End If
ll = Val(Text7.Text)
If ll < 0 Or Text7.Text = "" Then Exit Sub
If ll > lz - 20 Or ll < lq + 20 Then
xiansh = MsgBox("中桩超出曲线范围，请重新输入。", vbInformation, "问题提示")
Exit Sub
End If
Call lxy(x0, y0, ll, zh0, yh0, hz0, r0, ls0, t0)
If ll > zh0 And ll < hz0 Then
l = ll - zh0
If ll > yh0 Then l = hz0 - ll
If l <= ls0 Then
k = -1 / Tan(l / 2 / r0)
If ll > yh0 Then k = -1 / Tan(pj - l / 2 / r0)
Else
fi = (l - ls0) / r0 + ls0 / 2 / r0
k = -1 / Tan(fi)
End If
Else
If ll <= zh0 Then k = 1E+30
If ll >= hz0 Then k = -1 / Tan(pj)
End If
i = 1
Do
xsi = xsa(i)
ysi = ysa(i)
xsii = xsa(i + 1)
ysii = ysa(i + 1)
Call dxs(x1, y1, x0, y0, k, xsi, ysi, xsii, ysii)
pd1 = (x1 - xsa(i + 1)) * (x1 - xsa(i))
pd2 = (y1 - ysa(i + 1)) * (y1 - ysa(i))
If pd1 <= 0 And pd2 <= 0 Then Exit Do
i = i + 1
Loop
hjj = Sqr((x1 - x0) ^ 2 + (y1 - y0) ^ 2) - (bb / 2 - 1.5)
List1.AddItem ""
List1.AddItem " 中桩桩号JZ＝" + Text7.Text
List1.AddItem " 横净距 W＝" + Str(Int(hjj * 1000 + 0.5) / 1000)
pd = 2
Text7.Text = ""
Text7.SetFocus
Exit Sub
handlerror:
xiansh = MsgBox("在计算时出错，请检查输入的数据。", vbExclamation, "问题提示")
End Sub
Private Sub Command2_Click()
'关闭
On Error GoTo handlerror
If Text1.Text = "" And Text2.Text = "" And Text3.Text = "" And Text4.Text = "" And Text5.Text = "" Then
Unload Me
Exit Sub
End If
If List1.ListCount > 1 And rjsfzc = 88 Then
frmMain.Text1 = frmMain.Text1 & vbCrLf & ""
frmMain.Text1 = frmMain.Text1 & vbCrLf & " 《横净距计算结果》："
For i = 0 To List1.ListCount - 1
frmMain.Text1 = frmMain.Text1 & vbCrLf & " " + List1.List(i)
Next i
frmMain.Text1 = frmMain.Text1 & vbCrLf & " --------------------------------------"
End If
Unload Me
Exit Sub
handlerror:
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
'Esc键退出，VbEscape可以用27代替
On Error GoTo handlerror
If KeyAscii = 27 Then
Unload Me
End If
Exit Sub
handlerror:
End Sub
Private Sub Form_Load()
'启动
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
Text4.Text = ""
Text5.Text = ""
Text6.Text = ""
Text7.Text = ""
List1.Clear
List1.AddItem "偏角角度按度分秒输入："
List1.AddItem " 如32°23′45″按32.2345输入"
pd = 1
End Sub
Public Sub dh(rad, dms)
'度分秒化弧度
Jd = Abs(dms)
d = Int(Jd)
m = Int(Jd * 100) - d * 100
S = Jd * 10000 - d * 10000 - m * 100
rad = d + m / 60 + S / 60 / 60
rad = rad * pi / 180
rad = rad * Sgn(dms)
End Sub
Sub qxys(t, zh, hy, qz, yh, hz, Jd, r, ls, pj1)
'曲线要素
p = ls * ls / 24 / r
q = ls / 2 - ls ^ 3 / 240 / r / r
b = ls / 2 / r
t = (r + p) * Tan(pj1 / 2) + q
e = (r + p) / Cos(pj1 / 2) - r
ly = (pj1 - 2 * b) * r
l = ly + 2 * ls
zh = Jd - t
hy = zh + ls
qz = hy + ly / 2
yh = hy + ly
hz = yh + ls
End Sub
Sub lxy(x, y, pl, zh, yh, hz, r, ls, t)
'求视线端点坐标、相邻视线交点坐标XS、YS，形成视距曲线点集xsa(N)、ysa(N)
p = ls * ls / 24 / r
q = ls / 2 - ls ^ 3 / 240 / r / r
b = ls / 2 / r
l = pl - zh
If pl > yh Then l = hz - pl
If l <= 0 Then
x = l
y = 0
If pl > yh Then
x1 = x - t
y1 = y
x = x1 * Cos(pj) + y1 * Sin(pj)
y = y1 * Cos(pj) - x1 * Sin(pj)
x = t - x
End If
Else
If l <= ls Then
x = l - l ^ 5 / 40 / r / r / ls / ls
y = l ^ 3 / 6 / r / ls - l ^ 7 / 336 / r ^ 3 / ls ^ 3
If pl > yh Then
x1 = x - t
y1 = y
x = x1 * Cos(pj) + y1 * Sin(pj)
y = y1 * Cos(pj) - x1 * Sin(pj)
x = t - x
End If
Else
fi = ((l - ls) / r + ls / 2 / r)
x = q + r * Sin(fi)
y = p + r * (1 - Cos(fi))
End If
End If
End Sub
Public Sub lds(xlds, ylds, x1, y1, x2, y2, x3, y3, x4, y4)
If x2 = x1 Then k3 = 1E+30 Else k3 = (y2 - y1) / (x2 - x1)
Call dxs(xlds, ylds, x1, y1, k3, x3, y3, x4, y4)
End Sub
Public Sub dxs(xdxs, ydxs, x3, y3, k2, x1, y1, x2, y2)
dx = x2 - x1
If dx = 0 Then
xdxs = x1
ydxs = y3 + k2 * (xdxs - x3)
Else
k1 = (y2 - y1) / (x2 - x1)
If k2 > 1E+29 Then
xdxs = x3
ydxs = y1 + k1 * (xdxs - x1)
Else
xdxs = (y3 - y1 + k1 * x1 - x3 * k2) / (k1 - k2)
ydxs = y3 + k2 * (xdxs - x3)
End If
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -