订阅Excel-vba测量坐标计算
来源：网络收集 点击： 时间：2024-03-01打开office-excel
2/7ALT+F11
插入模块,如图所示
3/7粘贴如下代码
Public i1
Public fszdlc As Double
Function zs(ByRef lx_name, k, z, b)
If lx_name = Then
zs = 【线路名称不能为空】
Set Wb = Nothing
Exit Function
End If
If TypeName(pqxb) Variant() Then
pqxb = ThisWorkbook.Sheets(平曲线).Range(a1:i ThisWorkbook.Sheets(平曲线)..End(xlUp).Row)
sqxb = ThisWorkbook.Sheets(竖曲线).Range(a1:g ThisWorkbook.Sheets(竖曲线)..End(xlUp).Row)
For i = LBound(pqxb) + 1 To UBound(pqxb)
If pqxb(i, 1) Then
suoyouluxian.Add pqxb(i, 1)
End If
Next i
End If
Dim i0 As Long
For i0 = 1 To suoyouluxian.Count
If lx_name = i0 Then
lx_name = suoyouluxian.Item(i0)
Exit For
End If
Next i0
For i1 = 2 To UBound(pqxb)
If lx_name = pqxb(i1, 1) Then
Exit For
End If
Next i1
If i1 UBound(pqxb) Then
zs = 没有找到【 lx_name 】的路线名
Exit Function
Else
下面这个if语句主要是用于反算里程使用，如果只使用正算功能则不需要判断
If k = -1 Then
k = pqxb(i1, 2)
End If
找出终点里程
For i3 = i1 To UBound(pqxb)
If pqxb(i3, 1) And pqxb(i3, 1) lx_name Then
fszdlc = pqxb(i3 - 1, 2) + pqxb(i3 - 1, 6)
Exit For
End If
Next i3
For i2 = i1 To UBound(pqxb)
If (pqxb(i2, 1) = Or pqxb(i2, 1) = lx_name) And (k = pqxb(i2, 2) And k = pqxb(i2, 2) + pqxb(i2, 6)) Then
线元起点里程 = pqxb(i2, 2)
线元起点X = pqxb(i2, 3)
线元起点Y = pqxb(i2, 4)
线元起点弧度制方位角 = dfmtorad(CDbl(pqxb(i2, 5)))
线元长度 = pqxb(i2, 6)
起点半径 = pqxb(i2, 7)
终点半径 = pqxb(i2, 8)
左负1右1直线0 = pqxb(i2, 9)
zs = xyzs(线元起点里程, 线元起点X, 线元起点Y, 线元起点弧度制方位角, 线元长度, 起点半径, 终点半径, 左负1右1直线0, k, z, b)
Set Wb = Nothing
Exit Function
ElseIf pqxb(i2, 1) And pqxb(i2, 1) lx_name Then
Exit For
End If
Next i2
End If
zs = lx_name 的计算范围【 pqxb(i1, 2) — pqxb(i2 - 1, 2) + pqxb(i2 - 1, 6) 】
End Function
Function dfmtorad(dfm As Double)
dfm = dfm + 0.0000000000001
Dim d As Double
Dim f As Double
Dim m As Double
d = Fix(dfm)
f = Fix(dfm * 100 - d * 100)
m = Fix(dfm * 10000 - d * 10000 - f * 100)
dfmtorad = (d + f / 60 + m / 3600) * 3.1415926 / 180
End Function
线元法计算
参数:起点里程,起点x,起点y,起点方位角弧度,,线元长度,起点半径，终点半径，方向左-1,右1,直线0,计算点的里程，宽度，右夹角十进制
Private Function xyzs(线元起点里程, 线元起点X, 线元起点Y, 线元起点弧度制方位角, 线元长度, _
起点半径, 终点半径, 左负1右1直线0, jsk, 右角_十进制, jsb) As Variant
If 起点半径 = 0 Then
起点半径 = 9.999E+102
End If
If 终点半径 = 0 Then
终点半径 = 9.999E+102
End If
Dim f0 As Single
f0 = 线元起点弧度制方位角
Dim q As Integer
q = 左负1右1直线0
Dim c As Single
c = 1 / 起点半径
Dim d As Double
d = (起点半径 - 终点半径) / 2 / 线元长度 / 起点半径 / 终点半径
Dim rr(1 To 4) As Single
Dim vv(1 To 4) As Single
rr(1) = 0.1739274226
rr(2) = 0.3260725774
rr(3) = rr(2)
rr(4) = rr(1)
vv(1) = 0.0694318442
vv(2) = 0.3300094782
vv(3) = 1 - vv(2)
vv(4) = 1 - vv(1)
Dim i As Integer, W As Double, xs As Double, ys As Double, ff As Double
W = jsk - 线元起点里程
xs = 0
ys = 0
For i = 1 To 4
ff = f0 + q * vv(i) * W * (c + vv(i) * W * d)
xs = xs + rr(i) * Cos(ff)
ys = ys + rr(i) * Sin(ff)
Next i
Dim fhz3 As Double
fhz3 = f0 + q * W * (c + W * d)
If (fhz3 0) Then
fhz3 = fhz3 + 2 * 3.1415926
End If
If (fhz3 = 2 * 3.1415926) Then
fhz3 = fhz3 - 2 * 3.1415926
End If
Dim fhzdfm As Double
fhzdfm = fhz3 * 180 / 3.1415926
Dim fhzd As Integer
fhzd = Int(fhzdfm)
Dim fhzf
fhzf = Int((fhzdfm - fhzd) * 60)
If fhzf 10 Then
fhzf = 0 fhzf
End If
Dim fhzm
fhzm = Int((((fhzdfm - fhzd) * 60) - fhzf) * 60)
fhzf = Int((fhzdfm - fhzd) * 60)
If fhzm 10 Then
fhzm = 0 fhzm
End If
Dim fhz1 As Double
fhz1 = Format(线元起点X + W * xs + jsb * Cos(fhz3 + 右角_十进制 * 3.1415926 / 180), 0.000)
Dim fhz2 As Double
fhz2 = Format(线元起点Y + W * ys + jsb * Sin(fhz3 + 右角_十进制 * 3.1415926 / 180), 0.000)
xyzs = Array(fhz1, fhz2, fhz3, fhzd ° fhzf ′ fhzm ″)
End Function
4/7点击保存
格式选择为:.xlam
5/7关闭excel
打开excel选项
勾选 开发者选项
6/7选择刚才保存的位置
7/7任意单元格中输入zs 即可使用该自定义函数
到此结束
注意事项office安装必须是完整版
如若按ALT+F11未能打开vbe窗口,清下载完整版office
如有不明白,请直接联系本人
版权声明：
1、本文系转载，版权归原作者所有，旨在传递信息，不代表看本站的观点和立场。
2、本站仅提供信息发布平台，不承担相关法律责任。
3、若侵犯您的版权或隐私，请联系本站管理员删除。
4、文章链接：http://www.1haoku.cn/art_182869.html
