[编程交流] AcadPViewport2 - Deleting item

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

    '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

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

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

    '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   '???

'Returns true if the cleanup was successful; false if it wasn'tPublic Function cleanupDWG() As Boolean'On Error Resume NextOn 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 = TrueExit FunctionErrorFound:   '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 IfEnd Function'Retrieves the model space lower right and upper left points of the viewportPrivate 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 SubErrorFound:   'Error occured.  Tell user and exit the program.   MsgBox "Error occured in private sub getCrossingBoxPoints!  Exiting program...", _   vbCritical + vbOKOnly, "Error!!!"   EndEnd Sub

'Returns true if the cleanup was successfully; false if it wasn'tPublic Function cleanupDWG() As Boolean'On Error Resume NextOn 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 = TrueExit FunctionErrorFound:   '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 IfEnd Function'Retrieves the model space lower right and upper left points of the viewportPrivate 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 SubErrorFound:   'Error occured.  Tell user and exit the program.   MsgBox "Error occured in private sub getCrossingBoxPoints!  Exiting program...", _   vbCritical + vbOKOnly, "Error!!!"   EndEnd Sub