1、打开office-excel
2、ALT+F11插入模块,如图所示
3、粘贴如下代码Public i1Public fsz蟠校盯昂dlc As DoubleFunction zs(ByR髫潋啜缅ef 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 FunctionFunction 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 / 180End 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 即可使用该自定义函数到此结束
