Attribute VB_Name = "Engineering_Jdf"
'￥￥￥￥￥￥￥￥￥￥￥￥￥'
' '
'作者 Q Q：295188316 '
'作者网站：www.fffsky.com '
' '
'￥￥￥￥￥￥￥￥￥￥￥￥￥'
Option Explicit
Dim a As Double
Dim f As Double
Dim z As Double
Dim z17 As Double
Dim z20 As Double
Dim n, e, d, r, s, t, p, q, l, h, x, y, f1, dl, zhx, zhy, hzx, hzy, z5, z7, z12, z13, z14, z15, z16 As Double
Const pi = 3.14159265358979
Public Function cyt_xy(dk As Double, pj As Double, pa As Double, pd As Double) As Double
Dim i&
On Error Resume Next
z = dk: p = pj: q = pa
For i = 8 To 6666
If z <= Sheets("直曲表").Cells(i, 24) Then
d = Sheets("曲线要素").Cells(i, 2)
n = Sheets("曲线要素").Cells(i, 3)
e = Sheets("曲线要素").Cells(i, 4)
r = Sheets("曲线要素").Cells(i, 5)
s = Sheets("曲线要素").Cells(i, 6)
t = Sheets("曲线要素").Cells(i, 7)
If s = "" Then
s = 0
End If
If t = "" Then
t = 0
End If
f = Sheets("直曲表").Cells(i, 22)
a = Sheets("直曲表").Cells(i, 23)
Exit For
End If
Next i
Call ys
If z <= z12 Then
Call zx1
ElseIf z > z12 And z < z13 Then
Call hy
ElseIf z >= z13 And z <= z15 Then
Call yq
ElseIf z > z15 And z < z16 Then
Call yh
ElseIf z >= z16 Then
Call zx2
End If
If pd = 1 Then cyt_xy = x
If pd = 2 Then cyt_xy = y
If pd = 3 Then cyt_xy = f1
End Function
Sub cyt_xyz()
Dim j As Integer
On Error Resume Next
j = 6
If VBA.Trim(Sheets("曲线要素").Cells(j + 2, 2)) = "" Then MsgBox "“曲线要素“表中输入不完善或有误！", vbInformation, "提示": Exit Sub
If VBA.Trim(Sheets("直曲表").Cells(j + 2, 22)) = "" Then MsgBox "请在“直曲表”中点击生成曲线要素！", vbInformation, "提示": Exit Sub
With Sheets("坐标正算")
Do While .Cells(j, 1) <> ""
If .Cells(j, 1) < Sheets("直曲表").Cells(7, "W") Then MsgBox ("里程桩号：" & VBA.Format(Cells(j, 1), "00+000.000") & "超出了计算最小范围，请重新输入！"), vbExclamation, "提示": Exit Sub
If .Cells(j, 1) > Sheets("直曲表").Cells(6, "W") Then MsgBox ("里程桩号：" & VBA.Format(Cells(j, 1), "00+000.000") & "超出了计算最大范围，请重新输入！"), vbExclamation, "提示": Exit Sub
.Cells(j, 2) = cyt_xy(.Cells(j, 1), 0, 0, 1)
.Cells(j, 3) = cyt_xy(.Cells(j, 1), 0, 0, 2)
.Cells(j, 12) = ddms(f1)
.Cells(j, 13) = sqx(.Cells(j, 1))
j = j + 1
Loop
End With
End Sub
Sub cyt_xybz()
Dim j As Integer
On Error Resume Next
j = 6
If VBA.Trim(Sheets("曲线要素").Cells(j + 2, 2)) = "" Then MsgBox "“曲线要素“表中输入不完善或有误！", vbInformation, "提示": Exit Sub
If VBA.Trim(Sheets("直曲表").Cells(j + 2, 22)) = "" Then MsgBox "请在“直曲表”中点击生成曲线要素！", vbInformation, "提示": Exit Sub
With Sheets("坐标正算")
Do While .Cells(j, 1) <> ""
If .Cells(j, 1) < Sheets("直曲表").Cells(7, "W") Then MsgBox ("里程桩号：" & VBA.Format(Cells(j, 1), "00+000.000") & "超出了计算最小范围，请重新输入！"), vbExclamation, "提示": Exit Sub
If .Cells(j, 1) > Sheets("直曲表").Cells(6, "W") Then MsgBox ("里程桩号：" & VBA.Format(Cells(j, 1), "00+000.000") & "超出了计算最大范围，请重新输入！"), vbExclamation, "提示": Exit Sub
.Cells(j, 6) = cyt_xy(.Cells(j, 1), -.Cells(j, 4), .Cells(j, 5), 1)
.Cells(j, 7) = cyt_xy(.Cells(j, 1), -.Cells(j, 4), .Cells(j, 5), 2)
.Cells(j, 10) = cyt_xy(.Cells(j, 1), .Cells(j, 8), .Cells(j, 9), 1)
.Cells(j, 11) = cyt_xy(.Cells(j, 1), .Cells(j, 8), .Cells(j, 9), 2)
j = j + 1
Loop
End With
End Sub
Sub scdk()
Dim zz As Integer
Dim zz1, zz2 As Double
Dim c, arr, brr(), crr(), i&, m&, n&, f&, l&, s&, d As Object
On Error Resume Next
zz = InputBox("请输入计算桩号间距（m）", "提示", "20")
If zz = Empty Then End
If Sheets("曲线要素").Cells(8, 2) = "" Then End
zz1 = Sheets("直曲表").Cells(7, 23)
zz2 = Sheets("直曲表").Cells(6, 23)
Range("A6:M6666") = ""
Cells(6, 1) = zz1
Set d = CreateObject("scripting.dictionary")
f = Int(Cells(6, 1) / zz) * zz + zz
l = zz2
s = zz
ReDim brr(1 To l)
For i = f To l Step s
m = m + 1
brr(m) = i
Next
ReDim Preserve brr(1 To m)
arr = Sheet4.Range("m8:q" & Sheet4.Range("q6666").End(3).Row)
With WorksheetFunction
For Each c In arr
i = .Match(c, brr, 1)
d(i) = c
Next
End With
ReDim crr(1 To m + d.Count, 1 To 1)
For i = 1 To m
n = n + 1
crr(n, 1) = brr(i)
If d.Exists(i) Then
n = n + 1
crr(n, 1) = d(i)
End If
Next
With Sheets("坐标正算")
.[a7].Resize(n) = crr
.Activate
End With
End Sub
Sub zdsczb()
Dim j As Integer
Dim ld As Double
Dim rd As Double
On Error Resume Next
j = 6
ld = InputBox("请输入左偏距（m）", "提示", "5")
If ld = Empty Then End
rd = InputBox("请输入右偏距（m）", "提示", "5")
If rd = Empty Then End
With Sheets("坐标正算")
Do While .Cells(j, 1) <> ""
.Cells(j, 4) = ld: .Cells(j, 5) = 90
.Cells(j, 8) = rd: .Cells(j, 9) = 90
.Cells(j, 2) = cyt_xy(.Cells(j, 1), 0, 0, 1)
.Cells(j, 3) = cyt_xy(.Cells(j, 1), 0, 0, 2)
.Cells(j, 6) = cyt_xy(.Cells(j, 1), -.Cells(j, 4), .Cells(j, 5), 1)
.Cells(j, 7) = cyt_xy(.Cells(j, 1), -.Cells(j, 4), .Cells(j, 5), 2)
.Cells(j, 10) = cyt_xy(.Cells(j, 1), .Cells(j, 8), .Cells(j, 9), 1)
.Cells(j, 11) = cyt_xy(.Cells(j, 1), .Cells(j, 8), .Cells(j, 9), 2)
.Cells(j, 12) = ddms(f1)
.Cells(j, 13) = sqx(.Cells(j, 1))
j = j + 1
Loop
MsgBox "坐标计算完毕！", vbInformation, "提示": Exit Sub
End With
End Sub
Function ys()
Dim z3, z4, z6, z8, z9, z10, z11, z22 As Double
z5 = s ^ (2) / 24 / r - s ^ (4) / 2688 / r ^ (3) + s ^ (6) / 506880 / r ^ (5) - s ^ (8) / 154828800 / r ^ (7)
z6 = t ^ (2) / 24 / r - t ^ (4) / 2688 / r ^ (3) + t ^ (6) / 506880 / r ^ (5) - t ^ (8) / 154828800 / r ^ (7)
z7 = s / 2 - s ^ (3) / 240 / r ^ (2) + s ^ (5) / 34560 / r ^ (4) - s ^ (7) / 8386560 / r ^ (6) + s ^ (9) / 3158507520# / r ^ (8)
z8 = t / 2 - t ^ (3) / 240 / r ^ (2) + t ^ (5) / 34560 / r ^ (4) - t ^ (7) / 8386560 / r ^ (6) + t ^ (9) / 3158507520# / r ^ (8)
z9 = 90 * s / pi / r
z10 = 90 * t / pi / r
z4 = (Abs(a) - z9 - z10) * r * pi / 180
z11 = (r + z5) * mtan(Abs(a) / 2) + (z6 - z5) / msin(Abs(a)) + z7
z22 = (r + z6) * mtan(Abs(a) / 2) + (z5 - z6) / msin(Abs(a)) + z8
z3 = (r + (z5 + z6) / 2) / mcos(a / 2) - r
l = z4 + s + t
z12 = d - z11
z13 = z12 + s
z14 = z13 + z4 / 2
z15 = z13 + z4
z16 = z12 + l
z17 = f + 180
If z17 > 360 Then
z17 = z17 - 360
End If
zhx = n + z11 * mcos(z17)
zhy = e + z11 * msin(z17)
z20 = f + a
If z20 > 360 Then
z20 = z20 - 360
End If
hzx = n + z22 * mcos(z20)
hzy = e + z22 * msin(z20)
End Function
Function zx1()
Dim g As Double
g = z12 - z
x = zhx - g * mcos(f) + p * mcos(f + dms(q))
y = zhy - g * msin(f) + p * msin(f + dms(q))
f1 = f
End Function
Function hy()
Dim w, h, z26, z27, z28, z29 As Double
w = z - z12
If a < 0 Then
h = -1
Else
h = 1
End If
z26 = w ^ (2) / 2 / r / s * 180 / pi
z27 = f + z26 * h
z28 = w - w ^ (5) / 40 / r ^ (2) / s ^ (2) + w ^ (9) / 3456 / r ^ (4) / s ^ (4) - w ^ (13) / 599040 / r ^ (6) / s ^ (6) + w ^ (17) / 175472640 / r ^ (8) / s ^ (8) - w ^ (21) / 78033715200# / r ^ (10) / s ^ (10) + w ^ (25) / 49049763840000# / r ^ (12) / s ^ (12)
z29 = w ^ (3) / 6 / r / s - w ^ (7) / 336 / r ^ (3) / s ^ (3) + w ^ (11) / 42240 / r ^ (5) / s ^ (5) - w ^ (15) / 9676800 / r ^ (7) / s ^ (7) + w ^ (19) / 3530096640# / r ^ (9) / s ^ (9) - w ^ (23) / 1880240947200# / r ^ (11) / s ^ (11) + w ^ (27) / 1.3773173686272E+15 / r ^ (13) / s ^ (13)
x = zhx + z28 * mcos(f) - h * z29 * msin(f) + p * mcos(z27 + dms(q))
y = zhy + z28 * msin(f) + h * z29 * mcos(f) + p * msin(z27 + dms(q))
If z27 > 360 Then
f1 = z27 - 360
ElseIf z27 < 0 Then
f1 = z27 + 360
Else
f1 = z27
End If
End Function
Function yq()
Dim z32 As Double
Dim k, h, z33, z34, z35 As Double
k = z - z12
If a < 0 Then
h = -1
Else
h = 1
End If
z32 = (k - 0.5 * s) / r * 180 / pi
z33 = f + z32 * h
z34 = r * msin(z32) + z7
z35 = r * (1 - mcos(z32)) + z5
x = zhx + z34 * mcos(f) - h * z35 * msin(f) + p * mcos(z33 + dms(q))
y = zhy + z34 * msin(f) + h * z35 * mcos(f) + p * msin(z33 + dms(q))
If z33 > 360 Then
f1 = z33 - 360
ElseIf z33 < 0 Then
f1 = z33 + 360
Else
f1 = z33
End If
End Function
Function yh()
Dim h, m, z38, z39, z40, z41, z42 As Double
If a > 0 Then
h = -1
Else
h = 1
End If
m = z16 - z
z42 = z20 + 180
If z42 > 360 Then
z42 = z42 - 360
End If
z38 = m ^ (2) / 2 / r / t * 180 / pi
z39 = z20 + z38 * h
z40 = m - m ^ (5) / 40 / r ^ (2) / t ^ (2) + m ^ (9) / 3456 / r ^ (4) / t ^ (4) - m ^ (13) / 599040 / r ^ (6) / t ^ (6) + m ^ (17) / 175472640 / r ^ (8) / t ^ (8) - m ^ (21) / 78033715200# / r ^ (10) / t ^ (10) + m ^ (25) / 49049763840000# / r ^ (12) / t ^ (12)
z41 = m ^ (3) / 6 / r / t - m ^ (7) / 336 / r ^ (3) / t ^ (3) + m ^ (11) / 42240 / r ^ (5) / t ^ (5) - m ^ (15) / 9676800 / r ^ (7) / t ^ (7) + m ^ (19) / 3530096640# / r ^ (9) / t ^ (9) - m ^ (23) / 1880240947200# / r ^ (11) / t ^ (11) + m ^ (27) / 1.3773173686272E+15 / r ^ (13) / t ^ (13)
x = hzx + z40 * mcos(z42) - h * z41 * msin(z42) + p * mcos(z39 + dms(q))
y = hzy + z40 * msin(z42) + h * z41 * mcos(z42) + p * msin(z39 + dms(q))
If z39 > 360 Then
f1 = z39 - 360
ElseIf z39 < 0 Then
f1 = z39 + 360
Else
f1 = z39
End If
End Function
Function zx2()
Dim o As Double
o = z - z16
x = hzx + o * mcos(z20) + p * mcos(z20 + dms(q))
y = hzy + o * msin(z20) + p * msin(z20 + dms(q))
If z20 > 360 Then
f1 = z20 - 360
ElseIf z20 < 0 Then
f1 = z20 + 360
Else
f1 = z20
End If
End Function
Sub cyt_dkz()
Dim yanse As Worksheet
Dim j, i&
Dim fa, fb, ja, jb, dk, qjdx, qjdy, hjdx, hjdy, qjdk, hjdk, qjdf, hjdf As Double
Application.ScreenUpdating = False
For Each yanse In Worksheets
Sheets("坐标反算").Range("Y6:Y6666").Font.ColorIndex = 2
Next yanse
Range("A6:A6666,D6:E6666,Y6:Y6666") = ""
For i = 6 To Range("B6666").End(xlUp).Row
For j = 8 To Sheets("直曲表").Range("Y6666").End(xlUp).Row
qjdx = Sheets("直曲表").Cells(j - 1, 27)
qjdy = Sheets("直曲表").Cells(j - 1, 28)
hjdx = Sheets("直曲表").Cells(j, 27)
hjdy = Sheets("直曲表").Cells(j, 28)
qjdk = Sheets("直曲表").Cells(j - 1, 25)
hjdk = Sheets("直曲表").Cells(j, 25)
qjdf = Sheets("直曲表").Cells(j - 1, 33)
hjdf = Sheets("直曲表").Cells(j, 33)
If Abs(Cells(i, 2) - qjdx) < 0.0001 And Abs(Cells(i, 3) - qjdy) < 0.0001 Then
dk = (qjdk + hjdk) / 2: GoTo a
ElseIf Abs(Cells(i, 2) - hjdx) < 0.0001 And Abs(Cells(i, 3) - hjdy) < 0.0001 Then
dk = (qjdk + hjdk) / 2: GoTo a
Else
fa = fwj(qjdx, qjdy, Cells(i, 2), Cells(i, 3)) / 180 * pi
fb = fwj(hjdx, hjdy, Cells(i, 2), Cells(i, 3)) / 180 * pi
ja = Abs(fa - qjdf)
If ja > pi Then ja = 2 * pi - ja
jb = Abs(fb - hjdf)
If jb > pi Then jb = 2 * pi - ja
If ja <= pi / 2 + 0.0001 And jb >= pi / 2 - 0.0001 Then dk = (qjdk + hjdk) / 2: GoTo a
End If
a:
Cells(i, 25) = dk
Next
Next
Dim l As Integer
l = 9
Do While Cells(l - 1, 2) <> "" Or Cells(l - 1, 3) <> ""
Cells(6, 1) = 1
Cells(7, 1) = Cells(6, 1) + 1
Cells(l - 1, 1) = Cells(l - 2, 1) + 1
l = l + 1
Loop
End Sub
Sub cyt_dk()
Dim j, i As Integer
Dim f2, f3, f4, xa, ya As Double
On Error Resume Next
j = 6
i = j + 2
With Sheets("坐标反算")
Do While .Cells(j, 2) Or .Cells(j, 3) <> Empty
If .Cells(j, 25) <= Sheets("直曲表").Cells(i, 17) Then
d = Sheets("曲线要素").Cells(i, 2)
n = Sheets("曲线要素").Cells(i, 3)
e = Sheets("曲线要素").Cells(i, 4)
r = Sheets("曲线要素").Cells(i, 5)
s = Sheets("曲线要素").Cells(i, 6)
If s = "" Then
s = 0
End If
t = Sheets("曲线要素").Cells(i, 7)
If t = "" Then
t = 0
End If
f = Sheets("直曲表").Cells(i, 22)
a = Sheets("直曲表").Cells(i, 23)
End If
Call ys
z = .Cells(j, 25): x = cyt_xy(z, 0, 0, 1): y = cyt_xy(z, 0, 0, 2)
xa = .Cells(j, 2)
ya = .Cells(j, 3)
lbl1:
If z <= z12 Then
Call zx1
ElseIf z > z12 And z < z13 Then
Call hy
ElseIf z >= z13 And z <= z15 Then
Call yq
ElseIf z > z15 And z < z16 Then
Call yh
ElseIf z >= z16 Then
Call zx2
End If
f2 = f1 - 90: f3 = (ya - y) * Cos(f2 / 180 * pi) - (xa - x) * Sin(f2 / 180 * pi)
If Abs(f3) > 0.00001 Then
z = z + f3
GoTo lbl1
Else
GoTo jg
End If
jg:
f4 = Sqr((x - xa) ^ 2 + (y - ya) ^ 2)
If (y - ya) / Sin(f2 / 180 * pi) < 0 Then f4 = -f4
If Abs(f4) > 888 Then
Cells(j, 4) = "坐标超限"
Cells(j, 5) = "坐标超限"
Else
.Cells(j, 4) = z
.Cells(j, 5) = f4
End If
j = j + 1
Loop
End With
End Sub
Sub scqxysdk()
Dim jd As Variant
Dim j, i, l As Integer
Dim z1, z2, z3, z4, z5, z6, z7, z8, z9, z10, a, a1 As Double
If Cells(7, 3) = "" Or Cells(7, 4) = "" Then
MsgBox "交点法“曲线要素表”起点交点坐标未输入完整，请检查！", vbExclamation, "提示": ActiveSheet.Range("C7", "D7").Select
Exit Sub
End If
jd = Application.InputBox("请输入“" & Cells(7, 1) & "”起点桩号（单位：m）", "提示", "0")
If jd = "" Or jd = Empty Then Exit Sub
Range("a7:b6666") = ""
Range("i7:l6666") = ""
j = 8
i = 9
l = 8
Do While Cells(l + 1, 3) <> Empty Or Cells(l + 1, 4) <> Empty
a1 = fwj(Cells(l, 3), Cells(l, 4), Cells(l + 1, 3), Cells(l + 1, 4)) - fwj(Cells(l - 1, 3), Cells(l - 1, 4), Cells(l, 3), Cells(l, 4))
If a1 > 180 Then
Cells(l, 9) = a1 - 360
ElseIf a1 < -180 Then
Cells(l, 9) = a1 + 360
Else
Cells(l, 9) = a1
End If
l = l + 1
Loop
Do While Cells(j, 5) <> Empty
z1 = Cells(j, 6) ^ (2) / 24 / Cells(j, 5) - Cells(j, 6) ^ (4) / 2688 / Cells(j, 5) ^ (3) + Cells(j, 6) ^ (6) / 506880 / Cells(j, 5) ^ (5) - Cells(j, 6) ^ (8) / 154828800 / Cells(j, 5) ^ (7)
z2 = Cells(j, 7) ^ (2) / 24 / Cells(j, 5) - Cells(j, 7) ^ (4) / 2688 / Cells(j, 5) ^ (3) + Cells(j, 7) ^ (6) / 506880 / Cells(j, 5) ^ (5) - Cells(j, 7) ^ (8) / 154828800 / Cells(j, 5) ^ (7)
z3 = Cells(j, 6) / 2 - Cells(j, 6) ^ (3) / 240 / Cells(j, 5) ^ (2) + Cells(j, 6) ^ (5) / 34560 / Cells(j, 5) ^ (4) - Cells(j, 6) ^ (7) / 8386560 / Cells(j, 5) ^ (6) + Cells(j, 6) ^ (9) / 3158507520# / Cells(j, 5) ^ (8)
z4 = Cells(j, 7) / 2 - Cells(j, 7) ^ (3) / 240 / Cells(j, 5) ^ (2) + Cells(j, 7) ^ (5) / 34560 / Cells(j, 5) ^ (4) - Cells(j, 7) ^ (7) / 8386560 / Cells(j, 5) ^ (6) + Cells(j, 7) ^ (9) / 3158507520# / Cells(j, 5) ^ (8)
z5 = 90 * Cells(j, 6) / pi / Cells(j, 5): z6 = 90 * Cells(j, 7) / pi / Cells(j, 5)
z7 = (Abs(Cells(j, 9)) - z5 - z6) * Cells(j, 5) * pi / 180
z8 = (Cells(j, 5) + z1) * mtan(Abs(Cells(j, 9)) / 2) + (z2 - z1) / msin(Abs(Cells(j, 9))) + z3
z9 = (Cells(j, 5) + z2) * mtan(Abs(Cells(j, 9)) / 2) + (z1 - z2) / msin(Abs(Cells(j, 9))) + z4
z10 = z7 + Cells(j, 6) + Cells(j, 7)
Cells(j, 10) = z10
Cells(j, 11) = z8: Cells(j, 12) = z9
Cells(8, 2) = jd + jl(Cells(7, 3), Cells(7, 4), Cells(8, 3), Cells(8, 4))
Cells(7, 1) = "QD": Cells(8, 1) = 1
Cells(j + 1, 1) = Cells(j, 1) + 1
j = j + 1
Loop
Do While Cells(i + 1, 3) <> Empty Or Cells(i + 1, 4) <> Empty
Cells(i, 2) = Cells(i - 1, 2) - Cells(i - 1, 11) + Cells(i - 1, 10) + jl(Cells(i - 1, 3), Cells(i - 1, 4), Cells(i, 3), Cells(i, 4)) - Cells(i - 1, 12)
i = i + 1
Loop
MsgBox "交点里程计算完毕,请点击“进入直曲表”!", vbInformation, "提示": Exit Sub
End Sub
Function qxys(d As Double, a As Double, r As Double, s As Double, t As Double, p As Double) As Double
Dim z1, z2, z3, z4, z5, z6, z7, z8, z9, z10, z11, zh, hy, qz, yh, hz As Double
z1 = s ^ (2) / 24 / r - s ^ (4) / 2688 / r ^ (3) + s ^ (6) / 506880 / r ^ (5) - s ^ (8) / 154828800 / r ^ (7)
z2 = t ^ (2) / 24 / r - t ^ (4) / 2688 / r ^ (3) + t ^ (6) / 506880 / r ^ (5) - t ^ (8) / 154828800 / r ^ (7)
z3 = s / 2 - s ^ (3) / 240 / r ^ (2) + s ^ (5) / 34560 / r ^ (4) - s ^ (7) / 8386560 / r ^ (6) + s ^ (9) / 3158507520# / r ^ (8)
z4 = t / 2 - t ^ (3) / 240 / r ^ (2) + t ^ (5) / 34560 / r ^ (4) - t ^ (7) / 8386560 / r ^ (6) + t ^ (9) / 3158507520# / r ^ (8)
z5 = 90 * s / pi / r: z6 = 90 * t / pi / r
z7 = (Abs(a) - z5 - z6) * r * pi / 180
z8 = (r + z1) * mtan(Abs(a) / 2) + (z2 - z1) / msin(Abs(a)) + z3
z9 = (r + z2) * mtan(Abs(a) / 2) + (z1 - z2) / msin(Abs(a)) + z4
z10 = z7 + s + t: z11 = (r + (z1 + z2) / 2) / mcos(a / 2) - r
zh = d - z8
hy = zh + s
qz = hy + z7 / 2
yh = zh + z10 - t
hz = zh + z10
If p = 1 Then qxys = zh
If p = 2 Then qxys = hy
If p = 3 Then qxys = qz
If p = 4 Then qxys = yh
If p = 5 Then qxys = hz
If p = 6 Then qxys = z8
If p = 7 Then qxys = z9
If p = 8 Then qxys = z10
If p = 9 Then qxys = z11
End Function
Sub qxys1()
Dim j, i As Integer
Dim a1, aa As Double
On Error Resume Next
Range("a7:ai6666") = ""
With Sheets("直曲表")
i = 1
Do
i = i + 1
For j = 8 To i
.Cells(j + 1, 1) = Sheets("曲线要素").Cells(j + 1, 1)
.Cells(7, 1) = Sheets("曲线要素").Cells(7, 1)
.Cells(8, 1) = Sheets("曲线要素").Cells(8, 1)
.Cells(7, 2) = Sheets("曲线要素").Cells(7, 3)
.Cells(7, 3) = Sheets("曲线要素").Cells(7, 4)
.Cells(j, 2) = Sheets("曲线要素").Cells(j, 3)
.Cells(j, 3) = Sheets("曲线要素").Cells(j, 4)
.Cells(j, 4) = Sheets("曲线要素").Cells(j, 2)
.Cells(j - 1, 2) = Sheets("曲线要素").Cells(j - 1, 3)
.Cells(j - 1, 3) = Sheets("曲线要素").Cells(j - 1, 4)
.Cells(j + 1, 2) = Sheets("曲线要素").Cells(j + 1, 3)
.Cells(j + 1, 3) = Sheets("曲线要素").Cells(j + 1, 4)
a1 = fwj(.Cells(j, 2), .Cells(j, 3), .Cells(j + 1, 2), .Cells(j + 1, 3)) - fwj(.Cells(j - 1, 2), .Cells(j - 1, 3), .Cells(j, 2), .Cells(j, 3))
If a1 > 180 Then
aa = a1 - 360
ElseIf a1 < -180 Then
aa = a1 + 360
Else
aa = a1
End If
If aa > 0 Then
.Cells(j, 5) = "右 " & ddms(Abs(aa))
ElseIf aa < 0 Then
.Cells(j, 5) = "左 " & ddms(Abs(aa))
End If
.Cells(j, 6) = Sheets("曲线要素").Cells(j, 5)
If .Cells(j, 6) = "" Or .Cells(j, 6) = 0 Then
.Cells(j, 6) = 0.000000001
End If
.Cells(j, 7) = Sheets("曲线要素").Cells(j, 6)
If Sheets("曲线要素").Cells(j, 6) = "" Then
.Cells(j, 7) = 0
End If
.Cells(j, 8) = Sheets("曲线要素").Cells(j, 7)
If Sheets("曲线要素").Cells(j, 7) = "" Then
.Cells(j, 8) = 0
End If
.Cells(j, 9) = qxys(.Cells(j, 4), aa, .Cells(j, 6), .Cells(j, 7), .Cells(j, 8), 6)
.Cells(j, 10) = qxys(.Cells(j, 4), aa, .Cells(j, 6), .Cells(j, 7), .Cells(j, 8), 7)
.Cells(j, 11) = qxys(.Cells(j, 4), aa, .Cells(j, 6), .Cells(j, 7), .Cells(j, 8), 8)
.Cells(j, 12) = qxys(.Cells(j, 4), aa, .Cells(j, 6), .Cells(j, 7), .Cells(j, 8), 9)
.Cells(j, 13) = qxys(.Cells(j, 4), aa, .Cells(j, 6), .Cells(j, 7), .Cells(j, 8), 1)
.Cells(j, 14) = qxys(.Cells(j, 4), aa, .Cells(j, 6), .Cells(j, 7), .Cells(j, 8), 2)
.Cells(j, 15) = qxys(.Cells(j, 4), aa, .Cells(j, 6), .Cells(j, 7), .Cells(j, 8), 3)
.Cells(j, 16) = qxys(.Cells(j, 4), aa, .Cells(j, 6), .Cells(j, 7), .Cells(j, 8), 4)
.Cells(j, 17) = qxys(.Cells(j, 4), aa, .Cells(j, 6), .Cells(j, 7), .Cells(j, 8), 5)
.Cells(j, 19) = jl(.Cells(j - 1, 2), .Cells(j - 1, 3), .Cells(j, 2), .Cells(j, 3))
.Cells(j, 18) = .Cells(j, 19) - .Cells(j - 1, 10) - .Cells(j, 9)
.Cells(j, 20) = ddms(fwj(.Cells(j - 1, 2), .Cells(j - 1, 3), .Cells(j, 2), .Cells(j, 3)))
.Cells(j, 22) = fwj(.Cells(j - 1, 2), .Cells(j - 1, 3), .Cells(j, 2), .Cells(j, 3))
.Cells(j, 23) = aa
.Cells(7, 22) = jl(.Cells(7, 2), .Cells(7, 3), .Cells(8, 2), .Cells(8, 3)) - .Cells(8, 9)
.Cells(8, 18) = .Cells(7, 22)
.Cells(7, 23) = Abs(.Cells(8, 13) - .Cells(7, 22))
If aa < 0 Then
.Cells(j, 21) = -1
Else
.Cells(j, 21) = 1
End If
.Cells(j, 6) = Sheets("曲线要素").Cells(j, 5)
.Cells(6, 22) = Application.Max(Sheets("直曲表").Columns("Q"))
If Application.Max(Sheets("直曲表").Columns("Q")) = .Cells(6, 22) Then .Cells(6, 23) = jl(.Cells(j, 2), .Cells(j, 3), .Cells(j + 1, 2), .Cells(j + 1, 3)) - .Cells(j, 10): .Cells(6, 23) = .Cells(6, 22) + .Cells(6, 23)
If Sheets("曲线要素").Cells(j + 2, 3) = "" Or Sheets("曲线要素").Cells(j + 2, 4) = "" Or Sheets("曲线要素").Cells(j + 1, 5) = "" Or Sheets("曲线要素").Cells(j + 1, 6) = "" Or Sheets("曲线要素").Cells(j + 1, 7) = "" Then Exit Do
Next
Loop
End With
End Sub
Sub xy_jgw()
Dim x, y, d1, d2, d3, d4, f, aa, a1, a2, x1, y1, x2, y2, x3, y3, x4, y4, x5, y5, x6, y6, x7, y7, x8, y8, x9, y9, x10, y10, d9, d10, f9, f10, l1, l2 As Double
On Error Resume Next
If VBA.Trim(Cells(7, 2)) = "" Then MsgBox "请输入“计算桩号”！", vbInformation, "提示": Exit Sub
If VBA.Trim(Cells(8, 2)) = "" Then MsgBox "请输入“D1宽度”！", vbInformation, "提示": Exit Sub
If VBA.Trim(Cells(7, 4)) = "" Then MsgBox "请输入“偏距”！", vbInformation, "提示": Exit Sub
If VBA.Trim(Cells(8, 4)) = "" Then MsgBox "请输入“D2宽度”！", vbInformation, "提示": Exit Sub
If VBA.Trim(Cells(7, 6)) = "" Then MsgBox "请输入“α1夹角”！", vbInformation, "提示": Exit Sub
If VBA.Trim(Cells(8, 6)) = "" Then MsgBox "请输入“D3宽度”！", vbInformation, "提示": Exit Sub
If VBA.Trim(Cells(7, 9)) = "" Then MsgBox "请输入“α2夹角”！", vbInformation, "提示": Exit Sub
If VBA.Trim(Cells(8, 9)) = "" Then MsgBox "请输入“D4宽度”！", vbInformation, "提示": Exit Sub
If VBA.Trim(Cells(9, 9)) = "" Then MsgBox "请输入“L1宽度”！", vbInformation, "提示": Exit Sub
If VBA.Trim(Cells(10, 9)) = "" Then MsgBox "请输入“L2宽度”！", vbInformation, "提示": Exit Sub
If Sheets("结构物计算").OptionButton1.Value = True Then
If Cells(7, 2) < Sheets("直曲表").Cells(7, "W") Then MsgBox ("计算桩号：" & VBA.Format(Cells(7, 2), "00+000.000") & "超出了计算最小范围，请重新输入！"), vbExclamation, "提示": Exit Sub
If Cells(7, 2) > Sheets("直曲表").Cells(6, "W") Then MsgBox ("计算桩号：" & VBA.Format(Cells(7, 2), "00+000.000") & "超出了计算最大范围，请重新输入！"), vbExclamation, "提示": Exit Sub
x = cyt_xy(Cells(7, 2), Cells(7, 4), 90, 1): y = cyt_xy(Cells(7, 2), Cells(7, 4), 90, 2)
f = cyt_xy(Cells(7, 2), 0, 0, 3) / 180 * pi
ElseIf Sheets("结构物计算").OptionButton1.Value = False Then
If Cells(7, 2) < Sheets("线元法要素").Cells(6, "B") Then MsgBox ("计算桩号：" & VBA.Format(Cells(7, 2), "00+000.000") & "超出了计算最小范围，请重新输入！"), vbExclamation, "提示": Exit Sub
If Cells(7, 2) > Sheets("线元法要素").[c1000].End(3) Then MsgBox ("计算桩号：" & VBA.Format(Cells(7, 2), "00+000.000") & "超出了计算最大范围，请重新输入！"), vbExclamation, "提示": Exit Sub
x = xyf_xy(Cells(7, 2), Cells(7, 4), 90, 1): y = xyf_xy(Cells(7, 2), Cells(7, 4), 90, 2)
f = qxfwj(Cells(7, 2)) / 180 * pi
End If
d1 = Cells(8, 2): d2 = Cells(8, 4): d3 = Cells(8, 6): d4 = Cells(8, 9): l1 = Cells(9, 9): l2 = Cells(10, 9)
a1 = dms(Cells(7, 6)) / 180 * pi: a2 = dms(Cells(7, 9)) / 180 * pi: aa = a1 - a2
x1 = x - Cos(f + a1) * d1: y1 = y - Sin(f + a1) * d1
x2 = x + Cos(f + a1) * d2: y2 = y + Sin(f + a1) * d2
x3 = x1 - Cos(f + aa) * d4: y3 = y1 - Sin(f + aa) * d4
x4 = x2 - Cos(f + aa) * d4: y4 = y2 - Sin(f + aa) * d4
x5 = x1 + Cos(f + aa) * d3: y5 = y1 + Sin(f + aa) * d3
x6 = x2 + Cos(f + aa) * d3: y6 = y2 + Sin(f + aa) * d3
x7 = x + Cos(f + aa) * d3: y7 = y + Sin(f + aa) * d3
x8 = x - Cos(f + aa) * d4: y8 = y - Sin(f + aa) * d4
x9 = x - Cos(f + a1) * l1: y9 = y - Sin(f + a1) * l1
x10 = x + Cos(f + a1) * l2: y10 = y + Sin(f + a1) * l2
Cells(11, 2) = ddms(fwj(Cells(9, "D"), Cells(9, "F"), Cells(10, "D"), Cells(10, "F")))
Cells(12, 2) = ddms0(fwj(Cells(9, "D"), Cells(9, "F"), Cells(10, "D"), Cells(10, "F")))
Cells(11, 6) = Round(jl(Cells(9, "D"), Cells(9, "F"), Cells(10, "D"), Cells(10, "F")), 4)
Cells(12, 6) = Round(jl(Cells(9, "D"), Cells(9, "F"), Cells(10, "D"), Cells(10, "F")), 3)
Cells(15, 2) = x: Cells(15, 3) = y
Cells(16, 2) = x1: Cells(16, 3) = y1
Cells(17, 2) = x2: Cells(17, 3) = y2
Cells(18, 2) = x5: Cells(18, 3) = y5
Cells(19, 2) = x6: Cells(19, 3) = y6
Cells(20, 2) = x3: Cells(20, 3) = y3
Cells(21, 2) = x4: Cells(21, 3) = y4
Cells(22, 2) = x7: Cells(22, 3) = y7
Cells(23, 2) = x8: Cells(23, 3) = y8
Cells(24, 2) = x9: Cells(24, 3) = y9
Cells(25, 2) = x10: Cells(25, 3) = y10
Cells(15, 4) = ddms(fwj(Cells(9, "D"), Cells(9, "F"), Cells(15, "B"), Cells(15, "C")))
Cells(16, 4) = ddms(fwj(Cells(9, "D"), Cells(9, "F"), Cells(16, "B"), Cells(16, "C")))
Cells(17, 4) = ddms(fwj(Cells(9, "D"), Cells(9, "F"), Cells(17, "B"), Cells(17, "C")))
Cells(18, 4) = ddms(fwj(Cells(9, "D"), Cells(9, "F"), Cells(18, "B"), Cells(18, "C")))
Cells(19, 4) = ddms(fwj(Cells(9, "D"), Cells(9, "F"), Cells(19, "B"), Cells(19, "C")))
Cells(20, 4) = ddms(fwj(Cells(9, "D"), Cells(9, "F"), Cells(20, "B"), Cells(20, "C")))
Cells(21, 4) = ddms(fwj(Cells(9, "D"), Cells(9, "F"), Cells(21, "B"), Cells(21, "C")))
Cells(22, 4) = ddms(fwj(Cells(9, "D"), Cells(9, "F"), Cells(22, "B"), Cells(22, "C")))
Cells(23, 4) = ddms(fwj(Cells(9, "D"), Cells(9, "F"), Cells(23, "B"), Cells(23, "C")))
Cells(24, 4) = ddms(fwj(Cells(9, "D"), Cells(9, "F"), Cells(24, "B"), Cells(24, "C")))
Cells(25, 4) = ddms(fwj(Cells(9, "D"), Cells(9, "F"), Cells(25, "B"), Cells(25, "C")))
Cells(15, 7) = jl(Cells(9, "D"), Cells(9, "F"), Cells(15, "B"), Cells(15, "C"))
Cells(16, 7) = jl(Cells(9, "D"), Cells(9, "F"), Cells(16, "B"), Cells(16, "C"))
Cells(17, 7) = jl(Cells(9, "D"), Cells(9, "F"), Cells(17, "B"), Cells(17, "C"))
Cells(18, 7) = jl(Cells(9, "D"), Cells(9, "F"), Cells(18, "B"), Cells(18, "C"))
Cells(19, 7) = jl(Cells(9, "D"), Cells(9, "F"), Cells(19, "B"), Cells(19, "C"))
Cells(20, 7) = jl(Cells(9, "D"), Cells(9, "F"), Cells(20, "B"), Cells(20, "C"))
Cells(21, 7) = jl(Cells(9, "D"), Cells(9, "F"), Cells(21, "B"), Cells(21, "C"))
Cells(22, 7) = jl(Cells(9, "D"), Cells(9, "F"), Cells(22, "B"), Cells(22, "C"))
Cells(23, 7) = jl(Cells(9, "D"), Cells(9, "F"), Cells(23, "B"), Cells(23, "C"))
Cells(24, 7) = jl(Cells(9, "D"), Cells(9, "F"), Cells(24, "B"), Cells(24, "C"))
Cells(25, 7) = jl(Cells(9, "D"), Cells(9, "F"), Cells(25, "B"), Cells(25, "C"))
Cells(15, 5) = ddms(xjl(fwj(Cells(9, "D"), Cells(9, "F"), Cells(15, "B"), Cells(15, "C")), fwj(Cells(9, "D"), Cells(9, "F"), Cells(10, "D"), Cells(10, "F"))))
Cells(16, 5) = ddms(xjl(fwj(Cells(9, "D"), Cells(9, "F"), Cells(16, "B"), Cells(16, "C")), fwj(Cells(9, "D"), Cells(9, "F"), Cells(10, "D"), Cells(10, "F"))))
Cells(17, 5) = ddms(xjl(fwj(Cells(9, "D"), Cells(9, "F"), Cells(17, "B"), Cells(17, "C")), fwj(Cells(9, "D"), Cells(9, "F"), Cells(10, "D"), Cells(10, "F"))))
Cells(18, 5) = ddms(xjl(fwj(Cells(9, "D"), Cells(9, "F"), Cells(18, "B"), Cells(18, "C")), fwj(Cells(9, "D"), Cells(9, "F"), Cells(10, "D"), Cells(10, "F"))))
Cells(19, 5) = ddms(xjl(fwj(Cells(9, "D"), Cells(9, "F"), Cells(19, "B"), Cells(19, "C")), fwj(Cells(9, "D"), Cells(9, "F"), Cells(10, "D"), Cells(10, "F"))))
Cells(20, 5) = ddms(xjl(fwj(Cells(9, "D"), Cells(9, "F"), Cells(20, "B"), Cells(20, "C")), fwj(Cells(9, "D"), Cells(9, "F"), Cells(10, "D"), Cells(10, "F"))))
Cells(21, 5) = ddms(xjl(fwj(Cells(9, "D"), Cells(9, "F"), Cells(21, "B"), Cells(21, "C")), fwj(Cells(9, "D"), Cells(9, "F"), Cells(10, "D"), Cells(10, "F"))))
Cells(22, 5) = ddms(xjl(fwj(Cells(9, "D"), Cells(9, "F"), Cells(22, "B"), Cells(22, "C")), fwj(Cells(9, "D"), Cells(9, "F"), Cells(10, "D"), Cells(10, "F"))))
Cells(23, 5) = ddms(xjl(fwj(Cells(9, "D"), Cells(9, "F"), Cells(23, "B"), Cells(23, "C")), fwj(Cells(9, "D"), Cells(9, "F"), Cells(10, "D"), Cells(10, "F"))))
Cells(24, 5) = ddms(xjl(fwj(Cells(9, "D"), Cells(9, "F"), Cells(24, "B"), Cells(24, "C")), fwj(Cells(9, "D"), Cells(9, "F"), Cells(10, "D"), Cells(10, "F"))))
Cells(25, 5) = ddms(xjl(fwj(Cells(9, "D"), Cells(9, "F"), Cells(25, "B"), Cells(25, "C")), fwj(Cells(9, "D"), Cells(9, "F"), Cells(10, "D"), Cells(10, "F"))))
If Sheets("结构物计算").OptionButton1.Value = True Then
MsgBox "坐标计算完毕，当前选择线形为“交点法”！", vbInformation, "提示": Exit Sub
ElseIf Sheets("结构物计算").OptionButton1.Value = False Then
MsgBox "坐标计算完毕，当前选择线形为“线元法”！", vbInformation, "提示": Exit Sub
End If
End Sub
Sub szx_xy()
Dim j, i As Integer
Dim qf, hf, lf, rf As Double
On Error Resume Next
If VBA.Trim(Cells(7, 5)) = "" Then MsgBox "请输入“前方宽度（m）”！", vbInformation, "提示": Exit Sub
If VBA.Trim(Cells(7, 8)) = "" Then MsgBox "请输入“后方宽度（m）”！", vbInformation, "提示": Exit Sub
If VBA.Trim(Cells(7, 11)) = "" Then MsgBox "请输入“左侧宽度（m）”！", vbInformation, "提示": Exit Sub
If VBA.Trim(Cells(7, 14)) = "" Then MsgBox "请输入“右侧宽度（m）”！", vbInformation, "提示": Exit Sub
i = 10
j = 10
If Sheets("桩基十字线").OptionButton1.Value = True Then
Range("D10:N6666") = ""
Do While Cells(i, 1) <> ""
If Cells(i, 1) < Sheets("直曲表").Cells(7, "W") Then MsgBox ("计算桩号：" & VBA.Format(Cells(i, 1), "00+000.000") & "超出了计算最小范围，请重新输入！"), vbExclamation, "提示": Exit Sub
If Cells(i, 1) > Sheets("直曲表").Cells(6, "W") Then MsgBox ("计算桩号：" & VBA.Format(Cells(i, 1), "00+000.000") & "超出了计算最大范围，请重新输入！"), vbExclamation, "提示": Exit Sub
Cells(i, 4) = cyt_xy(Cells(i, 1), Cells(i, 2), dms(Cells(i, 3)), 1)
Cells(i, 5) = cyt_xy(Cells(i, 1), Cells(i, 2), dms(Cells(i, 3)), 2)
Cells(i, 6) = ddms(cyt_xy(Cells(i, 1), 0, 0, 3))
If Cells(i, 3) = 90 Then
qf = cyt_xy(Cells(i, 1), 0, 0, 3)
Else
qf = cyt_xy(Cells(i, 1), 0, 0, 3) + Cells(i, 3) - 90
End If
If qf < 0 Then
qf = qf + 360
End If
If qf > 360 Then
qf = qf - 360
End If
hf = qf + 180
If hf > 360 Then
hf = hf - 360
End If
lf = qf - 90
If lf < 0 Then
lf = lf + 360
End If
rf = qf + 90
If rf > 360 Then
rf = rf - 360
End If
qf = qf / 180 * pi
hf = hf / 180 * pi
lf = lf / 180 * pi
rf = rf / 180 * pi
Cells(i, 7) = Cells(i, 4) + Cells(7, 5) * Cos(qf): Cells(i, 8) = Cells(i, 5) + Cells(7, 5) * Sin(qf)
Cells(i, 9) = Cells(i, 4) + Cells(7, 8) * Cos(hf): Cells(i, 10) = Cells(i, 5) + Cells(7, 8) * Sin(hf)
Cells(i, 11) = Cells(i, 4) + Cells(7, 11) * Cos(lf): Cells(i, 12) = Cells(i, 5) + Cells(7, 11) * Sin(lf)
Cells(i, 13) = Cells(i, 4) + Cells(7, 14) * Cos(rf): Cells(i, 14) = Cells(i, 5) + Cells(7, 14) * Sin(rf)
i = i + 1
Loop
ElseIf Sheets("桩基十字线").OptionButton1.Value = False Then
Range("D10:N6666") = ""
Do While Cells(i, 1) <> ""
If Cells(i, 1) < Sheets("线元法要素").Cells(6, "B") Then MsgBox ("计算桩号：" & VBA.Format(Cells(i, 1), "00+000.000") & "超出了计算最小范围，请重新输入！"), vbExclamation, "提示": Exit Sub
If Cells(i, 1) > Sheets("线元法要素").[c1000].End(3) Then MsgBox ("计算桩号：" & VBA.Format(Cells(i, 1), "00+000.000") & "超出了计算最大范围，请重新输入！"), vbExclamation, "提示": Exit Sub
Cells(i, 4) = xyf_xy(Cells(i, 1), Cells(i, 2), dms(Cells(i, 3)), 1)
Cells(i, 5) = xyf_xy(Cells(i, 1), Cells(i, 2), dms(Cells(i, 3)), 2)
Cells(i, 6) = ddms(qxfwj(Cells(i, 1)))
If Cells(i, 3) = 90 Then
qf = qxfwj(Cells(i, 1))
Else
qf = qxfwj(Cells(i, 1)) + Cells(i, 3) - 90
End If
If qf < 0 Then
qf = qf + 360
End If
If qf > 360 Then
qf = qf - 360
End If
hf = qf + 180
If hf > 360 Then
hf = hf - 360
End If
lf = qf - 90
If lf < 0 Then
lf = lf + 360
End If
rf = qf + 90
If rf > 360 Then
rf = rf - 360
End If
qf = qf / 180 * pi
hf = hf / 180 * pi
lf = lf / 180 * pi
rf = rf / 180 * pi
Cells(i, 7) = Cells(i, 4) + Cells(7, 5) * Cos(qf): Cells(i, 8) = Cells(i, 5) + Cells(7, 5) * Sin(qf)
Cells(i, 9) = Cells(i, 4) + Cells(7, 8) * Cos(hf): Cells(i, 10) = Cells(i, 5) + Cells(7, 8) * Sin(hf)
Cells(i, 11) = Cells(i, 4) + Cells(7, 11) * Cos(lf): Cells(i, 12) = Cells(i, 5) + Cells(7, 11) * Sin(lf)
Cells(i, 13) = Cells(i, 4) + Cells(7, 14) * Cos(rf): Cells(i, 14) = Cells(i, 5) + Cells(7, 14) * Sin(rf)
i = i + 1
Loop
End If
If Sheets("桩基十字线").OptionButton1.Value = True Then
MsgBox "坐标计算完毕，当前选择线形为“交点法”！", vbInformation, "提示": Exit Sub
ElseIf Sheets("桩基十字线").OptionButton1.Value = False Then
MsgBox "坐标计算完毕，当前选择线形为“线元法”！", vbInformation, "提示": Exit Sub
End If
End Sub
Sub xysc()
Dim bh As Double
Dim j, i, l As Integer
On Error Resume Next
i = 8
j = 8
l = 8
bh = 0.0005
Cells(7, 25) = Round(Cells(7, 23), 3)
Do While Cells(i, 6) <> ""
Cells(j, 25) = Cells(i, 13)
If Abs(Cells(j, 25) - Cells(j - 1, 25)) > bh Then
Cells(j - 1, 30) = 0
Cells(j - 1, 31) = 0
If Cells(j - 1, 30) = 0 And Cells(j - 1, 31) = 0 Then
Cells(j - 1, 32) = 0
Else
Cells(j - 1, 32) = Cells(i, 21)
End If
j = j + 1
End If
Cells(j, 25) = Cells(i, 14)
If Abs(Cells(j, 25) - Cells(j - 1, 25)) > bh Then
Cells(j - 1, 30) = 0
Cells(j - 1, 31) = Cells(i, 6)
If Cells(j - 1, 30) = 0 And Cells(j - 1, 31) = 0 Then
Cells(j - 1, 32) = 0
Else
Cells(j - 1, 32) = Cells(i, 21)
End If
j = j + 1
End If
Cells(j, 25) = Cells(i, 16)
If Abs(Cells(j, 25) - Cells(j - 1, 25)) > bh Then
Cells(j - 1, 30) = Cells(i, 6)
Cells(j - 1, 31) = Cells(i, 6)
If Cells(j - 1, 30) = 0 And Cells(j - 1, 31) = 0 Then
Cells(j - 1, 32) = 0
Else
Cells(j - 1, 32) = Cells(i, 21)
End If
j = j + 1
End If
Cells(j, 25) = Cells(i, 17)
If Abs(Cells(j, 25) - Cells(j - 1, 25)) > bh Then
Cells(j - 1, 30) = Cells(i, 6)
Cells(j - 1, 31) = 0
If Cells(j - 1, 30) = 0 And Cells(j - 1, 31) = 0 Then
Cells(j - 1, 32) = 0
Else
Cells(j - 1, 32) = Cells(i, 21)
End If
j = j + 1
End If
i = i + 1
Loop
Do While Cells(l, 25) <> ""
Cells(l - 1, 26) = Cells(l, 25)
Cells(l - 1, 29) = ddms(cyt_xy(Cells(l - 1, 25), 0, 0, 3))
Cells(l - 1, 33) = cyt_xy(Cells(l - 1, 25), 0, 0, 3) / 180 * pi
Cells(l - 1, 27) = cyt_xy(Cells(l - 1, 25), 0, 0, 1)
Cells(l - 1, 28) = cyt_xy(Cells(l - 1, 25), 0, 0, 2)
Cells(l - 1, 35) = dfm(cyt_xy(Cells(l - 1, 25), 0, 0, 3))
l = l + 1
Loop
End Sub
Sub copy_zqbxyf()
Dim j As Integer
Sheets("线元法要素").Range("b6:i6666") = ""
j = 1
Do While Sheets("直曲表").Cells(j + 6, "y") <> "" Or Sheets("直曲表").Cells(j + 6, "z") <> ""
Sheets("线元法要素").Cells(j + 5, 2) = Sheets("直曲表").Cells(j + 6, "y")
Sheets("线元法要素").Cells(j + 5, 3) = Sheets("直曲表").Cells(j + 6, "z")
Sheets("线元法要素").Cells(j + 5, 4) = Sheets("直曲表").Cells(j + 6, "aa")
Sheets("线元法要素").Cells(j + 5, 5) = Sheets("直曲表").Cells(j + 6, "ab")
Sheets("线元法要素").Cells(j + 5, 6) = Sheets("直曲表").Cells(j + 6, "ai")
Sheets("线元法要素").Cells(j + 5, 7) = Sheets("直曲表").Cells(j + 6, "ad")
Sheets("线元法要素").Cells(j + 5, 8) = Sheets("直曲表").Cells(j + 6, "ae")
Sheets("线元法要素").Cells(j + 5, 9) = Sheets("直曲表").Cells(j + 6, "af")
j = j + 1
Loop
MsgBox "已成功复制到线元法要素表中，请进入“线元法要素表”！", vbInformation, "提示"
Sheets("线元法要素").Select
Sheets("线元法要素").OptionButton1.Value = True
End Sub
Function sqx(dk)
Dim i&
Dim k, h, k1, h1, r, i1, i2, i2a, l, t, e, x, q, zy, yz, z1, z2 As Double
On Error Resume Next
For i = 8 To 6666
If Sheets("竖曲线要素").Cells(i, 5) = "" Then
Exit For
End If
If dk <= Sheets("竖曲线要素").Cells(i, 11) Then
k = Sheets("竖曲线要素").Cells(i, 2)
h = Sheets("竖曲线要素").Cells(i, 3)
r = Sheets("竖曲线要素").Cells(i, 4)
i1 = Sheets("竖曲线要素").Cells(i, 5)
i2 = Sheets("竖曲线要素").Cells(i, 6)
Exit For
End If
Next i
k1 = Sheets("竖曲线要素").Cells(i - 1, 2)
h1 = Sheets("竖曲线要素").Cells(i - 1, 3)
i2a = Sheets("竖曲线要素").Cells(i - 1, 6)
If (i1 - i2) < 0 Then
q = 1
Else
q = -1
End If
If r = "" Or r = 0 Then
r = 0.000000001
End If
l = r * Abs(i1 / 100 - i2 / 100): t = l / 2: e = t ^ 2 / 2 / r: zy = k - t: yz = zy + l
If dk <= zy Then
x = h - (k - dk) * i1 / 100
ElseIf dk >= zy And dk < k Then
z1 = h + (dk - k) * i1 / 100
z2 = (dk - zy) ^ 2 / 2 / r
x = z1 + z2 * q
ElseIf dk = k Then
x = h + e * q
ElseIf dk > k And dk <= yz Then
z1 = h + (dk - k) * i2 / 100
z2 = (yz - dk) ^ 2 / 2 / r
x = z1 + z2 * q
ElseIf dk >= yz Then
x = h1 + (dk - k1) * i2a / 100
End If
sqx = x
End Function
Sub sqxys()
Dim j As Integer
Dim jd, h, r As Double
On Error Resume Next
Range("e7:k6666") = ""
j = 8
Do While Cells(j, 4) <> ""
If Cells(j, 4) = 0 Then
r = 0.000000001
Else
r = Cells(j, 4)
End If
Cells(j, 5) = (Cells(j, 3) - Cells(j - 1, 3)) / (Cells(j, 2) - Cells(j - 1, 2)) * 100
Cells(j, 6) = (Cells(j + 1, 3) - Cells(j, 3)) / (Cells(j + 1, 2) - Cells(j, 2)) * 100
Cells(j, 7) = r * Abs(Cells(j, 5) / 100 - Cells(j, 6) / 100)
Cells(j, 8) = Cells(j, 7) / 2
Cells(j, 9) = Cells(j, 8) ^ 2 / 2 / r
Cells(j, 10) = Cells(j, 2) - Cells(j, 8)
Cells(j, 11) = Cells(j, 10) + Cells(j, 7)
Cells(7, 1) = 1: Cells(8, 1) = 2
Cells(j + 1, 1) = Cells(j, 1) + 1
j = j + 1
Loop
End Sub
Sub cyt_sqx()
Dim j As Integer
On Error Resume Next
j = 6
If VBA.Trim(Sheets("竖曲线要素").Cells(j + 2, 5)) = "" Then MsgBox "请点击“竖曲线要素“表中“生成竖曲线要素”！", vbInformation, "提示": Exit Sub
With Sheets("竖曲线计算")
Do While .Cells(j, 2) <> ""
If Cells(j, 2) < Sheets("竖曲线要素").Cells(7, "B") Then MsgBox ("计算桩号：" & VBA.Format(Cells(j, 2), "00+000.000") & "超出了计算最小范围，请重新输入！"), vbExclamation, "提示": Exit Sub
If Cells(j, 2) > Sheets("竖曲线要素").[B65535].End(3) Then MsgBox ("计算桩号：" & VBA.Format(Cells(j, 2), "00+000.000") & "超出了计算最大范围，请重新输入！"), vbExclamation, "提示": Exit Sub
Cells(j, 3) = sqx(Cells(j, 2))
Cells(j, 1) = (j - 6)
j = j + 1
Loop
End With
End Sub
Sub cyt_sqxbz()
Dim j As Integer
On Error Resume Next
j = 6
If VBA.Trim(Sheets("竖曲线要素").Cells(j + 2, 5)) = "" Then MsgBox "请点击“竖曲线要素“表中“生成竖曲线要素”！", vbInformation, "提示": Exit Sub
With Sheets("竖曲线计算")
Do While .Cells(j, 2) <> ""
If Cells(j, 2) < Sheets("竖曲线要素").Cells(7, "B") Then MsgBox ("计算桩号：" & VBA.Format(Cells(j, 2), "00+000.000") & "超出了计算最小范围，请重新输入！"), vbExclamation, "提示": Exit Sub
If Cells(j, 2) > Sheets("竖曲线要素").[B65535].End(3) Then MsgBox ("计算桩号：" & VBA.Format(Cells(j, 2), "00+000.000") & "超出了计算最大范围，请重新输入！"), vbExclamation, "提示": Exit Sub
Cells(j, 6) = sqx(Cells(j, 2)) - .Cells(j, 5) * .Cells(j, 4) / 100
Cells(j, 9) = sqx(Cells(j, 2)) - .Cells(j, 8) * .Cells(j, 7) / 100
j = j + 1
Loop
End With
End Sub
Sub zdscgc()
Dim j, i, l, v, w As Integer
Dim zz1, zz2, zz, ld, rd As Double
On Error Resume Next
zz = InputBox("请输入计算桩号间距（m）", "提示", "20")
If zz = "" Then End
ld = InputBox("请输入横坡（%）", "提示", "2")
If ld = "" Then End
rd = InputBox("请输入横距（m）", "提示", "5")
If rd = Empty Then End
If Sheets("竖曲线要素").Cells(8, 4) = "" Then End
zz1 = Sheets("竖曲线要素").Cells(7, "B")
zz2 = Sheets("竖曲线要素").[B65535].End(3)
Range("a6:u6666") = ""
i = 0
Do
i = i + 1
Sheets("竖曲线计算").Range("B6") = zz1
Sheets("竖曲线计算").Range("B7") = Int(zz1 / zz) * zz + zz
Sheets("竖曲线计算").Cells(i + 7, 2) = Round(Sheets("竖曲线计算").Cells(i + 6, 2) + zz, 0)
If Sheets("竖曲线计算").Cells(i + 7, 2) > (zz2 - zz) Then Sheets("竖曲线计算").Cells(i + 7, 2) = zz2 - 0.0001
If Sheets("竖曲线计算").Cells(i + 7, 2) = zz2 - 0.0001 Then Exit Do
Loop
j = 6
Do While Cells(j, 2) <> ""
Cells(j, 4) = ld: Cells(j, 5) = rd
Cells(j, 7) = ld: Cells(j, 8) = rd
Cells(j, 3) = sqx(Cells(j, 2))
Cells(j, 6) = sqx(Cells(j, 2)) - Cells(j, 5) * Cells(j, 4) / 100
Cells(j, 9) = sqx(Cells(j, 2)) - Cells(j, 8) * Cells(j, 7) / 100
Cells(j, 1) = (j - 6)
j = j + 1
Loop
l = 6
Do While Cells(l, 2) <> ""
If Cells(3, "o") = True Then
Cells(l, "k") = Cells(l, 3) - Sheet5.TextBox1.Value
Cells(l, "l") = Cells(l, "k") - Cells(l, 5) * Cells(l, 4) / 100
Cells(l, "m") = Cells(l, "k") - Cells(l, 8) * Cells(l, 7) / 100
ElseIf Cells(3, "o") = False Then
Cells(l, "k") = ""
Cells(l, "l") = ""
Cells(l, "m") = ""
End If
l = l + 1
Loop
v = 6
Do While Cells(v, 2) <> ""
If Cells(3, "p") = True Then
Cells(v, "o") = Cells(v, 3) - Sheet5.TextBox2.Value
Cells(v, "p") = Cells(v, "o") - Cells(v, 5) * Cells(v, 4) / 100
Cells(v, "q") = Cells(v, "o") - Cells(v, 8) * Cells(v, 7) / 100
ElseIf Cells(3, "p") = False Then
Cells(v, "o") = ""
Cells(v, "p") = ""
Cells(v, "q") = ""
End If
v = v + 1
Loop
w = 6
Do While Cells(w, 2) <> ""
If Cells(3, "q") = True Then
Cells(w, "s") = Cells(w, 3) - Sheet5.TextBox3.Value
Cells(w, "t") = Cells(w, "s") - Cells(w, 5) * Cells(w, 4) / 100
Cells(w, "u") = Cells(w, "s") - Cells(w, 8) * Cells(w, 7) / 100
ElseIf Cells(3, "q") = False Then
Cells(w, "s") = ""
Cells(w, "t") = ""
Cells(w, "u") = ""
End If
w = w + 1
Loop
MsgBox "高程计算完毕！", vbInformation, "提示": Exit Sub
End Sub
Sub copy_jdf()
Dim j As Integer
Range("a10:c6666") = ""
j = 1
Do While Sheets("坐标正算").Cells(j + 5, 1) <> ""
Sheets("极坐标放样").Cells(j + 9, 1) = Sheets("坐标正算").Cells(j + 5, 1)
Sheets("极坐标放样").Cells(j + 9, 2) = Sheets("坐标正算").Cells(j + 5, 2)
Sheets("极坐标放样").Cells(j + 9, 3) = Sheets("坐标正算").Cells(j + 5, 3)
j = j + 1
Loop
MsgBox "数据复制完毕，请点击“计算数据”按钮！", vbInformation, "提示": Exit Sub
End Sub
Sub copy_jdf_l()
Dim j As Integer
Range("a10:c6666") = ""
j = 1
Do While Sheets("坐标正算").Cells(j + 5, 1) <> ""
Sheets("极坐标放样").Cells(j + 9, 1) = Sheets("坐标正算").Cells(j + 5, 1)
Sheets("极坐标放样").Cells(j + 9, 2) = Sheets("坐标正算").Cells(j + 5, 6)
Sheets("极坐标放样").Cells(j + 9, 3) = Sheets("坐标正算").Cells(j + 5, 7)
j = j + 1
Loop
MsgBox "数据复制完毕，请点击“计算数据”按钮！", vbInformation, "提示": Exit Sub
End Sub
Sub copy_jdf_r()
Dim j As Integer
Range("a10:c6666") = ""
j = 1
Do While Sheets("坐标正算").Cells(j + 5, 1) <> ""
Sheets("极坐标放样").Cells(j + 9, 1) = Sheets("坐标正算").Cells(j + 5, 1)
Sheets("极坐标放样").Cells(j + 9, 2) = Sheets("坐标正算").Cells(j + 5, 10)
Sheets("极坐标放样").Cells(j + 9, 3) = Sheets("坐标正算").Cells(j + 5, 11)
j = j + 1
Loop
MsgBox "数据复制完毕，请点击“计算数据”按钮！", vbInformation, "提示": Exit Sub
End Sub
|
/2 
|手机版|OpenEdv-开源电子网
( 粤ICP备12000418号-1 )
发表于 2018-5-8 14:19:41
楼主
