'方位角
sht.Cells(n, 5) = RAD(DEG(sht.Cells(n - 1, 5)) + DEG(sht.Cells(n - 1, 4)) - pi - DEG(gg) / m)
'坐标增量
sht.Cells(n, 6) = Format(sht.Cells(n - 1, 3) * Cos(DEG(sht.Cells(n, 5))), "#####.####")
sht.Cells(n, 7) = Format(sht.Cells(n - 1, 3) * Sin(DEG(sht.Cells(n, 5))), "#####.####")
'坐标增量和
xx = xx + sht.Cells(n, 6)
yy = yy + sht.Cells(n, 7)
Next
xx = xx + sht.Cells(3, 10) - sht.Cells(m + 2, 10)
yy = yy + sht.Cells(3, 11) - sht.Cells(m + 2, 11)
sht.Cells(m + 4, 5) = "△α=" & Format(gg, "###.######")
sht.Cells(m + 4, 6) = "△X=" & Format(xx, "###.###")
sht.Cells(m + 4, 7) = "△Y=" & Format(yy, "###.###")
sht.Cells(m + 4, 3) = "∑S=" & Format(S, "###.###")
sht.Cells(m + 4, 9) = "△S=" & Format(Sqr(xx * xx + yy * yy), "###.###")
sht.Cells(m + 4, 10) = "相对精度 1/" & Format(S / Sqr(xx * xx + yy * yy), "######")
For n = 4 To m + 2
sht.Cells(n, 8) = Format(xx / S * sht.Cells(n - 1, 3), "###.####")
sht.Cells(n, 9) = Format(yy / S * sht.Cells(n - 1, 3), "###.####")
Next
For n = 4 To m + 1
sht.Cells(n, 10) = sht.Cells(n - 1, 10) + sht.Cells(n, 6) - sht.Cells(n, 8)
sht.Cells(n, 11) = sht.Cells(n - 1, 11) + sht.Cells(n, 7) - sht.Cells(n, 9)
Next
Columns("F:K").Select
Selection.NumberFormatLocal = "0.000_ "
End Sub
Public Function RAD(Nu As Double) As Double
Dim A As Double, B As Double, C As Double, D As Double, E As Double, F As Double, G As Double, p As Double
D = Abs(Nu)
F = Sgn(Nu)
p = 180# / pi
G = p * 60#
A = Int(D * p)
B = Int((D - A / p) * G)
W = B
C = (D - A / p - B / G) * 20.62648062
RAD = (C + A + B / 100) * F
End Function
值得注意的是，前面提到的DEG函数别忘记加进去。
如果自己定义一个名字叫“计算”的按钮，指定此工具的宏为“单一附合导线计算”，那么，只要按下面的格式输入原始数据（斜体是输入的），点“计算”就可以得到计算结果了。所有的过程都是自动的，无须再手工填写，是不是很方便？
下面我们就来解决上面提到的与CAD的连接和通讯问题。
进入VBAIDE，按[工具]->[引用],找到可使用的引用，在“AutoCAD2000类型库”的左边打钩，点确定就行了。在模块中输入以下代码：
Global Sheet As Object, acadmtext As acadmtext, fontHight As Double
Global xlBook As Excel.Workbook
Global p0(2) As Double, p1(2) As Double, p2(2) As Double
Global acadApp As AcadApplication
Global acadDoc As AcadDocument
Global acadPoint As acadPoint
Global number As Integer
Public Type pt
n As Integer
pt(2) As Double
Global pt() As pt
Global text1 As AcadText
Global CAD As Object
Global p(2) As Double, i As Integer, j As Integer
Global h As Integer, l As Integer
Public Function Get_ACAD(Dwt As String) As Boolean
Dim YER As Integer
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application")
If Err Then
MsgBox Err.Description
On Error GoTo 0
Get_ACAD = False
Exit Function
End If
End If
On Error GoTo 0
Set acadDoc = acadApp.ActiveDocument
acadApp.Visible = True
Get_ACAD = True
Dim typeFace As String
Dim Bold As Boolean
Dim Italic As Boolean
Dim charSet As Long
Dim PitchandFamily As Long
acadDoc.ActiveTextStyle.GetFont typeFace, Bold, Italic, charSet, PitchandFamily
acadDoc.ActiveTextStyle.SetFont "宋体", Bold, Italic, charSet, PitchandFamily
End Function
Sub 显示对话框()
Form1.Show (0)
End Sub
Public Function Draw_Point(Point() As Double) As acadPoint
Set Draw_Point = acadDoc.ModelSpace.AddPoint(Point)
Draw_Point.Update
End Function
Public Sub Set_layer(s As String)
Dim layerObj As AcadLayer
Set layerObj = acadDoc.Layers.Add(s)
acadDoc.ActiveLayer = layerObj
End Sub
再按以下模式做个对话框：窗体的名字就叫“Form1”
双击“展点”按钮，输入以下代码：
Dim p0(2) As Double, p1(2) As Double, p2(2) As Double
Dim T1 As Double, T2 As Double, T3 As Double, T4 As Double
Public ne As Integer, sp As Single, cz As Single
Call Get_ACAD("")
Dim txt As AcadText
Dim la As AcadLayer
For Each Layer In acadDoc.ModelSpace
Next
Call Set_layer("zdh")
Set Sheet = ThisWorkbook.ActiveSheet
Dim i As Integer
Do While Sheet.Cells(i + 1, 3) <> "" Or Sheet.Cells(i + 1, 1) <> ""
If Sheet.Cells(i + 1, 3) = "" Or Sheet.Cells(i + 1, 4) = "" Then GoTo II
With Sheet
p1(0) = .Cells(i + 1, 3).Value
p1(1) = .Cells(i + 1, 4).Value
p1(2) = .Cells(i + 1, 5).Value
End With
p(0) = p1(0)
p(1) = p1(1)
Call Set_layer("ZDH")
Call Draw_Point(p1)
fontHight = TextBox5.Value
If Cells(i + 1, 2) = "" Then GoTo oo
Set txt = acadDoc.ModelSpace.AddText(Cells(i + 1, 2), p, fontHight)
txt.Color = acMagenta
oo:
If Cells(i + 1, 5) = "" Then GoTo II
Set_layer ("GCD")
p(1) = p1(1) - fontHight
Set txt = acadDoc.ModelSpace.AddText(Format(Cells(i + 1, 5), "00.0"), p, fontHight)
txt.Color = acMagenta
II:
i = i + 1
Loop
End Sub
当然，你在Excel上同样可以再加个工具按钮，比如叫“展点”，指定宏为“显示对话框”，只要你的Excel有了X,Y或者X,Y，Z（格式如下表），点击“展点” 就可以自动启动A utoCAD展点啦！当然,如果A utoCAD已经启动,就直接在已经打开的A utoCAD文档中展点，展点完毕后，会显示一个对话框，提示“展点完毕“，再切换到A utoCAD看看，你所要展的点是否已经出现了？如果没有输入错误，应该可以得到满意的结果。如果有点号,还可以显示点号，并且可以输入字体的高度。
下面是坐标格式，其中第一列为点名，第二列为编码（可以为空），第三列为X，第四列为Y，第五列为高程。注意，X，Y是A utoCAD的横坐标和纵坐标，与测量坐标系不同。
Excel的功能是非常强大的，如果有兴趣，你还可以在A utoCAD中直接与Excel通讯，比如一条三维多段线的所有结点的三维坐标直接导入到Excel，比在A utoCAD中用列表的方法要方便的多，限于篇幅，无法在此详细叙述了。如果读者有兴趣，可以深入的学习和探讨。
