Public Function OpenAnyMode(strFileName As String) As AcadDocument
                          Dim varMode As Variant
                          Dim intCnt As Integer
                          Dim objDoc As AcadDocument
                          Dim varLog As Variant
                          On Error GoTo Err_Control
                          intCnt = Application.Documents.Count
                          If intCnt > 0 Then
                          varMode = ThisDrawing.GetVariable("SDI")
                            If varMode Then
                              Set objDoc = ThisDrawing.Open(strFileName)
                            Else
                              Set objDoc = Application.Documents.Open(strFileName)
                            End If
                          Else
                            Set objDoc = Application.Documents.Open(strFileName)
                          End If
                          Set OpenAnyMode = objDoc
                        Exit_Here:
                          Exit Function
                        Err_Control:
                          MsgBox Err.Description
                          Resume Exit_Here
                        End Function

Public Sub SpaceText()
                     Dim objSelected As Object
                     Dim blnFlag As Boolean
                     Dim strGap As String
                     Dim intCnt As Integer
                     Dim dblFirstPnt(0 To 2) As Double
                     Dim dblNextPnt(0 To 2) As Double
                     Dim strPrompt As String
                     Dim acText As AcadText
                     Dim ssText As AcadSelectionSet
                     On Error GoTo ErrControl
                     GetGap:
                     'Get the distance to offset all the text (from the first selected text)
                     strGap = InputBox("Enter the Gap for your text", "Llamas Number")
                         'Check for error, if there is start that over
                         If Not IsNumeric(strGap) Then
                         MsgBox "You must enter a valid number for the text gap", vbInformation, "Llama Rules"
                         GoTo GetGap
                         End If
                     Set ssText = ThisDrawing.SelectionSets.Add("Text")
                     ssText.SelectOnScreen
                     'You could allow the user to select each entity and adjust as you go (GetEntity)
                     'I used a selection set for speed
                     For Each objSelected In ssText
                         If TypeOf objSelected Is AcadText Then
                          Set acText = objSelected
                             If blnFlag = False Then
                                 dblFirstPnt(0) = acText.InsertionPoint(0)
                                 dblFirstPnt(1) = acText.InsertionPoint(1)
                                 dblFirstPnt(2) = acText.InsertionPoint(2)
                                 blnFlag = True
                             Else
                                 'add the gap distance to the "Base Point" then move the object down the Y
                                 'by as many gap settings as there have been objects
                                 dblNextPnt(0) = dblFirstPnt(0)
                                 dblNextPnt(1) = dblFirstPnt(1) - (strGap * intCnt)
                                 dblNextPnt(2) = dblFirstPnt(2)
                                 acText.Move acText.InsertionPoint, dblNextPnt
                             End If
                              intCnt = intCnt + 1
                         Else
                             MsgBox "Object number " & intCnt & " is not DText, you need to reselect", vbInformation, "Llama Rules"
                             ThisDrawing.SelectionSets.Item("Text").Delete
                         End If
                     Next
                     ThisDrawing.SelectionSets.Item("Text").Delete
                     ThisDrawing.Application.Update
                     Exit Sub
                     ErrControl:
                     MsgBox Err.Description
                     End Sub

Public Sub DimArcLen()
                         Dim lngOwner As Long
                         Dim varPnt1 As Variant
                         Dim varPnt2 As Variant
                         Dim varTPnt As Variant
                         Dim strVal As String
                         Dim objSel As Object
                         Dim varSelPnt As Variant
                         Dim objArc As AcadArc
                         Dim objDim As AcadDimAligned
                         ThisDrawing.Utility.GetEntity objSel, varSelPnt, "Pick the arc to Dimension: "
                           If TypeOf objSel Is AcadArc Then
                             Set objArc = objSel
                           Else
                             MsgBox "You must select an arc!", vbOKOnly, "Llama Central"
                           End If
                         strVal = Format(objArc.ArcLength, "#.##") 'add more #'s to change round off
                         varPnt1 = objArc.StartPoint
                         varPnt2 = objArc.EndPoint
                         varTPnt = ThisDrawing.Utility.GetPoint(varPnt1, "Pick Point Text: ")
                         lngOwner = objArc.OwnerID
                           If lngOwner = ThisDrawing.ModelSpace.ObjectID Then
                             Set objDim = ThisDrawing.ModelSpace.AddDimAligned(varPnt1, varPnt2, varTPnt)
                             objDim.TextOverride = strVal
                           Else
                             Set objDim = ThisDrawing.PaperSpace.AddDimAligned(varPnt1, varPnt2, varTPnt)
                             objDim.TextOverride = strVal
                           End If
                       End Sub

Option Explicit
 Private Declare Function ReleaseCapture Lib "user32" () As Long
 Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
 Private Const WM_NCLBUTTONDOWN = &HA1
 Private Const HTBOTTOMRIGHT = 17
 Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

 Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   Dim lngHwnd As Long
   If X >= Me.Width - 10 Then
     If Y >= Me.Height - 30 Then
       lngHwnd = FindWindow(vbNullString, Me.Caption)
       ReleaseCapture
       SendMessage lngHwnd, WM_NCLBUTTONDOWN, HTBOTTOMRIGHT, ByVal 0&
     End If
   End If
 End Sub

 Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
 If X >= Me.Width - 10 Then
   If Y >= Me.Height - 30 Then
     Me.MousePointer = fmMousePointerSizeNWSE
   End If
 Else
   Me.MousePointer = fmMousePointerDefault
 End If
 End Sub

Option Explicit

                       'Win32API Constants for CheckKey
                       Public Const VK_ESCAPE = &H1B
                       Public Const VK_RETURN = &HD
                       Public Const VK_RBUTTON = &H2
                       Public Const VK_LBUTTON = &H1
                       'Win32API Constants for ClearAllKeyPress
                       Public Const WM_LBUTTONDOWN = &H201
                       Public Const WM_LBUTTONUP = &H202

                       Public Const PM_REMOVE = &H1
                       'Win32API Declare for CheckKey
                       Public Declare Function GetAsyncKeyState Lib "user32" _
                       (ByVal vKey As Long) As Integer
                       'Win32API Declare for ClearAllKeyPress
                       Public Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" _
                       (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, _
                       ByValwMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
                       'This is for AutoCAD R14 users that do not have the Hwnd property
                       'In clear all key press, change:
                       'lngHwnd = ThisDrawing.hwnd
                       'To
                       'lngHwnd = FindWindow(vbNullString, Application.Caption)
                       Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
                       (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

                       'Win32API Types
                       Public Type POINTAPI
                              x As Long
                              y As Long
                       End Type

                       Public Type MSG
                          hwnd As Long
                          message As Long
                          wParam As Long
                          lParam As Long
                          Time As Long
                          pt As POINTAPI
                       End Type

                       '@~~~~~~~~~~ TransferTextValue ~~~~~~~~~~~~~~~@
                       ' Pick any attribute, text, or Mtext to set
                       ' The transfer value. Next select the target
                       ' Attribute, MText, or Text object. The transfer
                       ' Value is applied to the targets Text string
                       '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@

                       Public Sub TransferTextValue()
                         Dim objSource As AcadEntity
                         Dim objTarget As AcadEntity
                         Dim varPnt As Variant
                         Dim varPntN As Variant
                         Dim varSubIDs As Variant
                         Dim varsubID2 As Variant
                         Dim varMatrix As Variant
                         Dim strPrompt As String
                         Dim varValue As Variant
                       Pick_One:
                         On Error GoTo Err_Control
                         ClearAllKeyPress
                         strPrompt = "Pick the source object (MText, Text, or Attribute): "
                         ThisDrawing.Utility.GetSubEntity objSource, varPnt, _
                         varMatrix, varSubIDs, strPrompt
                         varValue = objSource.TextString
                       Pick_Two:
                         ClearAllKeyPress
                         strPrompt = "Pick the target object (MText, Text, or Attribute): "
                         ThisDrawing.Utility.GetSubEntity objTarget, varPntN, _
                         varMatrix, varsubID2, strPrompt
                         objTarget.TextString = varValue
                       Exit_Here:
                         Exit Sub
                       Err_Control:
                         If Err.Number = 438 Then
                           If varValue = "" Then
                             Resume Pick_One
                           Else
                             Resume Pick_Two
                           End If
                         ElseIf Err.Number = -2147352567 Then
                            'Did the user miss or are they trying to exit?
                           If checkkey(VK_LBUTTON) Then
                           'left click? oops they missed
                             If objSource Is Nothing Then
                             ' But what pick ?
                               Resume Pick_One
                             Else
                               Resume Pick_Two
                             End If
                           Else
                             Resume Exit_Here
                           End If
                         Else
                           ThisDrawing.Utility.Prompt Err.Description
                           Resume Exit_Here
                         End If
                       End Sub

                       '///////////// Function and Sample Call //////////

                       '@~~~~~~~~~~~~~ Change Case ~~~~~~~~~~~~~~~~~~~@
                       ' Convert the Case of any textual entity. the
                       ' Argument "intCase" can be:
                       ' 1 = Uppercase
                       ' 2 = Lowercase
                       ' 3 = Propercase
                       ' You could also include the other constants
                       ' For general string conversion(vbWide, vbNarrow,
                       ' Etc..)
                       '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@

                       Public Function ChangeCase(intCase As Integer) As Boolean
                         Dim objEnt As AcadEntity
                         Dim varPnt As Variant
                         Dim varSubIDs As Variant
                         Dim varMatrix As Variant
                         Dim strVal As String
                         Dim strPrompt As String
                         On Error GoTo Err_Control
                         If intCase > 0 And intCase < 4 Then
                           strPrompt = "Pick the textual object for case change: "
                           ThisDrawing.Utility.GetSubEntity objEnt, varPnt, _
                           varMatrix, varSubIDs, strPrompt
                           strVal = objEnt.TextString
                           objEnt.TextString = StrConv(strVal, intCase)
                           ChangeCase = True
                         End If
                       Exit_Here:
                         Exit Function
                       Err_Control:
                         If Err.Number = 438 Then
                           ThisDrawing.Utility.Prompt "Selected Entity does not have a text value."
                         ElseIf Err.Number = -2147352567 Then
                           ThisDrawing.Utility.Prompt "No entity selected."
                         Else
                           ThisDrawing.Utility.Prompt Err.Description
                         End If
                         Resume Exit_Here
                       End Function

                       Public Sub TestCase()
                         Call ChangeCase(1)
                         Call ChangeCase(2)
                         Call ChangeCase(3)
                       End Sub

                       '//////////// End combined code ////////////////

                       '@~~~~~~~~~~~~~~~~~~~ VBDEdit ~~~~~~~~~~~~~~~~~@
                       ' Like DDEDIT, except it works on attributes and
                       ' Text or MText.
                       '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
                       Public Sub VBDEdit()
                         Dim objEnt As AcadEntity
                         Dim varPnt As Variant
                         Dim varSubIDs As Variant
                         Dim varMatrix As Variant
                         Dim strVal As String
                         Dim strNew As String
                         Dim strPrompt As String
                       Do_Retry:
                         On Error GoTo Err_Control
                         Do
                           ClearAllKeyPress
                           strPrompt = "Pick the textual object for string modification: "
                           ThisDrawing.Utility.GetSubEntity objEnt, varPnt, _
                           varMatrix, varSubIDs, strPrompt
                           strVal = objEnt.TextString
                           strNew = InputBox(Prompt:="New Value", Default:=strVal)
                           If Len(strNew) > 0 Then
                             objEnt.TextString = strNew
                           End If
                         Loop
                       Exit_Here:
                         Exit Sub
                       Err_Control:
                         If Err.Number = 438 Then
                           Resume Do_Retry
                           'This is the error generated by Nothing picked:
                         ElseIf Err.Number = -2147352567 Then
                           'We are in a loop, so we check to see if the user wants out
                           'or if they missed their pick.
                           If checkkey(VK_LBUTTON) Then
                           'left click? oops they missed
                             Resume Do_Retry
                           Else
                             'Anything else means they want out!
                             Resume Exit_Here
                           End If
                         Else
                           ThisDrawing.Utility.Prompt Err.Description
                           Resume Exit_Here
                         End If
                       End Sub

                       Public Sub MoveAttribute()
                         Dim objEnt As AcadEntity
                         Dim varPnt As Variant
                         Dim varBase As Variant
                         Dim varDisp As Variant
                         Dim varSubIDs As Variant
                         Dim varMatrix As Variant
                         Dim strVal As String
                         Dim strKeys As String
                         Dim strPrompt As String
                         On Error GoTo Err_Control
                         strKeys = "Insert"
                         strPrompt = "Pick Attribute to move: "
                       Do_Retry:
                           ThisDrawing.Utility.GetSubEntity objEnt, varPnt, _
                           varMatrix, varSubIDs, strPrompt
                           'Force an attribute selection by keeping the loop
                           'Until an attribute reference is returned.
                           'Of course an error will move to the error handler
                           'which is good, because we can use to detect an
                           'escape.
                           If TypeOf objEnt Is AcadAttributeReference Then
                             strPrompt = "Select base point for move [Insert]: "
                             ThisDrawing.Utility.InitializeUserInput 32, strKeys
                             On Error Resume Next
                             varBase = ThisDrawing.Utility.GetPoint(Prompt:=strPrompt)
                             If Err Then
                               If Err.Description = "User input is a keyword" Then
                                 varBase = objEnt.InsertionPoint
                                 Err.Clear
                               Else
                                 GoTo Err_Control
                               End If
                             End If
                             On Error GoTo Err_Control
                             strPrompt = "Select displacement point: "
                             varDisp = ThisDrawing.Utility.GetPoint(varBase, strPrompt)
                             objEnt.Move varBase, varDisp
                           Else
                             GoTo Do_Retry
                           End If
                       Exit_Here:
                         Exit Sub
                       Err_Control:
                         If Err.Number = -2147352567 Then
                           'We are in a loop, so we check to see if the user wants out
                           'or if they missed their pick.
                           If checkkey(VK_ESCAPE) Then
                           'They really want out
                             Resume Exit_Here
                           ElseIf checkkey(VK_LBUTTON) Then
                           'left click? oops they missed
                             Resume Do_Retry
                           ElseIf checkkey(VK_RBUTTON) Then
                           'another exit key (right click)
                             Resume Exit_Here
                           End If
                         Else
                           ThisDrawing.Utility.Prompt "Function canceled"
                         End If
                         Resume Exit_Here
                       End Sub

                       '@~~~~~~~~~~~~~~~ ApplyDate ~~~~~~~~~~~~~~~@
                       ' Apply the current date to any attribute
                       ' or (M)Text
                       '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@

                       Public Sub ApplyDate()
                         Dim objEnt As AcadEntity
                         Dim varPnt As Variant
                         Dim varSubIDs As Variant
                         Dim varMatrix As Variant
                         Dim strVal As String
                         Dim strPrompt As String
                         Dim varDate As Variant
                       Do_Retry:
                         On Error GoTo Err_Control
                           strPrompt = "Pick annotation to modify: "
                           ThisDrawing.Utility.GetSubEntity objEnt, varPnt, _
                           varMatrix, varSubIDs, strPrompt
                           'Use the format function to change the format of the date
                           objEnt.TextString = Date 'this returns mm/dd/yyyy
                       Exit_Here:
                         Exit Sub
                       Err_Control:
                         If Err.Number = 438 Then
                           Resume Do_Retry
                         ElseIf Err.Number = -2147352567 Then
                            'We are in a loop, so we check to see if the user wants out
                           'or if they missed their pick.
                           If checkkey(VK_ESCAPE) Then
                           'They really want out
                             Resume Exit_Here
                           ElseIf checkkey(VK_LBUTTON) Then
                           'left click? oops they missed
                             Resume Do_Retry
                           ElseIf checkkey(VK_RBUTTON) Then
                           'another exit key (right click)
                             Resume Exit_Here
                           End If
                         Else
                           ThisDrawing.Utility.Prompt Err.Description
                         End If
                         Resume Exit_Here
                       End Sub

                       ']---[ ]---[ ]---[ ]---[ ]---[ ]---[ ]---[
                       ' Utility functions for the module
                       ']---[ ]---[ ]---[ ]---[ ]---[ ]---[ ]---[


                       '@~~~~~~~~~~~~~~ CheckKey ~~~~~~~~~~~~~~~~~@
                       ' Check to see if a particular key has been
                       ' pressed. lngKey is provided by the Const
                       ' in the general declararions.
                       '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
                       Function checkkey(lngKey As Long) As Boolean
                         If GetAsyncKeyState(lngKey) Then
                           checkkey = True
                         Else
                           checkkey = False
                         End If
                       End Function


                       '@~~~~~~~~~~~~~~~ ClearAllKeyPress ~~~~~~~~~~~~~~~~~~~~~~~~@
                       ' Used to clear the mouse clicks (can be used for key press
                       ' You will just need to use different constants) so CheckKey
                       ' Can get a clear read.
                       '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@

                       Public Sub ClearAllKeyPress()
                         Dim lngHwnd As Long
                         Dim ThisMSG As MSG
                         lngHwnd = ThisDrawing.hwnd
                         Do While PeekMessage(ThisMSG, lngHwnd, WM_LBUTTONDOWN, _
                         WM_LBUTTONUP, PM_REMOVE) <> 0
                         Loop
                       End SubCreate Attribute data base 
 Option Explicit

 Public Function CreateDB(strName As String) As Database
   Dim objDBBlks As Database
   Dim objTbl As TableDef
   Dim objFld As Field
   Dim objBlk As AcadBlockReference
   Dim varAtts As Variant
   Dim varPnt As Variant
   Dim intCnt As Integer
   Dim strPrmpt As String
   strPrmpt = "Select a block: "
   On Error GoTo Error_Control
   ThisDrawing.Utility.GetEntity objBlk, varPnt, strPrmpt
   If objBlk.HasAttributes Then
     varAtts = objBlk.GetAttributes
     Set objDBBlks = CreateDatabase(strName, dbLangGeneral)
     Set objTbl = objDBBlks.CreateTableDef(objBlk.Name)
       For intCnt = LBound(varAtts) To UBound(varAtts)
         Set objFld = objTbl.CreateField(varAtts(intCnt).TagString, dbText)
         objTbl.Fields.Append objFld
       Next
         objDBBlks.TableDefs.Append objTbl
         PopulateDB objBlk.Name, objDBBlks
         Set CreateDB = objDBBlks
   Else
     MsgBox "The selected block did not have any attributes"
   End If
   Exit Function
 Error_Control:
 'For example just dump out
   MsgBox "unbelievable fatal error, your not even allowed to have this error!"
 'This will of course leave the calling function open to an error, so there had
 'better be a test to make sure that this returned something (Not Nothing)
 End Function


 Public Sub testit()
   Dim myBase As Database
   Dim allTables As TableDefs
   Dim allFields As Fields
   Dim myTable As TableDef
   Dim myField As Field
   Set myBase = CreateDB("C:\mydata.mdb")
   Set allTables = myBase.TableDefs
   For Each myTable In allTables
     Set allFields = myTable.Fields
     For Each myField In allFields
       MsgBox myField.Name
     Next
   Next
   myBase.Close
 End Sub

 Private Sub PopulateDB(strBlkName As String, objDB As Database)
   Dim NewSS As AcadSelectionSet
   Dim objBlk As AcadBlockReference
   Dim rsAtts As Recordset
   Dim fldAtt As Field
   Dim varAtts As Variant
   Dim varPnt1 As Variant
   Dim varPnt2 As Variant
   Dim VarData(0 To 1) As Variant
   Dim intData(0 To 1) As Integer
   Dim intCnt As Integer
   Set NewSS = vbdPowerSet("data")
   VarData(0) = "INSERT"
   VarData(1) = strBlkName
   intData(0) = 0
   intData(1) = 2
   NewSS.Select Mode:=acSelectionSetAll, FilterType:=intData, FilterData:=VarData
   Set rsAtts = objDB.OpenRecordset(strBlkName)
   For Each objBlk In NewSS
     varAtts = objBlk.GetAttributes
     rsAtts.AddNew
     For intCnt = LBound(varAtts) To UBound(varAtts)
       rsAtts.Fields(intCnt) = varAtts(intCnt).TextString
     Next
     rsAtts.Update
   Next
   rsAtts.Close
 End Sub
 Public Function vbdPowerSet(strName As String) As AcadSelectionSet
   Dim objSelSet As AcadSelectionSet
   Dim objSelCol As AcadSelectionSets
   Set objSelCol = ThisDrawing.SelectionSets
     For Each objSelSet In objSelCol
       If objSelSet.Name = strName Then
         ThisDrawing.SelectionSets.Item(strName).Delete
         Exit For
       End If
     Next
   Set objSelSet = ThisDrawing.SelectionSets.Add(strName)
   Set vbdPowerSet = objSelSet
 End Function

Public Function ExplodeEX(oBlkRef As AcadBlockReference, _
                         bKeep As Boolean) As Variant
                           Dim objEnt As AcadEntity
                           Dim objMT As AcadMText
                           Dim objBlk As AcadBlock
                           Dim objDoc As AcadDocument
                           Dim objArray() As AcadEntity
                           Dim objSpace As AcadBlock
                           Dim intCnt As Integer
                           Dim varTemp As Variant
                           Dim varPnt As Variant
                           Dim dblScale As Double
                           Dim dblRot As Double
                           Dim dblMatrix(3, 3) As Double
                           On Error GoTo Err_Control
                           'What document is the reference in?
                           Set objDoc = oBlkRef.Document
                           'Model space or layout?
                           Set objSpace = objDoc.ObjectIdToObject(oBlkRef.OwnerID)
                           Set objBlk = objDoc.Blocks(oBlkRef.Name)
                           varPnt = oBlkRef.InsertionPoint
                           dblScale = oBlkRef.XScaleFactor
                           dblRot = oBlkRef.Rotation
                           'Set the matrix for new objects transform
                           '*Note:
                           'This matrix uses only the X scale factor of the
                           'Block reference, many entities can not be scaled
                           'Non-uniformly!
                           dblMatrix(0, 0) = dblScale
                           dblMatrix(0, 1) = 0
                           dblMatrix(0, 2) = 0
                           dblMatrix(0, 3) = varPnt(0)
                           dblMatrix(1, 0) = 0
                           dblMatrix(1, 1) = dblScale
                           dblMatrix(1, 2) = 0
                           dblMatrix(1, 3) = varPnt(1)
                           dblMatrix(2, 0) = 0
                           dblMatrix(2, 1) = 0
                           dblMatrix(2, 2) = dblScale
                           dblMatrix(2, 3) = varPnt(2)
                           dblMatrix(3, 0) = 0
                           dblMatrix(3, 1) = 0
                           dblMatrix(3, 2) = 0
                           dblMatrix(3, 3) = 1
                           'Get all of the entities in the block
                           ReDim objArray(objBlk.Count - 1)
                           For Each objEnt In objBlk
                             Set objArray(intCnt) = objEnt
                             intCnt = intCnt + 1
                           Next objEnt
                           'Place them into the correct space
                           varTemp = objDoc.CopyObjects(objArray, objSpace)
                           'Transform & rotate
                           For intCnt = LBound(varTemp) To UBound(varTemp)
                             Set objEnt = varTemp(intCnt)
                             objEnt.TransformBy dblMatrix
                             objEnt.Rotate varPnt, dblRot
                           Next intCnt
                           'Keep the block reference?
                           If Not bKeep Then
                             oBlkRef.Delete
                           End If
                           'Return all of the new entities
                           ExplodeEX = varTemp
                           'Release memory
                           Set objDoc = Nothing
                           Set objBlk = Nothing
                           Set objSpace = Nothing
                         Exit_Here:
                           Exit Function
                         Err_Control:
                           MsgBox Err.Description
                           Resume Exit_Here
                         End Function

                         'And the obligatory sample of its use:

                         Public Sub TestExplode()
                           Dim objEnt As AcadEntity
                           Dim objBlkRef As AcadBlockReference
                           Dim varPnt As Variant
                           Dim varEnts As Variant
                           Dim intCnt As Integer
                           Dim strPrmt As String
                           strPrmt = "Select a block reference: "
                           ThisDrawing.Utility.GetEntity objEnt, varPnt, strPrmt
                           If TypeOf objEnt Is AcadBlockReference Then
                             varEnts = ExplodeEX(objEnt, False)
                             For intCnt = LBound(varEnts) To UBound(varEnts)
                               varEnts(intCnt).Color = acBlue
                             Next intCnt
                           Else
                             MsgBox "That was not a block reference"
                           End If
                         End Sub

