首先得聲明一下：這段代碼基本上是"借"來的。只是做了些修改。這段代碼的作用是計算選定區(qū)域的面積，運行效果如下面的圖，用了比較多的SendCommand，不太可取，不過也無大礙，管用就行。另外，有多次對Auto-CAD環(huán)境變量的操作，GetVariable/SetVariable，至于各環(huán)境變量有什么用，可以查看CAD幫助文檔。
         修正Bug：重設ObjectSnapMode之后，原來的捕捉設置會丟失，必須得修改OSMODE環(huán)境變量的值才行。

[程序代碼]   

Public Sub XArea() '選擇一點，計算圍繞該點的對象圍成的面積
On Error GoTo ErrorHandler
Dim pt As Variant
Dim spt As String
Dim i As Integer
Dim zarea As Double
zarea = 0
    
'得到當前的對象總數
Dim oCount As Long
oCount = ThisDrawing.ModelSpace.count
  
'得到當前邊界創(chuàng)建的對象類型(0 為面域，1 為多段線)
Dim oOL As Integer
oOL = ThisDrawing.GetVariable("HPBOUND")
    
'得到當前層的名字
Dim currentLayer As String
currentLayer = ThisDrawing.ActiveLayer.Name
  
'得到當前線體的顏色
Dim oColor As String
oColor = ThisDrawing.GetVariable("CECOLOR")
         '－－By :忽又一天 Email:wzw.icy@gmail.com QQ：365052003
'新建一層并把它設為當前層、還原用戶配置
Dim areaLayer As AcadLayer
Set areaLayer = ThisDrawing.Layers.Add("macula_Area_")
areaLayer.color = 11
ThisDrawing.ActiveLayer = areaLayer
  
'關閉對象捕捉
Dim CurSnapMode
CurSnapMode = ThisDrawing.GetVariable("OSMODE")
ThisDrawing.ObjectSnapMode = False
  
'設置新的線體顏色(這一段可以省去提示用戶輸入，沒太大意義，不過類似的寫法還是有意義的)
Dim cr As String
cr = ThisDrawing.Utility.GetString(0, vbCrLf & " 選擇顏色[隨層(L)/隨塊(K)/自定義(S)]<隨層>：")
If cr = "k" Or cr = "K" Then
    ThisDrawing.SetVariable "CECOLOR", "0"
ElseIf cr = "s" Or cr = "S" Then
    ThisDrawing.SendCommand "COLOR "
Else
    ThisDrawing.SetVariable "CECOLOR", "256"
End If
  
Dim oName As String
Dim oLayer As String
Dim oNum As Long
  
'計算單個區(qū)域的面積并求和
Do While 1
   pt = ThisDrawing.Utility.GetPoint(, vbCrLf & "請選取區(qū)域內部任意一點：")
   spt = pt(0) & "," & pt(1)
  
   With ThisDrawing
     '得到新的對象總數，用于分析是否建立了面域或多段線
     oNum = ModelSpace.count
    
     '設置當前邊界創(chuàng)建的對象為面域
     ThisDrawing.SetVariable "HPBOUND", 0
    
     '建立一個面域
     SendCommand Chr(3) & Chr(3) & "-boundary " & spt & " " & " "
    
     '如果建立面域不成功則建立多段線
     If oNum = ModelSpace.count Then
       ThisDrawing.SetVariable "HPBOUND", 1
       SendCommand Chr(3) & Chr(3) & "-boundary " & spt & " " & " "
     End If
    
     '得到最后一個對象的名字
     oName = ModelSpace.Item(ModelSpace.count - 1).ObjectName
    
     '獲取把對最后一個對象所在的層，用于分析最后一個對象是否是需要的面域或多段線
     oLayer = ModelSpace.Item(ModelSpace.count - 1).Layer
    
     '由三方面判斷對象是否建立，如果建立則計算其面積
     If (oNum < ModelSpace.count) And ((oName = "AcDbRegion") Or (oName = "AcDbPolyline")) And (oLayer = "macula_Area_") Then
       SendCommand "draworder last f "
       SendCommand "area "
       SendCommand "o "
       SendCommand "last "
       zarea = Round(zarea + GetVariable("AREA"), 4)
     End If
   End With
     ThisDrawing.Utility.Prompt vbCrLf & "選定區(qū)域的總面積為： " & zarea & vbCrLf
Loop
 ErrorHandler:
'復制結果到剪切板
Set mydataobject = New DataObject
mydataobject.SetText zarea
mydataobject.PutInClipboard
MsgBox "選定區(qū)域的總面積為： " & zarea & "   (mm^2)" & Chr(13) & Chr(13) & "計算結果已經復制到剪切板！      ", vbOKOnly, "面積計算"

'刪除計算面積產生的對象和圖層、還原對象捕捉設置
Do While oCount < ThisDrawing.ModelSpace.count
    ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.count - 1).Delete
Loop
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentLayer)
ThisDrawing.Layers.Item("macula_Area_").Delete
ThisDrawing.SetVariable "CECOLOR", oColor
ThisDrawing.SetVariable "HPBOUND", oOL
ThisDrawing.ObjectSnapMode = True
ThisDrawing.SetVariable "OSMODE", CurSnapMode
SendCommand Chr(3) & Chr(3)
End Sub