📄 jdjb.frm
字号:
TabIndex = 4
Text = "8476.35"
Top = 2280
Width = 1455
End
Begin VB.TextBox inls
BeginProperty Font
Name = "幼圆"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00800000&
Height = 370
Left = 1440
TabIndex = 3
Text = "60"
Top = 1845
Width = 1455
End
Begin VB.TextBox inr
BeginProperty Font
Name = "幼圆"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00800000&
Height = 370
Left = 1440
TabIndex = 2
Text = "200"
Top = 840
Width = 1455
End
Begin VB.TextBox inpj
BeginProperty Font
Name = "幼圆"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00800000&
Height = 370
Left = 1440
TabIndex = 1
Text = "33.0512"
Top = 400
Width = 1455
End
Begin VB.Label Label1
Caption = "路线偏角："
BeginProperty Font
Name = "幼圆"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 55
Top = 480
Width = 1095
End
Begin VB.Label Label2
Caption = "曲线半径："
BeginProperty Font
Name = "幼圆"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 54
Top = 960
Width = 1095
End
Begin VB.Label Label3
Caption = "缓和曲线长："
BeginProperty Font
Name = "幼圆"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 53
Top = 1920
Width = 1215
End
Begin VB.Label Label4
Caption = "交点桩号："
BeginProperty Font
Name = "幼圆"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 52
Top = 2400
Width = 1095
End
Begin VB.Label Label5
Caption = "桩距："
BeginProperty Font
Name = "幼圆"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 51
Top = 3360
Width = 1335
End
Begin VB.Label Label24
Caption = "保留小数："
BeginProperty Font
Name = "幼圆"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 50
Top = 3840
Width = 1095
End
End
Begin VB.Image Image1
Height = 900
Left = 840
Picture = "jdjb.frx":0058
Top = 120
Width = 6750
End
End
Attribute VB_Name = "jdjb"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim pj1 As Single, pj As Single, r As Single, ls As Single, jd As Single, zj As Single, t As Single, wj As Single, ly As Single, l As Single
Dim p As Single, q As Single, b As Single, zh As Single, hy As Single, qz As Single, yh As Single, hz As Single, fan As Integer
Dim zzh(100) As Single, zx(100) As Single, zy(100) As Single, i As Integer, jzzh(100) As String, szjd As Integer, pjstr As String
Private Sub Combo1_Click()
Select Case Combo1.ListIndex
Case 0
szjd = 0
Case 1
szjd = 1
Case 2
szjd = 2
Case 3
szjd = 3
Case 4
szjd = 4
Case 5
szjd = 5
End Select
End Sub
Private Sub exit_Click()
End
End Sub
Private Sub Form_Load()
Combo1.ListIndex = 2: szjd = 2
inpj.Text = "": inr.Text = "": xt.Value = 1: inls.BackColor = &H8000000F: inls.Text = ""
inls.Enabled = False: injd.Text = "": jz.Value = 1: inzj.Text = "20"
outjd.Text = "": outpj.Text = "": outr.Text = "": outt.Text = "": outly.Text = "": outpj.Text = ""
outls.Text = "": outwj.Text = "": outl.Text = ""
Fqxjz.Enabled = True
outzh.Text = "": outhy.Text = "": outqz.Text = "": outyh.Text = "": outhz.Text = ""
qxjzb.Clear
End Sub
Private Sub jz_Click()
If jz.Value = 1 Then
inzj.BackColor = &H8000000E
inzj.Enabled = True
Else
inzj.BackColor = &H8000000F
inzj.Text = "": inzj.Enabled = False
End If
End Sub
Private Sub ok_Click()
Dim i As Integer, temzh As Single, x As Single, fi As Single
fan = 0: qxjzb.DataChanged = True
qxjzb.Clear
If inpj.Text = "" Or inr.Text = "" Or injd.Text = "" Or xt.Value <> 1 And inls.Text = "" Or jz.Value = 1 And inzj.Text = "" Then
MsgBox "请将输入部分填写完整！", , "数据录入"
Exit Sub
Else
On Error GoTo jserr
pj1 = Val(inpj.Text): pjstr = dtodms(pj1): r = Val(inr.Text): jd = Val(injd.Text): pj = dh(pj1)
If fan <> 0 Then
MsgBox "您输入的路线偏角有错误！请您重新输入！(格式：按度分秒形式输入，如23度12分45秒，可输入为：23.1245)", , "输入错误"
Exit Sub
End If
If xt.Value = 1 Then
ls = pj / 2 * r: ls = CInt(ls)
Else
ls = Val(inls.Text)
End If
If jz.Value = 1 Then
zj = Val(inzj.Text)
Else
zj = 0
End If
p = ls * ls / 24 / r: q = ls / 2 - ls ^ 3 / 240 / r / r: b = ls / 2 / r
t = (r + p) * Tan(pj / 2) + q
wj = (r + p) / Cos(pj / 2) - r
ly = (pj - 2 * b) * r
l = ly + 2 * ls
zh = Round((jd - t), szjd): hy = Round((zh + ls), szjd): qz = Round((hy + ly / 2), szjd)
yh = Round((hy + ly), szjd): hz = Round((yh + ls), szjd)
Call qxjzsub
Call output
Exit Sub
End If
jserr:
MsgBox "输入错误！请重新输入！", vbOKOnly, "错误"
Call Form_Load
Exit Sub
End Sub
Private Sub sz_Click()
szjd = InputBox$("请输入要保留几位小数？", "设置精度")
End Sub
Private Sub re_Click()
Call Form_Load
Exit Sub
End Sub
Private Sub rejs_Click()
Call Form_Load
Exit Sub
End Sub
Private Sub sm_Click()
Form1.Show
End Sub
Private Sub TabStrip1_Click()
Select Case TabStrip1.SelectedItem.Key
Case "tzdlc"
Fzdlc.Visible = True
Fqxjz.Visible = False
Case "tqxjz"
Fqxjz.Visible = True
Fzdlc.Visible = False
End Select
End Sub
Private Sub xt_Click()
If xt.Value = 1 Then
inls.BackColor = &H8000000F
inls.Text = ""
inls.Enabled = False
Else
inls.BackColor = &H8000000E
inls.Enabled = True
End If
End Sub
Private Function dh(dms As Single) As Single
Dim jd As Single, d As Single, m As Single, s As Single, rad As Single
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 * 3.1415927 / 180: rad = rad * Sgn(dms)
dh = rad
End Function
Private Function qg(a1 As Single, b1 As Single, c1 As Single) As Single
Dim d As Single, x As Single
d = b1 ^ 2 - 4 * a1 * c1
If d < 0 Then qg = 0: Exit Function
x = (-b1 + Sqr(d)) / 2 / a1
qg = x
End Function
Private Sub output()
Dim o As Integer, msg As String
outjd.Text = bzh(jd)
outpj.Text = dtodms(pj1)
outr.Text = Str(Round(r, szjd))
outls.Text = Str(Round(ls, szjd))
outt.Text = Str(Round(t, szjd))
outwj.Text = Str(Round(wj, szjd))
outly.Text = Str(Round(ly, szjd))
outl.Text = Str(Round(l, szjd))
outzh.Text = bzh(zh)
outhy.Text = bzh(hy)
outqz.Text = bzh(qz)
outyh.Text = bzh(yh)
outhz.Text = bzh(hz)
If jz.Value = 1 Then
For o = 0 To i - 1
jzzh(o) = bzh(zzh(o)): zx(o) = Round(zx(o), szjd): zy(o) = Round(zy(o), szjd)
msg = jzzh(o) + " " + Str(zx(o)) + " " + Str(zy(o))
qxjzb.AddItem msg
Next o
End If
End Sub
Private Function bzh(ybzh As Single) As String
Dim k As Single, k1 As Single
ybzh = Round(ybzh, szjd)
k = Int(ybzh / 1000): k1 = ybzh - k * 1000
bzh = "K" + LTrim(Str(k)) + "+" + LTrim(Str(Round(k1, szjd)))
End Function
Private Sub qxjzsub()
Dim temzh As Single, x As Single, lf As Single
If zj <> 0 Then
Dim tem As Single, yy As Integer, zz As Integer
tem = zh - Int(zh): yy = 0
i = 0: temzh = zh + (zj - ((Int(zh) Mod zj) + tem))
Do Until temzh > hz
x = temzh - zh: If temzh > qz Then x = hz - temzh
If x < ls Then
If yh < temzh And temzh - yh < zj Then
If zz = 0 Then
zzh(i) = yh
zx(i) = q + r * Sin(ls / 2 / r)
zy(i) = p + r * (1 - Cos(ls / 2 / r))
temzh = zzh(i - 1)
zz = 1
GoTo jz
End If
End If
zx(i) = x - x ^ 5 / 40 / r / r / ls / ls
zy(i) = x ^ 3 / 6 / r / ls - x ^ 7 / 336 / r ^ 3 / ls ^ 3
Else
If temzh - hy < zj Then
If yy = 0 Then
zzh(i) = hy
zx(i) = q + r * Sin(ls / 2 / r)
zy(i) = p + r * (1 - Cos(ls / 2 / r))
temzh = zzh(i - 1)
yy = 1
GoTo jz
End If
End If
fi = ((x - ls) / r + ls / 2 / r)
zx(i) = q + r * Sin(fi)
zy(i) = p + r * (1 - Cos(fi))
End If
zzh(i) = temzh
jz:
i = i + 1
temzh = temzh + zj
Loop
End If
End Sub
Private Sub save_click()
Dim filename As String
filename = InputBox$("请输入要保存的文件名", "保存成果")
If filename = "" Then Exit Sub
On Error GoTo err1
Open filename For Output As #1
Print #1, " 单交点基本平曲线设计成果"
Print #1, "-----------------------------------------------------------"
Print #1, "曲线的基本要素："
Print #1, " 路线偏角:"; dtodms(pj1), "园曲线半径:"; Round(r, szjd); "米"
Print #1, " 缓和曲线长:"; Round(ls, szjd); "米", " 切线长:"; Round(t, szjd); "米"
Print #1, " 外距长:"; Round(wj, szjd); "米", "中间圆曲线长:"; Round(ly, szjd); "米"
Print #1, " 平曲线总长:"; Round(l, szjd); "米"
Print #1, "-----------------------------------------------------------"
Print #1, "曲线的主点里程："
Print #1, " ZH点："; bzh(zh), "HY点："; bzh(hy)
Print #1, " QZ点："; bzh(qz), "YH点："; bzh(yh)
Print #1, " HZ点："; bzh(hz)
Print #1, "-----------------------------------------------------------"
Print #1, "曲线加桩一览表:"
Print #1, " 加桩里程 支距X值 支距Y值"
For o = 0 To i - 1
Print #1, jzzh(o) + " " + Str(zx(o)) + " " + Str(zy(o))
Next o
Print #1, "___________________________________________________________"
Print #1, " Copyright by 星梦软件工作室"
Close #1
MsgBox "存取成功！", , "保存文件"
Exit Sub
err1:
MsgBox Err.Description, , "存取错误！"
End Sub
Private Function dtodms(ybd As Single) As String
Dim d As Integer, m As Integer, s As Integer
d = Round(ybd, 0): m = Round((ybd - d) * 100, 0): s = Round((ybd - d - m / 100) * 10000, 0)
dtodms = LTrim(Str(d)) + "度" + LTrim(Str(m)) + "分" + LTrim(Str(s)) + "秒"
If m >= 60 Or s >= 60 Then fan = 1
Exit Function
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -