Excel-vba测量坐标计算
1、打开office-excel
2、ALT+F11
插入模块,如图所示
3、粘贴如下代码
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("平曲线").[b65536].End(xlUp).Row)
sqxb = ThisWorkbook.Sheets("竖曲线").Range("a1:g" & ThisWorkbook.Sheets("竖曲线").[b65536].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、点击保存
格式选择为:.xlam
5、关闭excel
打开excel选项
勾选 开发者选项
6、选择刚才保存的位置
7、任意单元格中输入zs 即可使用该自定义函数
到此结束
