PDA

View Full Version : AutoCAD 2004 - Deleted dimensions from selection



malik641
03-16-2006, 06:37 AM
:banghead: I really need to start reading my AutoCAD VBA book.

Anyway, I can't get this to work for me. The code is simple, but I keep getting an error.

What is supposed to happen is I'll select a whole bunch of entities, then run this macro to delete solely dimensions:


Option Explicit
Sub Delete_Dims()
'On Error Resume Next
Dim oDim As AcadDimension

For Each oDim In ThisDrawing.ActiveSelectionSet
'On Error Resume Next
oDim.Delete
Next
End Sub

The error will come up in the For loop OR in the oDim.Delete, depending where I place the On Error Resume Next statement. Either way, the error is saying that oDim = Nothing...but I can't use an IF statement like:

If oDim = Nothing Then.....

I'm not sure what to do to get this to work out...any help is appreciated :)

lucas
03-16-2006, 07:51 AM
Hi Joseph,
I hate to ask you this but why would you want to delete all of the diminsions? If they are all on one layer you can just turn that layer off or delete it.

Tommy
03-16-2006, 07:51 AM
Hi Joseph,
When selecting the entities you could also use the filter method just an FYI. The below sub will take the existing active selection set and delete all dim objects found.

Sub DelDimSSet()
Dim oDim As AcadDimension
Dim mDelDimSset As AcadSelectionSet
Dim mI As Integer, mTmp() As AcadEntity
Dim mCntr As Long
ReDim mTmp(30)
Set mDelDimSset = SelectionSets.Add("DimDelete")
For mI = ThisDrawing.ActiveSelectionSet.Count - 1 To 0 Step -1
If InStr(1, ThisDrawing.ActiveSelectionSet(mI).ObjectName, "Dimension") > 0 Then
Set mTmp(mCntr) = ThisDrawing.ActiveSelectionSet.Item(mI)
mCntr = mCntr + 1
If UBound(mTmp) < mCntr Then
ReDim Preserve mTmp(mCntr - 1)
End If
End If
Next
ReDim Preserve mTmp(mCntr - 1)
mDelDimSset.AddItems mTmp
mDelDimSset.Erase
mDelDimSset.Delete
Regen acActiveViewport
End Sub

lucas
03-16-2006, 07:55 AM
Tommy, I get a sub or function not defined on this line:

Regen acActiveViewport

Tommy
03-16-2006, 08:03 AM
Ok one that works in a module instead of thisdocument code pane :)

Thats what I get for doing quick and dirty. :)

Sub DelDimSSet()
Dim oDim As AcadDimension
Dim mDelDimSset As AcadSelectionSet
Dim mI As Integer, mTmp() As AcadEntity
Dim mCntr As Long
ReDim mTmp(30)
Set mDelDimSset = ThisDrawing.SelectionSets.Add("DimDelete")
For mI = ThisDrawing.ActiveSelectionSet.Count - 1 To 0 Step -1
If InStr(1, ThisDrawing.ActiveSelectionSet(mI).ObjectName, "Dimension") > 0 Then
Set mTmp(mCntr) = ThisDrawing.ActiveSelectionSet.Item(mI)
mCntr = mCntr + 1
If UBound(mTmp) < mCntr Then
ReDim Preserve mTmp(mCntr - 1)
End If
End If
Next
ReDim Preserve mTmp(mCntr - 1)
mDelDimSset.AddItems mTmp
mDelDimSset.Erase
mDelDimSset.Delete
ThisDrawing.Regen acActiveViewport
End Sub

lucas
03-16-2006, 08:10 AM
That works great Tommy. I posted too quickly to Joseph, after thinking about it you might want to delete all of the dims from an area on a drawing.

malik641
03-16-2006, 08:25 AM
Steve,

Exactly. It's a nice tool for my work.

Tommy,
Error, subscript out of range:

Set mTmp(mCntr) = ThisDrawing.ActiveSelectionSet.Item(mI)

mCntr = 31 and mI = 24
:dunno

But really appreciate this...I thought the code would be much simpler.

lucas
03-16-2006, 08:31 AM
Joseph,
silly question but did you make your selection before running the macro?

malik641
03-16-2006, 08:34 AM
Yes.

Tommy
03-16-2006, 09:07 AM
You should see how much lisp it takes to find the boundry of an existing hatch. VBA can't touch it as far as I can tell at this time, it will only work on DXF's (which is what I read and write). I still looking for a start on finding the boundry.

Anyway I had a brain cramp and was subtracting instead of adding, sorry for the problems.

Sub DelDimSSet()
Dim oDim As AcadDimension
Dim mDelDimSset As AcadSelectionSet
Dim mI As Integer, mTmp() As AcadEntity
Dim mCntr As Long
ReDim mTmp(30)
Set mDelDimSset = ThisDrawing.SelectionSets.Add("DimDelete")
For mI = ThisDrawing.ActiveSelectionSet.Count - 1 To 0 Step -1
If InStr(1, ThisDrawing.ActiveSelectionSet(mI).ObjectName, "Dimension") > 0 Then
Set mTmp(mCntr) = ThisDrawing.ActiveSelectionSet.Item(mI)
mCntr = mCntr + 1
If UBound(mTmp) < mCntr Then
' the below line was subtracting instead of adding
ReDim Preserve mTmp(mCntr)
End If
End If
Next
ReDim Preserve mTmp(mCntr - 1)
mDelDimSset.AddItems mTmp
mDelDimSset.Erase
mDelDimSset.Delete
ThisDrawing.Regen acActiveViewport
End Sub

malik641
03-16-2006, 09:19 AM
Hey Tommy,

Great stuff :thumb :thumb Really appreciate this. Thanks a lot!



BTW, I'm not familiar with LISP at all...and if the Hatch idea is too much trouble....then don't worry about it. It's not a big issue right now anyway, I was just curious and I thought it would be a helpful tool.

lucas
03-16-2006, 09:21 AM
looks like a kb entry to me

malik641
03-16-2006, 09:46 AM
looks like a kb entry to me
Yeah Tommy, nice work :thumb

Tommy
03-16-2006, 10:07 AM
Joseph,

This will allow you to select by crossing a group of entities and delete the dimensions only. It does not show the entities selected (I have that code somewhere in the BOM editer/editor), do you two think it needs it?

Sub DelDim()
Dim ssetA As AcadSelectionSet
Dim gpCode(0) As Integer, InsrtPnt As Variant, InsrtPnta As Variant
Dim dataValue(0) As Variant
InsrtPnt = ThisDrawing.Utility.GetPoint(, "Pick a corner:")
InsrtPnta = ThisDrawing.Utility.GetPoint(, "Pick a corner:")
gpCode(0) = 0
dataValue(0) = "Dimension"
groupCode = gpCode
dataCode = dataValue
Set ssetA = SelectionSets.Add("DimDelete")
ssetA.Select acSelectionSetCrossing, InsrtPnt, InsrtPnta, groupCode, dataCode
ssetA.Erase
ssetA.Delete
ThisDrawing.Regen acActiveViewport
End Sub

malik641
03-16-2006, 10:27 AM
Had to config it a little for me (most notably because I have Option Explicit):
Sub DelDim()
Dim groupCode, dataCode
Dim ssetA As AcadSelectionSet
Dim gpCode(0) As Integer, InsrtPnt As Variant, InsrtPnta As Variant
Dim dataValue(0) As Variant
InsrtPnt = ThisDrawing.Utility.GetPoint(, "Pick a corner:")
InsrtPnta = ThisDrawing.Utility.GetPoint(, "Pick a corner:")
gpCode(0) = 0
dataValue(0) = "Dimension"
groupCode = gpCode
dataCode = dataValue
Set ssetA = ThisDrawing.SelectionSets.Add("DimDelete")
ssetA.Select acSelectionSetCrossing, InsrtPnt, InsrtPnta, groupCode, dataCode
ssetA.Erase
ssetA.Delete
ThisDrawing.Regen acActiveViewport
End Sub

If you want my opinion, I wouldn't use the two points...instead I would just have a "Select Objects" inplace of that. And BTW, I realize when I was playing with the code I ran into some errors if the "DimDelete" SelectionSet was already created, so I did this:


Option Explicit
Sub Delete_Dims()
Dim oDim As AcadDimension
Dim mDelDimSset As AcadSelectionSet
Dim mI As Integer, mTmp() As AcadEntity
Dim mCntr As Long
ReDim mTmp(30)
SelectionSetCheck ("DimDelete")
Set mDelDimSset = ThisDrawing.SelectionSets.Add("DimDelete")
For mI = ThisDrawing.ActiveSelectionSet.Count - 1 To 0 Step -1
If InStr(1, ThisDrawing.ActiveSelectionSet(mI).ObjectName, "Dimension") > 0 Then
Set mTmp(mCntr) = ThisDrawing.ActiveSelectionSet.Item(mI)
mCntr = mCntr + 1
If UBound(mTmp) < mCntr Then
' the below line was subtracting instead of adding
ReDim Preserve mTmp(mCntr)
End If
End If
Next
ReDim Preserve mTmp(mCntr - 1)
mDelDimSset.AddItems mTmp
mDelDimSset.Erase
mDelDimSset.Delete
ThisDrawing.Regen acActiveViewport
End Sub
Function SelectionSetCheck(ByVal SelectionSetName As String) As Boolean
On Error GoTo Handler
ThisDrawing.SelectionSets.Add (SelectionSetName)
SelectionSetCheck = True
ThisDrawing.SelectionSets(SelectionSetName).Delete
Exit Function
Handler:
SelectionSetCheck = False
End Function


And if I mess with the code (this was when I was trying to figure out why it wasn't working before) sometimes I would get an "Object Variable With Block not set" error with this variable:

mDelDimSset


Just to help you make it a KB entry :yes



Edit: Come to think of it, that function should be a sub now....eh. Originally I used an IF statement checking the Boolean value of the function, which is why I made is a function to begin with. Oh well.

malik641
03-16-2006, 10:31 AM
Oh yeah, AND I would make it so that if the entities were already selected, to just perform like the original macro. If no entities were selected, to allow the user to choose the objects.

Tommy
03-16-2006, 12:50 PM
OK - This one will ask if you want to delete the dimension objects in the active selection set, they will be highlighted on screen, if there is any. This is just in case the last selection set what you thought :rofl: happens to me all the time. Then the select objects starts, this is the standard acad user interface for selecting objects, left for crossing etc.. It will only select the dimension objects, pressing enter will delete the selected items. Now because just as soon as I press enter, I will see 2 or 3 more that I need to delete, the select option will continue until there are no entities selected.


Sub DelDim()
Dim ssetA As AcadSelectionSet
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
Dim groupCode As Variant
Dim dataCode As Variant
gpCode(0) = 0
dataValue(0) = "Dimension"
groupCode = gpCode
dataCode = dataValue
Set ssetA = Aset("DimDelete")
ssetA.SelectOnScreen groupCode, dataCode
While ssetA.Count
ssetA.Highlight True
ssetA.Erase
ThisDrawing.Regen acActiveViewport
ssetA.SelectOnScreen groupCode, dataCode
Wend
ssetA.Delete
End Sub
Sub DelDimSSet()
Dim oDim As AcadDimension
Dim mDelDimSset As AcadSelectionSet
Dim mI As Integer, mTmp() As AcadEntity
Dim mCntr As Long
ReDim mTmp(30)
If ThisDrawing.ActiveSelectionSet.Count Then
For mI = ThisDrawing.ActiveSelectionSet.Count - 1 To 0 Step -1
If InStr(1, ThisDrawing.ActiveSelectionSet(mI).ObjectName, "Dimension") > 0 Then
Set mTmp(mCntr) = ThisDrawing.ActiveSelectionSet.Item(mI)
mCntr = mCntr + 1
If UBound(mTmp) < mCntr Then
ReDim Preserve mTmp(mCntr)
End If
End If
Next
If mCntr Then
ReDim Preserve mTmp(mCntr - 1)
Set mDelDimSset = Aset("DimDelete")
mDelDimSset.AddItems mTmp
mDelDimSset.Highlight True
Select Case MsgBox("Please Confirm Highlighted Entities are to be deleted.", vbYesNo Or vbExclamation Or vbDefaultButton1, "Confirm Deletion!")
Case vbYes
mDelDimSset.Erase
mDelDimSset.Delete
Case vbNo
mDelDimSset.Delete
End Select
End If
End If
ThisDrawing.Regen acActiveViewport
DelDim
End Sub
Function Aset(iSSetName As String) As AcadSelectionSet
Dim ssetA As AcadSelectionSet
On Error Resume Next
Set ssetA = ThisDrawing.SelectionSets.Add(iSSetName)
If Err.Number <> 0 Then
Set ssetA = ThisDrawing.SelectionSets(iSSetName)
ssetA.Delete
Set ssetA = ThisDrawing.SelectionSets.Add(iSSetName)
Err.Clear
End If
On Error GoTo 0
Set Aset = ssetA
End Function



edited - found an error

lucas
03-16-2006, 02:22 PM
Lots of joy here....Joseph, in case you hadn't noticed Tommy likes to take it to the limit. Haven't had time to do anything but try it but was wondering why there are two subs Tommy?

Sub DelDim()
&
Sub DelDimSSet()

Tommy
03-16-2006, 02:47 PM
The DelDimSSet is to delete the Dimensions from the ActiveSelectionSet (per the original question) I also ask if these are the ones you want to delete. Then DelDim allows you to select more dimensions if you need to, if no press enter. This way if there are dims in the active selection set they are deleted, and you are asked for more. or if there are no dims in the original ss you are asked if you want to select some to delete.

BTW you can modify this to include any entity or entities you want. You can filter by layer, entity type.

The change below will select all entities on the layers "STEEL", and "HOTROLLED", but if it is a hatch it will exclude it.


Sub DelDim()
Dim ssetA As AcadSelectionSet
Dim gpCode(6) As Integer
Dim dataValue(6) As Variant
Dim groupCode As Variant
Dim dataCode As Variant
' gpCode(0) = 0
' dataValue(0) = "Dimension"
gpCode(0) = -4
dataValue(0) = "<or"
gpCode(1) = 8
dataValue(1) = "STEEL"
gpCode(2) = 8
dataValue(2) = "HOTROLLED"
gpCode(3) = -4
dataValue(3) = "or>"
gpCode(4) = 67
dataValue(4) = 0 '
gpCode(5) = -4
dataValue(5) = "<not"
gpCode(6) = 0
dataValue(6) = "hatch"
gpCode(6) = -4
dataValue(6) = "not>"

groupCode = gpCode
dataCode = dataValue
Set ssetA = Aset("DimDelete")
ssetA.SelectOnScreen groupCode, dataCode
While ssetA.Count
ssetA.Highlight True
ssetA.Erase
ThisDrawing.Regen acActiveViewport
ssetA.SelectOnScreen groupCode, dataCode
Wend
ssetA.Delete
End Sub



Sorry I am rambling again ROFLMA

malik641
03-16-2006, 03:56 PM
This is just too cool. I'm going to check this out later tonight :thumb Unfortunately I have to go to class :mkay (normally I like class....but not MicroEconomics...I like my engineering courses MUCH better).

Be back tonight :yes

lucas
03-17-2006, 09:39 AM
For those following this thread, Tommy has submitted the delete dims code to the kb and it should be available there soon.