在公路地基處理中可能會(huì)遇到鋼釬加固的情況，在作圖之中需要對(duì)上千個(gè)點(diǎn)逐一編號(hào)，重復(fù)工作量很大。如果通過(guò)編制程序可以提高工作效率，一天的工作量可以在幾分鐘之內(nèi)解決，而且能夠避免視覺(jué)疲勞而引起的錯(cuò)誤。
    AutoDesk公司提供了面向?qū)ο蟮木幊探涌贏ctiveX Automation，它使用了OLE的Automation技術(shù)。AutoCAD被登錄為一個(gè)其它Windows的應(yīng)用程序可以操作的對(duì)象，用戶可以用VB來(lái)訪問(wèn)AutoCAD的所有圖形對(duì)象和非圖形對(duì)象，進(jìn)行二次開發(fā)，開發(fā)過(guò)程完全獨(dú)立于AutoCAD本身。
    有關(guān)VB開發(fā)AutoCAD的技術(shù)環(huán)節(jié)，在網(wǎng)上可以找到，特別是崔航的有關(guān)文章值得同行借鑒。下面給出程序以及簡(jiǎn)單的實(shí)現(xiàn)方法步驟。
    程序用到的控件有:Command1點(diǎn)擊可連接AutoCAD，并在其中標(biāo)注鋼釬編號(hào)；Command2點(diǎn)擊以釋放AutoCAD所占內(nèi)存； txtX 、txtY 輸入編號(hào)文字相對(duì)于鋼釬點(diǎn)的相對(duì)坐標(biāo)；Text1、 Text2編號(hào)文字的高度和旋轉(zhuǎn)角度�，F(xiàn)在給出的程序很短而且并不難，就不再作過(guò)多注釋。作圖當(dāng)中先打開鋼釬（在圖中體現(xiàn)為點(diǎn)對(duì)象）位置的圖層，然后運(yùn)行程序，遍歷所有對(duì)象并逐一對(duì)點(diǎn)對(duì)象編號(hào)。為節(jié)約時(shí)間還可以在程序中聲明一個(gè)"選擇集"對(duì)象，只對(duì)選擇集中的對(duì)象遍歷。下面給出的程序運(yùn)行后的結(jié)果按畫點(diǎn)的順序，而不是按坐標(biāo)順序編號(hào)，如果有特殊的需要，可以通過(guò)相應(yīng)的排序算法實(shí)現(xiàn)。

Private Sub Command1_Click()
Call AcadConnect

Dim acadUtil As Object

Set acadUtil = AcadApp.ActiveDocument.Utility   '設(shè)置Utility對(duì)象

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    '遍歷工作區(qū)中的實(shí)體

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 "不能運(yùn)行AutoCAD,請(qǐng)檢查是否安裝！", vbOKCancel, "警告！"
      Exit Sub
   End If
End If
AcadApp.Visible = True
End Sub

Public Sub AcadQuit()
'釋放內(nèi)存空間
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
    本文提供簡(jiǎn)單的實(shí)現(xiàn)方法，借以拋磚引玉。其中不當(dāng)之處希望行家給以指正。