Jump to content

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


lovemy65stang

Recommended Posts

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! :)

Link to comment
Share on other sites

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.

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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 ?

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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 :D).

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

Link to comment
Share on other sites

  • 1 year later...

Thanks for your reply:)

 

i have the same demand with you: clean up the dwg accroding to the viewpoint in the layout.

 

When i am using your code, there is a problem:

when you used acSelectionSetCrossing to select the objects which you want to delete, some objects in the viewpoint are selected and deleted. so, i want to trim the object according the rectangle at first and then select the useless objects.

'Get the points for the selection

Call getCrossingBoxPoints(objAcadObject, lowerRightP, upperLeftP)

'绘制边界

Dim objRect As AcadLWPolyline

'Dim objRect As AcadRectangle

Set objRect = AddRectangle(lowerRightP, upperLeftP)

 

'trim

Dim det1 As String

det1 = axEnt2lspEnt(objRect)

 

Dim Point As String

Dim SideP(2) As Double

 

SideP(0) = lowerRightP(0) - 10

SideP(1) = lowerRightP(1) - 10

SideP(2) = 0

Point = axPoint2lspPoint(SideP)

Dim sPoint As String

 

sPoint = Format(lowerRightP(0) - 10, "0.0000")

sPoint = sPoint & "," & Format(lowerRightP(1) - 10, "0.0000")

ThisDrawing.SendCommand "_extrim" & vbCr & det1 & vbCr & vbCr & sPoint & vbCr

Link to comment
Share on other sites

but, maybe there are some errors in my code, the sendcommand of extrim does not work correctly. anyone can give me some hints?

Link to comment
Share on other sites

I would avoid trimming as some objects, like blocks and text won't allow you to trim them.

 

Looking at my code, I think I found why some of your objects were being deleted. If you have more than one viewport with the same object within them, when I do this:

ss1.RemoveItems objEntities

The code errors out on the second selection set because it is trying to remove something that has already been removed; hence none of the objects are removed.

I have a solution; instead of trying to remove all the objects in the selection set at once, I changed the code to remove each object one by one. That way if it errors because it has already been removed, it continues to the next object.

Here's the modified code:

'Returns true if the cleanup was successfully; false if it wasn't
Public Function cleanupDWG() As Boolean
On Error GoTo ErrorFound
   'Variables
   'Various objects/array of objects
   Dim objAcadObject As AcadObject
   Dim objLayout As AcadLayout
   'Dim objEntities() As AcadEntity
   Dim objEntities(0 To 0) 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 (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
                       '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 ssT.Count > 0 Then
               'Make space for all the entities in the array
               'ReDim objEntities(ssT.Count - 1)
               
               For ssTEntityCount = 0 To ssT.Count - 1
                   Set objEntities(0) = ssT(ssTEntityCount)
                   'Remove each object individually from the selection set
                   ss1.RemoveItems objEntities
               Next
               
               'No longer trying to remove all of selection set at once; causes problems
               'when trying to remove objects that were previously removed
               '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
   
   'Leave the first non modelspace layout to be the current one
   For Each objLayout In ThisDrawing.Layouts
       If objLayout.Name <> "Model" Then
           ThisDrawing.ActiveLayout = objLayout
           Exit For
       End If
   Next

   '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

   
   '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 "
    
   '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 model space inside paper space
   ThisDrawing.MSpace = False
   
Exit Sub
ErrorFound:
   'Call HandleErrors(Err, "getCrossingBoxPoints")
End Sub

Also please note that I changed the 'objEntities' to a single element array, rather than dynamically allocating.

 

I hope this helps you! It actually helped me as well since that was a serious bug! :shock:

Link to comment
Share on other sites

Thanks for your reply. it is so kind of you:)

 

But, i guess there is a misunderstood between us. to take a trivial instance, there is a line, one part of the line is in the viewpoint, and the other part of the line is out of the viewpoint. when i delete the object, i delete the whole line!, because i used the selectset select the whole line. but, in fact, i only want to delete the part of the line out of the viewpoint. so, i used trim to cut the line into two part and only select the part out of the viewpoint, and delete.

 

Are we clear now? can you give me some hints?

Link to comment
Share on other sites

I understood you're original question, but like I said it's probably not a good idea to do this:

I would avoid trimming as some objects, like blocks and text won't allow you to trim them.
As a side note, using 'ThisDrawing.SendCommand' has been known to cause problems because your code continues to run in the background while the AutoCAD API is still doing it's thing making execution sketchy at best.

 

I did a quick google on trimming in AutoCAD using VBA and it appears the developers did not include that functionality; probably because of some of the reasons I listed.

 

If you want to continue with the trimming concept, you might try using lisp (as much as I personally HATE lisp!). It does have functions for trimming.

 

Good luck and I'm sorry I couldn't provide any further help! I hope my code at least helps you in your ventures!

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...