AutoCAD 2004 - Deleted dimensions from selection

[malik641]

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:

[vba]
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
[/vba]
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]

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]

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.
[VBA]
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
[/VBA]

[lucas]

Tommy, I get a sub or function not defined on this line:
[VBA]
Regen acActiveViewport
[/VBA]

[Tommy]

Ok one that works in a module instead of thisdocument code pane

Thats what I get for doing quick and dirty.
[VBA]
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
[/VBA]

[lucas]

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]

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


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

[lucas]

Joseph,
silly question but did you make your selection before running the macro?

[malik641]

Yes.

[Tommy]

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.
[VBA]
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
[/VBA]

[malik641]

Hey Tommy,

Great stuff 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]

looks like a kb entry to me

[malik641]

looks like a kb entry to me

Yeah Tommy, nice work

[Tommy]

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?
[VBA]
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
[/VBA]

[malik641]

Had to config it a little for me (most notably because I have Option Explicit):
[vba]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[/vba]

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:

[vba]
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
[/vba]

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



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]

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]

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 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.

[vba]
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

[/vba]

edited - found an error

[lucas]

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?
[VBA]
Sub DelDim()
&
Sub DelDimSSet()

[/VBA]

[Tommy]

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.

[VBA]
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

[/VBA]

Sorry I am rambling again ROFLMA

[malik641]

This is just too cool. I'm going to check this out later tonight Unfortunately I have to go to class (normally I like class....but not MicroEconomics...I like my engineering courses MUCH better).

Be back tonight