AcadPViewport2 - Deleting items in model space that aren't seen inside paper space

[lovemy65stang]

I have a difficult (at least for me) problem.

I'm using VBA inside of AutoCAD 2006. What I'm trying to accomplish is a sort of drawing clean-up. All of the drawings my company creates need to go through this clean-up process, so I've been asked to automate it.

The end result is that any items that aren’t being used inside any of the layouts should be deleted from model space.

Each drawing has at least one layout within paper space.

When I run the following code, the TypeName of the viewports are all "IAcadPViewPort2" :

    Dim objAcadObject As AcadObject
      Dim strName As String
   
      For Each objAcadObject In ThisDrawing.PaperSpace
          strName = TypeName(objAcadObject)
      Next

The solution as I see it (please tell me if you have any better ideas) could be laid out in the following code/pseudo-code :

    'Variables
      Dim objAcadObject As AcadObject
      Dim objLayout As AcadLayout
   
      'Go to paperspace
      ThisDrawing.ActiveSpace = acPaperSpace
      
      'SELECT ALL items in one of the viewports.
      'This is the same as selecting all items in model space
      For Each objLayout In ThisDrawing.Layouts
          For Each objAcadObject In objLayout.Block
              If TypeName(objAcadObject) = "IAcadPViewport2" Then
                  'SELECT ALL
                  'Exit the loop since the selection is done
                  Exit For
              End If
          Next
          Exit For
      Next
      
      'UNSELECT all visible items in each viewport inside paper space
      For Each objLayout In ThisDrawing.Layouts
          For Each objAcadObject In objLayout.Block
              If TypeName(objAcadObject) = "IAcadPViewport2" Then
                  'UNSELECT all items visible in the viewport
                  'Same as holding down the shift key and using an X box inside the viewport
                  'UNSELECT
                  'objAcadObject.Delete
              End If
          Next
      Next
      
      'Any items still selected are not being used inside paper space.
      'Since they are not being used, they can be deleted, so delete them!
      'DELETE

The selection and delete processes are what I can’t figure out. Any help would be EXTREMELY helpful!!!!

Thanks in advance,
Brian W.


BTW... I'm new to this forum, so please forgive me if I do something wrong and let me know what I'm doing wrong so I don't do it again!

[zourtney]

It sounds like you have problem a lot like mine. I have objects which is invisible. You can use a selection set to select objects on the screen; for example, something like:

Dim ss as AcadSelectionSet = ActiveDocument.SelectionSets.Add( "newone" )

However, AutoCad seems to either refuse to run the command and crash the program, or just simply ignore it and print ** That command may not be invoked transparently ** in the commandline.

* sigh *... that's where I am.

[lovemy65stang]

I think the reason your code isn't working is because you need to declare your object separately from setting it. Try something like this:

    Dim ss As AcadSelectionSet
    Set ss = ActiveDocument.SelectionSets.Add("newone")

Hope this helps,
-Brian

[hendie]

it's a bit more complicated than that I'm afraid.
You can't just grab objects through a viewport window. You have to check the min/max coordinates of the viewport, translate that to modelspace coordinates, then check if any of your entities are within those coordinates.
then what do you do with any objects that are part in/part out ?

[lovemy65stang]

Hendie,
Thanks for shedding some light on the subject. Do you think it would be possible to do something like the following:

    'Variables
    Dim objAcadObject As AcadObject
    Dim objLayout As AcadLayout
    Dim arrBottomRightX() As Double, arrBottomRightY() As Double
    Dim arrTopLeftX() As Double, arrTopLeftY() As Double

    'Go to paper space
    ThisDrawing.ActiveSpace = acPaperSpace
    
    'Get coordinates inside modelspace from the viewports
    For Each objLayout In ThisDrawing.Layouts
        For Each objAcadObject In objLayout.Block
            If TypeName(objAcadObject) = "IAcadPViewport2" Then
                'Store bottom right and top left model space coordinates of the viewport
                ReDim Preserve arrBottomRightX(i): ReDim Preserve arrBottomRightY(i)
                ReDim Preserve arrTopLeftX(i): ReDim Preserve arrTopLeftY(i)
                'arrBottomRightX(i) = ???
                'arrBottomRightY(i) = ???
                'arrTopLeftX(i) = ???
                'arrTopLeftY(i) = ???
                i = i + 1
            End If
        Next
    Next
    
    'Go to model space
    ThisDrawing.ActiveSpace = acModelSpace
    
    'Select everything inside the coordinates from bottom right to top left
    For i = 0 To UBound(arrBottomRightX)
        '???
    Next i
    
    'Delete everything that is selected
    '???

Any insight you, or anyone for that matter could give would be a HUGE help!
Thanks in advance for everyone's help.
-Brian

[lovemy65stang]

I finally figured it all out! The following code seems to work great, but if anyone has any suggestions on how I might improve it, please let me know. I worked really hard on this code, so please give credit to me in your comments if you decide to use it.

Here it is! Enjoy!

'Returns true if the cleanup was successful; false if it wasn't
Public Function cleanupDWG() As Boolean
'On Error Resume Next
On Error GoTo ErrorFound
    'Variables
    'Various objects/array of objects
    Dim objAcadObject As AcadObject
    Dim objLayout As AcadLayout
    Dim objEntities() As AcadEntity
    'Add the two selection sets you will be using
    Dim ss1 As AcadSelectionSet, ssT As AcadSelectionSet
    Set ss1 = ThisDrawing.SelectionSets.Add("ss1")
    Set ssT = ThisDrawing.SelectionSets.Add("ssT")
    'Points defining the model space points of each viewport
    Dim arrPoints As Variant: arrPoints = Array(arrPoints, arrPoints)
    Dim lowerRightP(2) As Double, upperLeftP(2) As Double
    'Various counters
    Dim purgeCount As Integer, vPortsCount As Integer, ssTEntityCount As Integer
    'Boolean defining if you are inside the first viewport in a layout (the paperspace itself)
    Dim boolFirstOne As Boolean: boolFirstOne = True
    'Used for filtering only items inside model space
    Dim FilterData(0) As Variant: Dim DataValue As Variant
    FilterData(0) = 0: DataValue = FilterData
    Dim FilterType(0) As Integer: Dim Groupcode As Variant
    FilterType(0) = 67: Groupcode = FilterType
 
 
    'Make sure the dynmode is off
    Call ThisDrawing.SetVariable("DYNMODE", False)
 
    'Go to paper space
    ThisDrawing.ActiveSpace = acPaperSpace
 
    'Loop through all the layouts
    For Each objLayout In ThisDrawing.Layouts
        'Make sure you aren't in model space
        If objLayout.Name <> "Model" Then
            'Set the layout to be the active layout
            ThisDrawing.ActiveLayout = objLayout
            'Make sure you are inside paper space before you zoom, then zoom
            ThisDrawing.MSpace = False
            ZoomExtents
            'Loop through all the objects
            For Each objAcadObject In objLayout.Block
                'If the object name is an MVIEW (IAcadPViewPort2 in VBA terms)
                If TypeName(objAcadObject) = "IAcadPViewport2" Then
                    'The first one you find will be the actual layout, so skip it
                    If boolFirstOne = True Then
                        'Set the first viewport found flag to false for the rest of this layout
                        boolFirstOne = False
                    Else
                        'Go inside model space inside paper space
                        ThisDrawing.MSpace = True
                        'Get the points for the selection
                        Call getCrossingBoxPoints(objAcadObject, lowerRightP, upperLeftP)
                        'Store those points for later use
                        ReDim Preserve arrPoints(vPortsCount + 1)
                        arrPoints(vPortsCount) = lowerRightP: arrPoints(vPortsCount + 1) = upperLeftP
                        vPortsCount = vPortsCount + 2
                    End If
                End If
            Next
            'Re-set the firs viewport found flag to true for the next layout
            boolFirstOne = True
        End If
    Next
 
    'Go to model space and zoom extents so the selection set will work properly
    ThisDrawing.ActiveSpace = acModelSpace
    ZoomExtents
 
    'Select everything inside modelspace in a selection set
    With ThisDrawing.Utility
        'Selects everything in model space
        ss1.Select acSelectionSetAll, , , Groupcode, DataValue
    End With
 
    'If any viewports were found...
    If Not IsEmpty(arrPoints(0)) Then
        'Loop through the viewport points that were found
        For vPortsCount = 0 To UBound(arrPoints) Step 2
            'Clear the previous selection (if there was one)
            ssT.Clear
            'Get selection set for the viewport using the points found earlier
            ssT.Select acSelectionSetCrossing, arrPoints(vPortsCount), arrPoints(vPortsCount + 1), Groupcode, DataValue
            'If anything was selected...
            If ssT.Count > 0 Then
                'Make space for all the entities in the second selection set
                ReDim objEntities(ssT.Count - 1)
                'Set the objects in the second selection set into the entities array
                For ssTEntityCount = 0 To ssT.Count - 1
                    Set objEntities(ssTEntityCount) = ssT(ssTEntityCount)
                Next
                'Remove all the entities from the second selection set from the first selection set
                ss1.RemoveItems objEntities
            End If
        Next
        'Delete everything that is still selected
        ss1.Erase
    End If
 
    'zoom extents
    ZoomExtents
 
    'If you get here, you have succeeded.  Return true
    cleanupDWG = True
 
Exit Function
ErrorFound:
    'If the error is because you are trying to remove objects from the
    'selection set that were already removed, then continue
    If Err.Number = -2147467259 Then
        Resume Next
    'If the error is because of any other reason, then return false
    Else
        cleanupDWG = False
    End If
End Function
 
 
'Retrieves the model space lower right and upper left points of the viewport
Private Sub getCrossingBoxPoints(vp As AcadPViewport, lowerRightP() As Double, upperLeftP() As Double)
On Error GoTo ErrorFound
    'Variables
    Dim lowerLeftP As Variant, upperRightP As Variant
    Dim paperViewHeight As Double, paperViewWidth As Double
 
 
    'Set the viewport to the current view port
    ThisDrawing.ActivePViewport = vp
 
    'Get the min and max lower left and upper right points in paper space terms
    Call vp.GetBoundingBox(lowerLeftP, upperRightP)
 
    'Translate the paper space points to model space points
    lowerLeftP = ThisDrawing.Utility.TranslateCoordinates(lowerLeftP, acPaperSpaceDCS, acDisplayDCS, False)
    upperRightP = ThisDrawing.Utility.TranslateCoordinates(upperRightP, acPaperSpaceDCS, acDisplayDCS, False)
    lowerLeftP = ThisDrawing.Utility.TranslateCoordinates(lowerLeftP, acDisplayDCS, acWorld, False)
    upperRightP = ThisDrawing.Utility.TranslateCoordinates(upperRightP, acDisplayDCS, acWorld, False)
 
    'Set the lower right and upper left points of the view as they would be in model space
    lowerRightP(0) = upperRightP(0)
    lowerRightP(1) = lowerLeftP(1)
    upperLeftP(0) = lowerLeftP(0)
    upperLeftP(1) = upperRightP(1)
 
Exit Sub
ErrorFound:
    'Error occured.  Tell user and exit the program.
    MsgBox "Error occured in private sub getCrossingBoxPoints!  Exiting program...", _
    vbCritical + vbOKOnly, "Error!!!"
    End
End Sub

Hope some one besides me finds this useful!
-Brian Wiggins

[hendie]

well, it didn't do anything to my drawing except zoom extents in the layout tab.
Nothing deleted/removed whatsoever !

you are also leaving a number of selection sets active in the drawing which means that the routine errors out on a second run and could cause further errors if anyone else tries creating a selection set with that name

[lovemy65stang]

Hendie,
I think I might have fixed the issues you were having with my code. It seems that on some machines, the viewport is seen by VBA as being an 'IAcadPViewport2' (like on my machine), and an 'IAcadPViewport' (no #2) on others. Weird huh . Anyways, the code looks for that now. I also made these changes:

• Set the UCS for all the viewports and model space to 'World' because it was causing some problems if the UCS was not set to 'World'.
• Added code to delete the selection sets when everything is finished, so you don't have the multiple-runs problem anymore (per your excellent suggestion Hendie ).

Anyways, try out the following code and let me know if it works for you. If not, send me the drawing you are getting errors on and I'll take a look at it to see if I can't get it working.

'Returns true if the cleanup was successfully; false if it wasn't
Public Function cleanupDWG() As Boolean
'On Error Resume Next
On Error GoTo ErrorFound
    'Variables
    'Various objects/array of objects
    Dim objAcadObject As AcadObject
    Dim objLayout As AcadLayout
    Dim objEntities() As AcadEntity
    'Add the two selection sets you will be using
    Dim ss1 As AcadSelectionSet, ssT As AcadSelectionSet
    Set ss1 = ThisDrawing.SelectionSets.Add("ss1")
    Set ssT = ThisDrawing.SelectionSets.Add("ssT")
    'Points defining the model space points of each viewport
    Dim arrPoints As Variant: arrPoints = Array(arrPoints, arrPoints)
    Dim lowerRightP(2) As Double, upperLeftP(2) As Double
    'Various counters
    Dim purgeCount As Integer, vPortsCount As Integer, ssTEntityCount As Integer
    'Boolean defining if you are inside the first viewport in a layout (the paperspace itself)
    Dim boolFirstOne As Boolean: boolFirstOne = True
    'Used for filtering only items inside model space
    Dim FilterData(0) As Variant: Dim DataValue As Variant
    FilterData(0) = 0: DataValue = FilterData
    Dim FilterType(0) As Integer: Dim Groupcode As Variant
    FilterType(0) = 67: Groupcode = FilterType
 
 
    'Make sure the dynmode is off
    Call ThisDrawing.SetVariable("DYNMODE", False)
 
    'Make sure that the UCS is set to World inside model space
    ThisDrawing.ActiveSpace = acModelSpace
    ThisDrawing.SendCommand "UCS WORLD "
 
    'Go to paper space
    ThisDrawing.ActiveSpace = acPaperSpace
 
    'Loop through all the layouts
    For Each objLayout In ThisDrawing.Layouts
        'Make sure you aren't in model space
        If objLayout.Name <> "Model" Then
            'Set the layout to be the active layout
            ThisDrawing.ActiveLayout = objLayout
            'Make sure you are inside paper space before you zoom, then zoom
            ThisDrawing.MSpace = False
            ZoomExtents
            'Loop through all the objects
            For Each objAcadObject In objLayout.Block
                'If the object name is an MVIEW (either an IAcadPViewPort OR IAcadPViewPort2 in VBA terms)
                If TypeName(objAcadObject) = "IAcadPViewport" Or TypeName(objAcadObject) = "IAcadPViewport2" Then
                    'The first one you find will be the actual layout, so skip it
                    If boolFirstOne = True Then
                        'Set the first viewport found flag to false for the rest of this layout
                        boolFirstOne = False
                    Else
                        'Go inside model space inside paper space
                        ThisDrawing.MSpace = True
                        'Make sure that the UCS is set to World inside the viewport
                         ThisDrawing.SendCommand "UCS WORLD "
                        'Get the points for the selection
                        Call getCrossingBoxPoints(objAcadObject, lowerRightP, upperLeftP)
                        'Store those points for later use
                        ReDim Preserve arrPoints(vPortsCount + 1)
                        arrPoints(vPortsCount) = lowerRightP: arrPoints(vPortsCount + 1) = upperLeftP
                        vPortsCount = vPortsCount + 2
                    End If
                End If
            Next
            'Re-set the first viewport found flag to true for the next layout
            boolFirstOne = True
            'Go outside of model space inside paperspace
            ThisDrawing.MSpace = False
        End If
    Next
 
    'Go to model space and zoom extents so the selection set will work properly
    ThisDrawing.ActiveSpace = acModelSpace
    ZoomExtents
 
    'Select everything inside modelspace in a selection set
    With ThisDrawing.Utility
        'Selects everything in model space
        ss1.Select acSelectionSetAll, , , Groupcode, DataValue
    End With
 
    'If any viewports were found...
    If Not IsEmpty(arrPoints(0)) Then
        'Loop through the viewport points that were found
        For vPortsCount = 0 To UBound(arrPoints) Step 2
            'Clear the previous selection (if there was one)
            ssT.Clear
            'Get selection set for the viewport using the points found earlier
            ssT.Select acSelectionSetCrossing, arrPoints(vPortsCount), arrPoints(vPortsCount + 1), Groupcode, DataValue
            'If anything was selected...
            If ssT.Count > 0 Then
                'Make space for all the entities in the second selection set
                ReDim objEntities(ssT.Count - 1)
                'Set the objects in the second selection set into the entities array
                For ssTEntityCount = 0 To ssT.Count - 1
                    Set objEntities(ssTEntityCount) = ssT(ssTEntityCount)
                Next
                'Remove all the entities from the second selection set from the first selection set
                ss1.RemoveItems objEntities
            End If
        Next
        'Delete everything that is still selected
        ss1.Erase
    End If
 
    'Delete the selection sets from the drawing
    ss1.Delete
    ssT.Delete
 
    'Go to model space
    ThisDrawing.ActiveSpace = acModelSpace
 
    'zoom extents
    ZoomExtents
 
    'If you get here, you have succedded.  Return true
    cleanupDWG = True
 
Exit Function
ErrorFound:
    'If the error is because you are trying to remove objects from the
    'selection set that were already removed, then continue
    If Err.Number = -2147467259 Then
        Resume Next
    'If the error is because of any other reason, then return false
    Else
        cleanupDWG = False
    End If
End Function
 
 
'Retrieves the model space lower right and upper left points of the viewport
Private Sub getCrossingBoxPoints(vp As AcadPViewport, lowerRightP() As Double, upperLeftP() As Double)
On Error GoTo ErrorFound
    'Variables
    Dim lowerLeftP As Variant, upperRightP As Variant
    Dim paperViewHeight As Double, paperViewWidth As Double
 
 
    'Set the viewport to the current view port
    ThisDrawing.ActivePViewport = vp
 
    'Get the min and max lower left and upper right points in paper space terms
    Call vp.GetBoundingBox(lowerLeftP, upperRightP)
 
    'Translate the paper space points to model space points
    lowerLeftP = ThisDrawing.Utility.TranslateCoordinates(lowerLeftP, acPaperSpaceDCS, acDisplayDCS, False)
    upperRightP = ThisDrawing.Utility.TranslateCoordinates(upperRightP, acPaperSpaceDCS, acDisplayDCS, False)
    lowerLeftP = ThisDrawing.Utility.TranslateCoordinates(lowerLeftP, acDisplayDCS, acWorld, False)
    upperRightP = ThisDrawing.Utility.TranslateCoordinates(upperRightP, acDisplayDCS, acWorld, False)
 
    'Set the lower right and upper left points of the view as they would be in model space
    lowerRightP(0) = upperRightP(0)
    lowerRightP(1) = lowerLeftP(1)
    upperLeftP(0) = lowerLeftP(0)
    upperLeftP(1) = upperRightP(1)
 
Exit Sub
ErrorFound:
    'Error occured.  Tell user and exit the program.
    MsgBox "Error occured in private sub getCrossingBoxPoints!  Exiting program...", _
    vbCritical + vbOKOnly, "Error!!!"
    End
End Sub

Thanks,
Brian Wiggins

[hendie]

Sub or Function not defined: HandleErrors

[ChenLiangqiao]

Thank you, lovemy65stang
I am using your code!
But, i have some questions about your code!