OpenEdv-开源电子网

 找回密码
 立即注册
正点原子全套STM32/Linux/FPGA开发资料,上千讲STM32视频教程免费下载...
查看: 1967|回复: 4

这种计算量 32能搞定不?

[复制链接]

72

主题

179

帖子

0

精华

高级会员

Rank: 4

积分
615
金钱
615
注册时间
2014-5-12
在线时间
158 小时
发表于 2018-5-8 14:19:41 | 显示全部楼层 |阅读模式
20金钱
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

正点原子逻辑分析仪DL16劲爆上市
回复

使用道具 举报

72

主题

179

帖子

0

精华

高级会员

Rank: 4

积分
615
金钱
615
注册时间
2014-5-12
在线时间
158 小时
 楼主| 发表于 2018-5-8 14:20:36 | 显示全部楼层
上面是VB软件的源码   想改成32加串口屏  这能实现不。。。。
回复

使用道具 举报

2

主题

756

帖子

0

精华

论坛元老

Rank: 8Rank: 8

积分
4163
金钱
4163
注册时间
2017-10-24
在线时间
251 小时
发表于 2018-5-9 08:20:38 | 显示全部楼层
如果屏幕接在FSMC总线上的话我觉得F1就可以,如果是串口屏的话……不清楚,串口相对FSMC还是慢,写屏幕就得花不少时间
十六进制带我飞。
回复

使用道具 举报

19

主题

246

帖子

0

精华

高级会员

Rank: 4

积分
608
金钱
608
注册时间
2017-9-21
在线时间
171 小时
发表于 2018-5-9 08:43:47 | 显示全部楼层
如果是裸机的肯定是满CPU跑,在OS的话,就要具体测试下是不是影响了其他任务的调度,还有不要听楼上瞎说,串口屏自带驱动,51都随便带
回复

使用道具 举报

72

主题

179

帖子

0

精华

高级会员

Rank: 4

积分
615
金钱
615
注册时间
2014-5-12
在线时间
158 小时
 楼主| 发表于 2018-5-9 15:30:42 | 显示全部楼层
哆啦A萌 发表于 2018-5-9 08:43
如果是裸机的肯定是满CPU跑,在OS的话,就要具体测试下是不是影响了其他任务的调度,还有不要听楼上瞎说, ...

嗯  只能试试再说了  不过 我相信32  还是很强大的  哈哈
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则



关闭

原子哥极力推荐上一条 /2 下一条

正点原子公众号

QQ|手机版|OpenEdv-开源电子网 ( 粤ICP备12000418号-1 )

GMT+8, 2025-6-8 00:33

Powered by OpenEdv-开源电子网

© 2001-2030 OpenEdv-开源电子网

快速回复 返回顶部 返回列表