(vl-load-com)

(defun c:repair-dim (/ adoc lst:layer err)
   (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
   (vlax-for item (vla-get-layers adoc)
     (if (not (wcmatch (vla-get-name item) "*|*"))
       (setq lst:layer (cons
                         (list item
                               (mapcar
                                 (function
                                   (lambda (x / tmp)
                                     (setq tmp (vlax-get-property item x))
                                     (vl-catch-all-apply
                                       (function
                                         (lambda ()
                                           (vlax-put-property item x :vlax-false)
                                           );_ end of lambda
                                         );_ end of function
                                       );_ end of vl-catch-all-apply
                                     (cons x tmp)
                                     );_ end of lambda
                                   );_ end of function
                                 '("freeze" "lock")
                                 );_ end of mapcar
                               );_ end of list
                         lst:layer
                         );_ end of cons
             );_ end of setq
       );_ end of if
     );_ end of vlax-for
   (vlax-for blk_def (vla-get-blocks adoc)
     (if (and (equal (vla-get-isxref blk_def) :vlax-false)
              (not (wcmatch (vla-get-name blk_def) "`*D*"))
              );_ end of and
       (vlax-for ent blk_def
         (if (and (wcmatch (strcase (vla-get-objectname ent)) "*DIMENSION")
                  (/= (vla-get-textoverride ent) "")
                  (not (wcmatch (vla-get-textoverride ent) "*<>*"))
                  );_ end of and
           (vl-catch-all-apply
             (function
               (lambda ()
                 (vla-put-textoverride
                   ent
                   (strcat "<>"
                           "\\X"
                           (vla-get-textoverride ent)
                           );_ end of strcat
                   );_ end of vla-put-textoverride
                 (vla-put-color ent 1)
                 );_ end of lambda
               );_ end of function
             );_ end of vl-catch-all-apply
           );_ end of if
         );_ end of vlax-for
       );_ end of if
     );_ end of vlax-for
   (foreach item lst:layer
     (foreach prop (cdr item)
       (vl-catch-all-apply
         (function
           (lambda ()
             (vlax-put-property (car item) (car prop) (cdr prop))
             );_ end of lambda
           );_ end of function
         );_ end of vl-catch-all-apply
       );_ end of foreach
     );_ end of foreach

   (vla-endundomark adoc)
   (princ)
   );_ end of defun

ThisDrawing.Layouts - 1

Function GetAllViewPorts() As Variant
Dim Res() As Object
Dim oLayout As AcadLayout, oEnt As AcadEntity
  For Each oLayout In ThisDrawing.Layouts
    If Not (UCase(oLayout.Name) Like "*[*]") Then
      On Error GoTo lErrorReDim
      For Each oEnt In oLayout.Block
        If oEnt.ObjectName = "AcDbViewport" Then
          ReDim Preserve Res(UBound(Res) + 1)
          Set Res(UBound(Res)) = oEnt
        End If
      Next oEnt
    End If
  Next oLayout
  GetAllViewPorts = Res
  Exit Function
lErrorReDim:
  ReDim Res(0)
  Resume Next
End Function

Sub Test()
Dim arVP As Variant
  arVP = GetAllViewPorts
End Sub

(defun execute-magiexp ()
  (command magiexp "" "_all" "" "")
  (while (/= (getvar "cmdactive") 0)
    (command pause)
    );_ end of while
  );_ end of defun

(defun execute-command (cmdname)
  (command cmdname)
  (while (/= (getvar "cmdactive") 0)
    (command pause)
    );_ end of while
  );_ end of defun

ThisDrawing.SendCommand "(execute-command " & Chr(34) & ИмяВыполняемойКоманды & Chr(34) & ")" & vbCr

If Not (ThisDrawing.Layers.Item(objSelSet.Item(i).Layer).Lock) Then
objSelSet.Item(i).Explode
objSelSet.Item(i).Erase
End If

Sub Test()
  ExplodeBlocksExcule 'разбить вообще все блоки
End Sub

Sub Test1()
  ExplodeBlocksExcule "2" 'Разбить все блоки с именем "2"
End Sub

Sub Test2()
  ExplodeBlocksExcule "*2*" ' Разбить все блоки с именами, в которых содержится цифра 2
End Sub

Type typLayer
  oPointer As Object
  IsLock As Boolean
  IsFrozen As Boolean
End Type

Public Sub ExplodeBlocksExcule(Optional sBlockNameExclude As String)
  If IsMissing(sBlockNameExclude) Then
    sBlockNameExclude = "*"
  Else
    sBlockNameExclude = UCase(sBlockNameExclude)
  End If
Dim oLayer As AcadLayer, arLayers() As typLayer, iCounter As Integer
  ReDim arLayers(ThisDrawing.Layers.Count - 1)
  iCounter = 0
On Error Resume Next
  For Each oLayer In ThisDrawing.Layers
    arLayers(iCounter).oPointer = oLayer
    arLayers(iCounter).IsFrozen = oLayer.Freeze
    arLayers(iCounter).IsLock = oLayer.Lock
    oLayer.Freeze = False
    oLayer.Lock = False
  Next oLayer
On Error GoTo 0
Dim oBlockDef As AcadBlock, oEnt As AcadEntity
  For Each oBlockDef In ThisDrawing.Blocks
    For Each oEnt In oBlockDef
      If oEnt.ObjectName = "AcDbBlockReference" And UCase(oEnt.Name) Like sBlockNameExclude Then
        oEnt.Explode
        oEnt.Erase
      End If
    Next oEnt
  Next oBlockDef
On Error Resume Next
  For iCounter = 0 To UBound(arLayers)
    arLayers(iCounter).oPointer.Lock = arLayers(iCounter).IsLock
    arLayers(iCounter).oPointer.Freeze = arLayers(iCounter).IsFrozen
  Next iCounter
End Sub

Option Explicit

Public Sub EraseBlocks(Optional sBlockName As String)
Dim blkRef As AcadBlock
  If IsMissing(sBlockName) Then sBlockName = "*"
  On Error Resume Next
  For Each blkRef In ThisDrawing.Blocks
    blkRef.Erase
  Next blkRef
Dim oLayout As AcadLayout, blkLay As AcadBlock, oEnt As AcadEntity
  For Each oLayout In ThisDrawing.Layouts
    Set blkLay = oLayout.Block
    For Each oEnt In blkLay
      If oEnt.ObjectName = "AcDbBlockReference" And UCase(oEnt.Name) Like UCase(sBlockName) Then
        oEnt.Delete
      End If
    Next oEnt
  Next oLayout
End Sub

Option Explicit

Function CreateCombinedRegion(docPointer As AcadDocument, _
                              PointLowCenter As Variant, _
                              PointUpCenter As Variant, _
                              Radius As Double) As AcadEntity
' Piblished by kpblc 24/07/2008 at lavteam.org
' Создание региона с "закруглениями"
' Параметры вызова:
'    docPointer -> указатель на активный документ
'    PointLowCenter -> массив из 2 чисел Double, нижний центр бывшего кружка
'    PointUpCenter  -> массив из 2 чисел Double, верхний центр бывшего кружка
'    Radius -> радиус закругления.
' Возвращает указатель на созданный регион.
' Никакие ошибки не отслеживаются.
Dim docModel As AcadBlock
Dim ResRegion As Variant
  Set docModel = docPointer.ModelSpace
Dim tmpArray(0) As AcadEntity
Dim tmpLWVertex(7) As Double
  tmpLWVertex(0) = PointLowCenter(0) - Radius: tmpLWVertex(1) = PointLowCenter(1)
  tmpLWVertex(2) = PointLowCenter(0) + Radius: tmpLWVertex(3) = PointLowCenter(1)
  tmpLWVertex(4) = PointUpCenter(0) + Radius: tmpLWVertex(5) = PointUpCenter(1)
  tmpLWVertex(6) = PointUpCenter(0) - Radius: tmpLWVertex(7) = PointUpCenter(1)
  Set tmpArray(0) = docModel.AddLightWeightPolyline(tmpLWVertex)
  tmpArray(0).Closed = True
  tmpArray(0).SetBulge 0, 1
  tmpArray(0).SetBulge 2, 1
  ResRegion = docModel.AddRegion(tmpArray)
  tmpArray(0).Delete
  Set CreateCombinedRegion = ResRegion(0)
End Function

Sub Test()
Dim lc(2) As Double
Dim uc(2) As Double
Dim res As AcadEntity
  lc(0) = 100#: lc(1) = 100#
  uc(0) = 100#: uc(1) = 560.5
  Set res = CreateCombinedRegion(ThisDrawing, lc, uc, 20)
End Sub

"C:\Program Files\AutoCAD 2005\acad.exe" /p "<<Unnamed Profile>>"