📄 缓和曲线统一坐标.frm
字号:
VERSION 5.00
Begin VB.Form frmtyzhb
BorderStyle = 1 'Fixed Single
Caption = "缓和曲线计算"
ClientHeight = 3780
ClientLeft = 45
ClientTop = 345
ClientWidth = 6090
Icon = "缓和曲线统一坐标.frx":0000
KeyPreview = -1 'True
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3780
ScaleWidth = 6090
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton Command3
Caption = "关闭"
Height = 375
Left = 5040
TabIndex = 19
Top = 3360
Width = 975
End
Begin VB.CommandButton Command2
Caption = "曲线要素"
Height = 375
Left = 3960
TabIndex = 18
Top = 3360
Width = 975
End
Begin VB.CommandButton Command1
Caption = "加桩计算"
Height = 375
Left = 1320
TabIndex = 17
Top = 3360
Width = 975
End
Begin VB.Frame Frame4
Caption = "计算结果"
Height = 3255
Left = 2400
TabIndex = 15
Top = 0
Width = 3615
Begin VB.ListBox List1
Height = 2940
Left = 120
TabIndex = 16
Top = 240
Width = 3375
End
End
Begin VB.Frame Frame3
Caption = "加桩桩号"
Height = 615
Left = 0
TabIndex = 12
Top = 2640
Width = 2295
Begin VB.TextBox Text6
Height = 270
Left = 1200
TabIndex = 14
Text = "Text6"
Top = 240
Width = 975
End
Begin VB.Label Label6
Caption = "加桩桩号JZ＝"
Height = 255
Left = 120
TabIndex = 13
Top = 240
Width = 1215
End
End
Begin VB.Frame Frame2
Caption = "加桩间距"
Height = 615
Left = 0
TabIndex = 9
Top = 1920
Width = 2295
Begin VB.TextBox Text5
Height = 270
Left = 1200
TabIndex = 11
Text = "Text5"
Top = 240
Width = 975
End
Begin VB.Label Label5
Caption = "加桩间距Lj＝"
Height = 255
Left = 120
TabIndex = 10
Top = 240
Width = 1095
End
End
Begin VB.Frame Frame1
Caption = "原始数据"
Height = 1815
Left = 0
TabIndex = 0
Top = 0
Width = 2295
Begin VB.TextBox Text4
Height = 270
Left = 1200
TabIndex = 8
Text = "Text4"
Top = 1440
Width = 975
End
Begin VB.TextBox Text3
Height = 270
Left = 1200
TabIndex = 7
Text = "Text3"
Top = 1080
Width = 975
End
Begin VB.TextBox Text2
Height = 270
Left = 1200
TabIndex = 6
Text = "Text2"
Top = 720
Width = 975
End
Begin VB.TextBox Text1
Height = 270
Left = 1200
TabIndex = 5
Text = "Text1"
Top = 360
Width = 975
End
Begin VB.Label Label4
Caption = "缓和曲线LS＝"
Height = 255
Left = 120
TabIndex = 4
Top = 1440
Width = 1335
End
Begin VB.Label Label3
Caption = "偏角角度AL＝"
Height = 255
Left = 120
TabIndex = 3
Top = 1080
Width = 1215
End
Begin VB.Label Label2
Caption = "曲线半径R ＝"
Height = 255
Left = 120
TabIndex = 2
Top = 720
Width = 1095
End
Begin VB.Label Label1
Caption = "交点桩号JD＝"
Height = 255
Left = 120
TabIndex = 1
Top = 360
Width = 1215
End
End
End
Attribute VB_Name = "frmtyzhb"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim zh As Single, hy As Single, qz As Single, yh As Single, hz As Single
Dim jd As Single, r As Single, al As Single, ls As Single
Dim hudu As Single, bt As Single
Dim th As Single, eh As Single, lh As Single
Dim p As Single, q As Single, jz As Single
Const pi = 3.1415927
Private Sub Command1_Click()
'加桩计算
On Error GoTo handlerror
jz = Val(Text6.Text)
If jz <= zh Then
x = jz - zh
y = 0
End If
If jz > zh And jz <= hy Then
l = jz - zh
x = l - l ^ 5 / 40 / r / r / ls / ls
y = l * l * l / 6 / r / ls - l ^ 7 / 336 / r / r / r / ls / ls / ls
End If
If jz > hy And jz <= yh Then
l = jz - hy
fi = l / r + bt
x = r * Sin(fi) + q
y = r * (1 - Cos(fi)) + p
End If
If jz > yh And jz <= hz Then
l = hz - jz
x1 = l - l ^ 5 / 40 / r / r / ls / ls
y1 = l * l * l / 6 / r / ls - l ^ 7 / 336 / r / r / r / ls / ls / ls
x = th * (1 + Cos(hudu)) - x1 * Cos(hudu) - y1 * Sin(hudu)
y = th * Sin(hudu) - x1 * Sin(hudu) + y1 * Cos(hudu)
End If
If jz > hz Then
x1 = jz - hz
y1 = 0
x = (1 + Cos(hudu)) * th + x1 * Cos(hudu)
y = (th + x1) * Sin(hudu)
End If
wb1 = "JZ＝" + Trim(Str(jz))
chdu = Len(wb1)
If chdu = 1 Then wb1 = wb1 + " "
If chdu = 2 Then wb1 = wb1 + " "
If chdu = 3 Then wb1 = wb1 + " "
If chdu = 4 Then wb1 = wb1 + " "
If chdu = 5 Then wb1 = wb1 + " "
If chdu = 6 Then wb1 = wb1 + " "
If chdu = 7 Then wb1 = wb1 + " "
If chdu = 8 Then wb1 = wb1 + " "
wb2 = wb1 + "X＝" + Trim(Str(Int(x * 1000 + 0.5) / 1000))
chdu = Len(wb2)
If chdu = 9 Then wb2 = wb2 + " "
If chdu = 10 Then wb2 = wb2 + " "
If chdu = 11 Then wb2 = wb2 + " "
If chdu = 12 Then wb2 = wb2 + " "
If chdu = 13 Then wb2 = wb2 + " "
If chdu = 14 Then wb2 = wb2 + " "
If chdu = 15 Then wb2 = wb2 + " "
If chdu = 16 Then wb2 = wb2 + " "
If chdu = 17 Then wb2 = wb2 + " "
If chdu = 18 Then wb2 = wb2 + " "
If chdu = 19 Then wb2 = wb2 + " "
If chdu = 20 Then wb2 = wb2 + ""
List1.AddItem wb2 + " Y＝" + Trim(Str(Int(y * 1000 + 0.5) / 1000))
Text6.Text = ""
Text6.SetFocus
Exit Sub
handlerror:
xiansh = MsgBox("在计算加桩时出错。", vbExclamation, "问题提示")
End Sub
Private Sub Command2_Click()
'曲线要素计算
On Error GoTo handlerror
jd = Val(Text1.Text)
r = Val(Text2.Text)
al = Abs(Val(Text3.Text))
du = Int(al)
fen = Int(al * 100) - du * 100
miao = al * 10000 - du * 10000 - fen * 100
hudu = (du + fen / 60 + miao / 60 / 60) * pi / 180
ls = Val(Text4.Text)
bt = ls / 2 / r
If hudu < 2 * bt Then
xiansh = MsgBox("请增大曲线半径或减少缓和曲线长。", vbExclamation, "问题提示")
Exit Sub
End If
p = ls * ls / 24 / r
q = ls / 2 - ls * ls * ls / 240 / r / r
th = (r + p) * Tan(hudu / 2) + q
lh = (hudu - 2 * bt) * r + 2 * ls
eh = (r + p) / Cos(hudu / 2) - r
zh = jd - th
hy = zh + ls
qz = zh + lh / 2
yh = zh + lh - ls
hz = zh + lh
List1.Clear
List1.AddItem "原始数据：－－－－－－－－－－"
List1.AddItem "交点桩号JD＝" + Str(jd)
List1.AddItem "曲线半径R ＝" + Str(r)
List1.AddItem "偏角角度AL＝" + Str(al)
List1.AddItem "缓和曲线LS＝" + Str(ls)
List1.AddItem ""
List1.AddItem "曲线要素：－－－－－－－－－－"
List1.AddItem " P ＝" + Str(Int(p * 1000 + 0.5) / 1000)
List1.AddItem " Q ＝" + Str(Int(q * 1000 + 0.5) / 1000)
List1.AddItem " TH＝" + Str(Int(th * 1000 + 0.5) / 1000)
List1.AddItem " LH＝" + Str(Int(lh * 1000 + 0.5) / 1000)
List1.AddItem " EH＝" + Str(Int(eh * 1000 + 0.5) / 1000)
List1.AddItem " ZH＝" + Str(Int(zh * 1000 + 0.5) / 1000)
List1.AddItem " HY＝" + Str(Int(hy * 1000 + 0.5) / 1000)
List1.AddItem " QZ＝" + Str(Int(qz * 1000 + 0.5) / 1000)
List1.AddItem " YH＝" + Str(Int(yh * 1000 + 0.5) / 1000)
List1.AddItem " HZ＝" + Str(Int(hz * 1000 + 0.5) / 1000)
List1.AddItem ""
List1.AddItem "加桩坐标：－－－－－－－－－－"
LJ = Val(Text5.Text)
If LJ = 0 Then
Exit Sub
End If
jz = Int(zh / LJ + 1) * LJ
Do While jz <= hz
If jz <= zh Then
x = jz - zh
y = 0
End If
If jz > zh And jz <= hy Then
l = jz - zh
x = l - l ^ 5 / 40 / r / r / ls / ls
y = l * l * l / 6 / r / ls - l ^ 7 / 336 / r / r / r / ls / ls / ls
End If
If jz > hy And jz <= yh Then
l = jz - hy
fi = l / r + bt
x = r * Sin(fi) + q
y = r * (1 - Cos(fi)) + p
End If
If jz > yh And jz <= hz Then
l = hz - jz
x1 = l - l ^ 5 / 40 / r / r / ls / ls
y1 = l * l * l / 6 / r / ls - l ^ 7 / 336 / r / r / r / ls / ls / ls
x = th * (1 + Cos(hudu)) - x1 * Cos(hudu) - y1 * Sin(hudu)
y = th * Sin(hudu) - x1 * Sin(hudu) + y1 * Cos(hudu)
End If
If jz > hz Then
x1 = jz - hz
y1 = 0
x = (1 + Cos(hudu)) * th + x1 * Cos(hudu)
y = (th + x1) * Sin(hudu)
End If
wb1 = "JZ＝" + Trim(Str(jz))
chdu = Len(wb1)
If chdu = 1 Then wb1 = wb1 + " "
If chdu = 2 Then wb1 = wb1 + " "
If chdu = 3 Then wb1 = wb1 + " "
If chdu = 4 Then wb1 = wb1 + " "
If chdu = 5 Then wb1 = wb1 + " "
If chdu = 6 Then wb1 = wb1 + " "
If chdu = 7 Then wb1 = wb1 + " "
If chdu = 8 Then wb1 = wb1 + " "
wb2 = wb1 + "X＝" + Trim(Str(Int(x * 1000 + 0.5) / 1000))
chdu = Len(wb2)
If chdu = 9 Then wb2 = wb2 + " "
If chdu = 10 Then wb2 = wb2 + " "
If chdu = 11 Then wb2 = wb2 + " "
If chdu = 12 Then wb2 = wb2 + " "
If chdu = 13 Then wb2 = wb2 + " "
If chdu = 14 Then wb2 = wb2 + " "
If chdu = 15 Then wb2 = wb2 + " "
If chdu = 16 Then wb2 = wb2 + " "
If chdu = 17 Then wb2 = wb2 + " "
If chdu = 18 Then wb2 = wb2 + " "
If chdu = 19 Then wb2 = wb2 + " "
If chdu = 20 Then wb2 = wb2 + ""
List1.AddItem wb2 + " Y＝" + Trim(Str(Int(y * 1000 + 0.5) / 1000))
jz = jz + LJ
Loop
Command1.Enabled = True
Text6.SetFocus
Exit Sub
handlerror:
xiansh = MsgBox("在计算曲线要素时出错，请检查输入的数据。", vbExclamation, "问题提示")
End Sub
Private Sub Command3_Click()
'关闭
On Error GoTo handlerror
If Text1.Text = "" And Text2.Text = "" And Text3.Text = "" And Text4.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 = ""
List1.Clear
List1.AddItem "偏角按度分秒输入："
List1.AddItem "如32°23′19″按32.2319输入"
List1.AddItem ""
List1.AddItem "本程序的X、Y是"
List1.AddItem "以ZH为原点的统一坐标。"
Command1.Enabled = False
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -