Deleting Duplicate Blocks - Code Help Requested

After searching the NG and google, I've not found much. MAP has the cleanup, however "...Points, text, and blocks are not included in delete duplicate calculations..." (from MAP help).

I'd like to insert a block (an iron pin) at the ends of each line. My problem is where two or more lines intersect, my code inserts a duplicate block.

After trying a variety of things, i'm requesting some help from folks who actually know what they're doing!

Currently, I'm attempting to compare insertion points along with the object's handle...

TIA!

Here's what I have so far:

Code:

Public Sub CleanUpDuplicates()
Dim oBlkRef As AcadBlockReference
Dim oBlkRefToValidate As AcadBlockReference
Dim oSS As AcadSelectionSet
Dim oSS_Temp As AcadSelectionSet
Dim removeObjects(0) As AcadEntity
Dim grpCode(0 To 1) As Integer
Dim dataVal(0 To 1) As Variant

'create a new selection set object
Set oSS = vbdPowerSet("TEMP_SS")
Set oSS_Temp = vbdPowerSet("TEMP_SS_To_Compare")

' Build a selection set of group codes and values to filter for: Text or Mtext.
grpCode(0) = 0
dataVal(0) = "INSERT"
grpCode(1) = 2
dataVal(1) = "IP"
oSS.Select acSelectionSetAll, , , grpCode, dataVal
oSS_Temp.Select acSelectionSetAll, , , grpCode, dataVal

For Each oBlkRef In oSS
For Each oBlkRefToValidate In oSS_Temp
If getDistance(oBlkRef.InsertionPoint, oBlkRefToValidate.InsertionPoint) = 0 And _
oBlkRef.Handle <> oBlkRefToValidate.Handle Then
Set removeObjects(0) = oBlkRef
oSS_Temp.RemoveItems removeObjects
End If
Next
Next


End Sub

' calc distance from two points
Private Function getDistance(Point1, Point2) As Double
Dim dist As Double
Dim i As Integer

On Error Resume Next
For i = LBound(Point1) To UBound(Point1)
dist = dist + ((Point1(i) - Point2(i)) ^ 2)
If Err Then Exit For
Next

getDistance = Sqr(dist)
End Function

 

Seems like the actual problem, is that your code should
not insert duplicate blocks to start with.

Have you considered addressing that problem directly?

I suppose you would need to check the insertion points
of all existing inserts to see if any are at the location
where the next one will go.

 

Yes Tony, I originally tried to use a SelectAtPoint, but could never get the block returned...
I've read that SelectAtpoint can be flakey and that I should use a selection polygon instead...

As for the "check the insertion points of all existing inserts" that's what i was hoping my "cleanup" routine would do. however, it's not working either...

 

Along the lines of Tony's suggestion, you might consider using a
Microsoft Scripting dictionary to keep track of your inserted blocks.

Convert your object endpoints to string in the form X,Y,Z. If you use
that string as a key, you'll be able to query the dictionary to see if
the key's already present thus indicating a prior insertion.

 

Here's a little function that can be called to check if a block exists
already:

Public Function IsBlockThere(strBname As String, chkPt As Variant) As
Boolean
Dim ssBlocks As AcadSelectionSet
Dim iCode(1) As Integer, vValue(1) As Variant
Dim oBlock As AcadBlockReference

On Error Resume Next
Set ssBlocks = ThisDrawing.SelectionSets.Item("ss-blocks")
If Err.Number <> 0 Then
Err.Clear
Set ssBlocks = ThisDrawing.SelectionSets.Add("ss-blocks")
End If
On Error GoTo 0
ssBlocks.Clear
iCode(0) = 0: vValue(0) = "INSERT"
iCode(1) = 2: vValue(1) = strBname
ssBlocks.Select acSelectionSetAll, , , iCode, vValue
IsBlockThere = False
If ssBlocks.Count > 0 Then
For Each oBlock In ssBlocks
If oBlock.InsertionPoint(0) = chkPt(0) And _
oBlock.InsertionPoint(1) = chkPt(1) Then
IsBlockThere = True
Exit For
End If
Next
End If
End Function

And this is how I'd use it:

Sub TESTME()
Dim bname As String
Dim inspt As Variant
Dim util As AcadUtility

Set util = ThisDrawing.Utility
inspt = util.GetPoint(, vbLf & "Next insertion Point: ")
bname = "ips"
If IsBlockThere(bname, inspt) = False Then
ThisDrawing.ModelSpace.InsertBlock inspt, bname, 50#, 50#, 50#, 0
End If
End Sub

 

Hi,

An relatively easy and reliable approach to this problem is:

Make a collection (colLines) of all the lines on which you intend to add the
blocks. If you have arcs and you need the centre as well then you need to
handle the array sizing differently as there will be three points instead of
two.

Dimension an array to hold items of the number of ends with X, Y and Z
values.

eg Dim baEnds () as double
Redim baEnds(0 to colLines.Count -1, 0 to 2)
Add the ends of the lines into the array and then sort it by the X field

You can then insert a block at the first point and for subsequent points you
check if the X value is the same as the previous point Abs(X1-X2) <
ToleranceValue
If it is check the Y value and finally the Z value. If all are the same
don't insert.

--


Laurie Comerford
CADApps
www.cadapps.com.au

cleanup, however "...Points, text, and blocks are not included in delete
duplicate calculations..." (from MAP help).

problem is where two or more lines intersect, my code inserts a duplicate
block.

actually know what they're doing!

 

you could always try to delete the possible existing block before inserting it again:
ss_temp.Clear
On Error Resume Next
ss_temp.SelectAtPoint InsertionPoint … (filters for blockreferences only)
ss_temp.Delete
'now insert the block in InsertionPoint
…
to make your block be selectable "at point", some elements of the block have to go through that point. In case they aren't, you could add a point (AcadPoint) in the definition of your block, placing it at the insertion point

 

One hack would be to use the Express tool OVERKILL.

Just a suggestion.

 

This will get you started
--


Public pi As Double
Public chkSize As Double
Public sFuzz As Double




Private Sub PutBlk()
Dim ssLin As AcadSelectionSet
Dim Dtype(0) As Integer
Dim Dvalue(0) As Variant
Dim i As Integer
Dim sEnt As AcadEntity
Dim sLine As AcadLine
Dim sArc As AcadArc
Dim sSpace As AcadLayout
Dim Spnt As Variant
Dim Epnt As Variant
'Dim sLine As AcadLine
'Dim sArc As AcadArc

pi = 4 * Atn(1)
chkSize = 10 * 1.5 'block's bounding box largest side + 50 %
sFuzz = 0.001

On Error Resume Next
ThisDrawing.SelectionSets("test").Delete
Set ssLin = ThisDrawing.SelectionSets.Add("test")
On Error GoTo 0

Dtype(0) = 0: Dvalue(0) = "Line,Arc"

ssLin.Select acSelectionSetAll, , , Dtype, Dvalue

For Each sEnt In ssLin
If TypeOf sEnt Is AcadLine Then
Set sLine = sEnt
Spnt = sLine.StartPoint
Epnt = sLine.EndPoint
Else
Set sArc = sEnt
Spnt = sArc.StartPoint
Epnt = sArc.EndPoint
End If

If NoBlk(Spnt, chkSize, sFuzz) Then
ThisDrawing.ModelSpace.InsertBlock Spnt, "TheBlock", 1#, 1#, 1#, 0#
End If

If NoBlk(Epnt, chkSize, sFuzz) Then
ThisDrawing.ModelSpace.InsertBlock Epnt, "TheBlock", 1#, 1#, 1#, 0#
End If

Next sEnt



End Sub



Private Function NoBlk(iPoint As Variant, iSize As Double, cfuzz As Double)
As Boolean
Dim pnt1 As Variant
Dim pnt2 As Variant
Dim ssBlk As AcadSelectionSet
Dim fType(0) As Integer
Dim fValue(0) As Variant
Dim sIns As AcadBlockReference
Dim sBlk As Variant

fType(0) = 0
fValue(0) = "INSERT"


pnt1 = ThisDrawing.Utility.PolarPoint(iPoint, pi * 1.25, iSize / 2)
pnt2 = ThisDrawing.Utility.PolarPoint(iPoint, pi / 4#, iSize / 2)



On Error Resume Next
ThisDrawing.SelectionSets("bTest").Delete
Set ssBlk = ThisDrawing.SelectionSets.Add("bTest")
On Error GoTo 0

ssBlk.Select acSelectionSetWindow, pnt1, pnt2, fType, fValue

For Each sIns In ssBlk
sBlk = sIns.InsertionPoint
If Abs(sBlk(0) - iPoint(0)) <= cfuzz And Abs(sBlk(1) - iPoint(1)) <=
cfuzz And Abs(sBlk(2) - iPoint(2)) <= cfuzz Then
NoBlk = False
Exit Function
End If
Next sIns
NoBlk = True

End Function

 

While the rest have helped move you along with this, no one has pointed out
the problem in your logic - the block does not exist at the point you
inserted it! The block has no geometry there so SAP won't find it. There is
no problem or flakiness with that method, just a general lack of
understanding.

FWIW use a collection or dictionary for your points. While Frank points out
using a dictionary to check for the existance of the point already within
the dctionary, just error trap it or a collection:

On Error Resume Next
MyCollection.Add "x:y:z"
If Err.Number <> 0 Then Err.Clear

Crude but effective. Once your points are assembled, insert your blocks.
There is no need for a cleanup routine.

-- Mike
___________________________
Mike Tuersley
CADalyst's CAD Clinic
Rand IMAGINiT Technologies
___________________________
the trick is to realize that there is no spoon...

 

Mike,
That's why I was posting - I know my programming skills are hardly up to par.

Thanks to all for the code and logic suggestions as well...

 

Some things I've tried so far:
I tried to use a collection, but it didn't seem to care about duplicates.
I tried to use a dictionary, but couldn't figure out how to store the coords (besides a comma delimited string, then i'd need to reassemble that back to an array). As many have noted, the help is either weak (or in my case, simply not there.)

I was able to use the code provided here to get things working. However, as Mike pointed out, there IS a problem with my original logic.

I'd like to further my understanding of objects like dictionaries (I became excited when I read they are like "collections on steriods", and a bit disappointed to find no help)

Thanks again for all the help, suggestions, and time offered.

 

What you are looking to do at least point-wise is simple. Here run this
example using a collection [watch for wordwrap]:

Sub Test()
Dim cPoints As Collection
Set cPoints = New Collection

Dim iIndex As Integer
Dim dPt() As Double

For iIndex = 1 To 5
'get point
dPt = ThisDrawing.Utility.GetPoint(, "Select point number " & iIndex &
": ")
'the point is added to the collection - the "point" itself is the
object and
'the concatenation of X_Y_Z is the key to ensure the points are unique
'NOTE: Don't try inputing the same point twice UNLESS you incorporate
the
'error trap below
cPoints.Add dPt, dPt(0) & "_" & dPt(1) & "_" & dPt(2)

Next

'now try to re-add the last point...if you step thru it, you'll see an
'error fires so the point isn't added
On Error Resume Next
cPoints.Add dPt, dPt(0) & "_" & dPt(1) & "_" & dPt(2)
If Err.Number <> 0 Then Err.Clear

'now lets use the points
Dim oLine As AcadLine

For iIndex = 1 To 4
Set oLine = ThisDrawing.ModelSpace.AddLine(cPoints.Item(iIndex),
cPoints.Item(iIndex + 1))
oLine.color = iIndex
Next

End Sub
-- Mike
___________________________
Mike Tuersley
CADalyst's CAD Clinic
Rand IMAGINiT Technologies
___________________________
the trick is to realize that there is no spoon...

 

just to list another possibility: you could build a data tree (instead of a collection); binary trees are easy to understand and funny; moreover they order your points (so if you like, you can label each block with a progressive number); if you don't know anything about trees in general and in vba, give a look to

http://www.developershandbook.com/Downloads/1951c06.pdf

be aware that there is an error in the AddNode function (pg.43); the last lines have to be
...
End if
Set AddNode = ti '''this line was missed
End Function

 

Thanks again Mike. I thought I tried a similar approach, but couldn't generate the error (using the coords in a string as the key).

Not sure what I did differently, but your code works as you suggested.

This is actually going to be a big help with another project (finding entities within each parcel - duplicate coords have been killing me!)

 

FWIW, the solution I posted allows you to run your routine in seperate
drawing sessions whereas the other solutions expect it to be run only once.
I mention this only because I, too, work with lots and iron pipes......and I
can't think of a job I've worked on in the last 5 years that the client has
not changed the lot lines after I've gotten the subdivison map pretty much
complete. Using my little function allows you to make the changes and
re-select all of your lot lines/arcs and only the revised ones will get
pipes placed on them.

Here's a better suited example:
Sub PlaceIronPipes()
Dim sBname As String
Dim inspt As Variant
Dim ss As AcadSelectionSet
Dim iCode(0) As Integer, vValue(0) As Variant
Dim oEnt As AcadEntity
Dim dScale As Double

On Error Resume Next
Set ss = ThisDrawing.SelectionSets.Item("lines")
If Err.Number <> 0 Then
Set ss = ThisDrawing.SelectionSets.Add("lines")
Err.Clear
End If
ss.Clear
On Error GoTo 0
iCode(0) = 0: vValue(0) = "LINE,ARC"
ss.SelectOnScreen iCode, vValue
sBname = "ips"
dScale = ThisDrawing.GetVariable("dimscale")
ThisDrawing.StartUndoMark
For Each oEnt In ss
inspt = oEnt.StartPoint
If IsBlockThere(sBname, inspt) = False Then
ThisDrawing.ModelSpace.InsertBlock inspt, sBname, dScale, dScale,
dScale, 0
End If
inspt = oEnt.EndPoint
If IsBlockThere(sBname, inspt) = False Then
ThisDrawing.ModelSpace.InsertBlock inspt, sBname, dScale, dScale,
dScale, 0
End If
Next
ThisDrawing.EndUndoMark
End Sub

 

FWIW, the solution I posted allows you to run your routine in seperate

Not exactly true =) I posted an example of how to use a collection, not a
solution for which you wrote.

FWIW, you're app can be optimized if you incorporate either collections or
dictionaries. Every time you insert a block, you grab a selection set of
all blockrefs with the same name, then a selection set for pipes, then
iterate thru them.

You could build a collection for each blockref when your program launches.
Then instead of selectionsets and iterations you just error trap adding the
point in question to the right collection [or do an .Exist on a
dictionary].

-- Mike
___________________________
Mike Tuersley
CADalyst's CAD Clinic
Rand IMAGINiT Technologies
___________________________
the trick is to realize that there is no spoon...

 

OK, so you forced me to look into collections again
I had originally thought of something like this, but thought it wouldn'y
make that much of a difference.........that's what I get for thinking. The
following version is at LEAST 1000 times faster than my previous one. Thanks
for the push.

Option Explicit
Dim colBlks As Collection


Public Function IsBlockThere(strBname As String, chkPt As Variant) As
Boolean
Dim ssBlocks As AcadSelectionSet
Dim iCode(1) As Integer, vValue(1) As Variant
Dim oBlock As AcadBlockReference
Dim I As Long
Dim insPt As Variant
Dim sPoint As String
Dim sChkPt As String

IsBlockThere = False
sChkPt = chkPt(0) & "," & chkPt(1) & "," & chkPt(2)
On Error Resume Next
Set ssBlocks = ThisDrawing.SelectionSets.Item("ss-blocks")
If Err.Number <> 0 Then
Err.Clear
Set ssBlocks = ThisDrawing.SelectionSets.Add("ss-blocks")
iCode(0) = 0: vValue(0) = "INSERT"
iCode(1) = 2: vValue(1) = strBname
ssBlocks.Select acSelectionSetAll, , , iCode, vValue
If ssBlocks.Count > 0 Then
For Each oBlock In ssBlocks
insPt = oBlock.InsertionPoint
sPoint = insPt(0) & "," & insPt(1) & "," & insPt(2)
colBlks.Add I, sPoint
I = I + 1
Next
End If
End If
sPoint = ""
sPoint = colBlks.Item(sChkPt)
If Not sPoint = "" Then IsBlockThere = True

End Function

Sub PlaceIronPipes()
Dim sBname As String
Dim insPt As Variant
Dim ss As AcadSelectionSet
Dim iCode(0) As Integer, vValue(0) As Variant
Dim oEnt As AcadEntity
Dim dScale As Double
Dim sPoint As String


On Error Resume Next
colBlks.Count
If Err.Number <> 0 Then Set colBlks = New Collection
Err.Clear
Set ss = ThisDrawing.SelectionSets.Item("lines")
If Err.Number <> 0 Then
Set ss = ThisDrawing.SelectionSets.Add("lines")
Err.Clear
End If
ss.Clear
On Error GoTo 0
iCode(0) = 0: vValue(0) = "LINE,ARC"
ss.SelectOnScreen iCode, vValue
sBname = "ips"
dScale = ThisDrawing.GetVariable("dimscale")
ThisDrawing.StartUndoMark
For Each oEnt In ss
insPt = oEnt.StartPoint
If IsBlockThere(sBname, insPt) = False Then
ThisDrawing.ModelSpace.InsertBlock insPt, sBname, dScale, dScale,
dScale, 0
sPoint = insPt(0) & "," & insPt(1) & "," & insPt(2)
colBlks.Add colBlks.Count, sPoint
End If
insPt = oEnt.EndPoint
If IsBlockThere(sBname, insPt) = False Then
ThisDrawing.ModelSpace.InsertBlock insPt, sBname, dScale, dScale,
dScale, 0
sPoint = insPt(0) & "," & insPt(1) & "," & insPt(2)
colBlks.Add colBlks.Count, sPoint
End If
Next
ThisDrawing.EndUndoMark
End Sub


--
Jeff
check out www.cadvault.com

 

Thanks for the push.
Any time, Jeff ;-)

-- Mike
___________________________
Mike Tuersley
CADalyst's CAD Clinic
Rand IMAGINiT Technologies
___________________________
the trick is to realize that there is no spoon...

 

Jeff,
After reading your "1000 times faster" comment, I decided to try your updated IsBlockThere function. I'm back to getting duplicate blocks at lot line intersections.

I'm not sure why, but as I've said a few times in the thread - thanks to you and everyone for the help. It may be ugly, but it's working