在公路地基處理中可能會遇到鋼釬加固的情況，在作圖之中需要對上千個點逐一編號，重復工作量很大。如果通過編制程序可以提高工作效率，一天的工作量可以在幾分鐘之內解決，而且能夠避免視覺疲勞而引起的錯誤。

　　AutoDesk公司提供了面向對象的編程接口ActiveX Automation，它使用了OLE的Automation技術。AutoCAD被登錄為一個其它Windows的應用程序可以操作的對象，用戶可以用VB來訪問AutoCAD的所有圖形對象和非圖形對象，進行二次開發，開發過程完全獨立于AutoCAD本身。

　　有關VB開發AutoCAD的技術環節，在網上可以找到，特別是崔航的有關文章值得同行借鑒。下面給出程序以及簡單的實現方法步驟。

　　在公路地基處理中可能會遇到鋼釬加固的情況，在作圖之中需要對上千個點逐一編號，重復工作量很大。如果通過編制程序可以提高工作效率，一天的工作量可以在幾分鐘之內解決，而且能夠避免視覺疲勞而引起的錯誤。

　　AutoDesk公司提供了面向對象的編程接口ActiveX Automation，它使用了OLE的Automation技術。AutoCAD被登錄為一個其它Windows的應用程序可以操作的對象，用戶可以用VB來訪問AutoCAD的所有圖形對象和非圖形對象，進行二次開發，開發過程完全獨立于AutoCAD本身。

　　有關VB開發AutoCAD的技術環節，在網上可以找到，特別是崔航的有關文章值得同行借鑒。下面給出程序以及簡單的實現方法步驟。

　　程序用到的控件有:Command1點擊可連接AutoCAD，并在其中標注鋼釬編號;Command2點擊以釋放AutoCAD所占內存; txtX 、txtY 輸入編號文字相對于鋼釬點的相對坐標;Text1、 Text2編號文字的高度和旋轉角度?，F在給出的程序很短而且并不難，就不再作過多注釋。作圖當中先打開鋼釬(在圖中體現為點對象)位置的圖層，然后運行程序，遍歷所有對象并逐一對點對象編號。為節約時間還可以在程序中聲明一個"選擇集"對象，只對選擇集中的對象遍歷。下面給出的程序運行后的結果按畫點的順序，而不是按坐標順序編號，如果有特殊的需要，可以通過相應的排序算法實現。

　　Private Sub Command1_Click()

　　Call AcadConnect

　　Dim acadUtil As Object

　　Set acadUtil = AcadApp.ActiveDocument.Utility '設置Utility對象

　　Dim stx As Double

　　Dim sty As Double

　　Dim stmString As String

　　stmString = acadUtil.GetString(0, " 按任意鍵開始........ ")

　　Dim i As Integer

　　Dim oBj As AcadObject

　　Dim stxx As Variant

　　i = 1

　　For Each oBj In AcadApp.ActiveDocument.ModelSpace '遍歷工作區中的實體

　　If oBj.EntityName = "AcDbPoint" Then

　　stxx = oBj.Coordinates

　　stx = stxx(0)

　　sty = stxx(1)

　　Call DrawTxt(stx + Val(txtX), sty + Val(txtY), Val(Text1), 0.8, Val(Text2), str(i))

　　i = i + 1

　　End If

　　Next oBj

　　End Sub

　　Private Sub Command2_Click()

　　Call AcadQuit

　　End Sub

　　文件模塊

　　Public AcadApp As AcadApplication

　　Public Sub AcadConnect() '連接Cad

　　On Error Resume Next

　　Set AcadApp = GetObject(, "autocad.application")

　　If Err Then

　　Err.Clear

　　Set AcadApp = CreateObject("autocad.application")

　　If Err Then

　　MsgBox "不能運行AutoCAD,請檢查是否安裝!", vbOKCancel, "警告!"

　　Exit Sub

　　End If

　　End If

　　AcadApp.Visible = True

　　End Sub

　　Public Sub AcadQuit()

　　'釋放內存空間

　　On Error Resume Next

　　AcadApp.Quit

　　Set AcadApp = Nothing

　　End Sub

　　Public Sub DrawTxt(x As Double, y As Double, H As Double, Factr As Double, angle As Double, tXtstr As String) '單行文本

　　Dim txtobj As AcadText

　　Dim P(0 To 2) As Double

　　P(0) = x: P(1) = y: P(2) = 0

　　Set txtobj = AcadApp.ActiveDocument.ModelSpace.AddText(tXtstr, P, H)

　　txtobj.ScaleFactor = Factr

　　txtobj.Rotation = angle * 3.1415926 / 180

　　End Sub

　　本文提供簡單的實現方法，借以拋磚引玉。其中不當之處希望行家給以指正。