Ask away... 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 but, maybe there are some errors in my code, the sendcommand of extrim does not work correctly. anyone can give me some hints? 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'tPublic Function cleanupDWG() As BooleanOn 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 = 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 '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 SubErrorFound: 'Call HandleErrors(Err, "getCrossingBoxPoints")End SubAlso 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! 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 usedtrim 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? I understood you're original question, but like I said it's probably not a good idea to do this:
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! Thank you all the same! your code helps me a lot.
谢谢
页:
1
[2]