[VBA程序]：Add Area：来自http://vbdesign.hypermart.net

efan2000

Add Area  

Option Explicit

Public Sub vbd_Add_Areas()
  'The Variables
  Dim objSel As Object
  Dim dblArea As Double
  Dim intCnt As Integer
  Dim strPrompt As String
  Dim ssArea As AcadSelectionSet
  On Error GoTo ErrorControl
  'Assignments
  strPrompt = "The Total area of selected entities is "
  intCnt = 1
  Set ssArea = ThisDrawing.SelectionSets.Add("Areas")
  'The Selections
  ssArea.SelectOnScreen
  'The Math
  For Each objSel In ssArea
    dblArea = dblArea + objSel.Area
    intCnt = intCnt + 1
  Next
  'dblArea = RoundOff(dblArea)
  'PutOnClipboard dblArea
  MsgBox strPrompt & vbCrLf & dblArea, vbInformation, "Lisp to VBA"
  ThisDrawing.SelectionSets.Item("Areas").Delete
  Exit Sub
  'Error Label
ErrorControl:
  If Err.Description = "Object doesn't support this property or method" Then
    If MsgBox("Entity #" & intCnt & " does not have an area property." & vbCrLf & _
    "The area total will not include it, Would you like to continue?", vbYesNo, "Lisp to VBA") = vbYes Then
      Err.Clear
      Resume Next
    End If
  Else
  Debug.Print Err.Description
  End If
  ThisDrawing.SelectionSets.Item("Areas").Delete
End Sub

Public Sub PutOnClipboard(varValue As Variant)
  Dim objClip As New DataObject
  objClip.SetText Format(varValue)
  objClip.PutInClipboard
End Sub

Private Function RoundOff(varValue As Variant) As Variant
  'If you would like to format to another decimal place, add more # symbols!
  RoundOff = Format(varValue, "##.##")
End Function

Private Sub SendToNewXLBook(strName As String, varVal As Variant)
    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim intRow As Integer
    intRow = 1
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Sheets(1).Select
    xlSheet.Cells(intRow, 1).Value = varVal
    xlBook.SaveAs strName
    xlApp.Quit
    Set xlApp = Nothing
End Sub

XDSoft

最初由 efan2000 发布
[B]Add Area  

Option Explicit

Public Sub vbd_Add_Areas()
  'The Variables
  Dim objSel As Object
  Dim dblArea As Double
  Dim intCnt As Integer
  Dim strPrompt As String
  Dim ssArea As Acad... [/B]

谢谢！加10分，鼓励。欢迎常来！