Deleting Duplicate Blocks - Code Help Requested

He's probably not taking into consideration a fuzz factor.
When working with high value coordinates, this becomes
very important.

 

Actually, I tested this in my Civil drawings that use large coordinates and
it worked well for me.
I have made a few more tweaks to allow the resetting of the collection,
which must be done if any blocks have been erased or when changing drawings
since the collection is public it remains active across drawings. I've
modified it to only check to 3 decimal places to avoid potential 'fuzz'
problems.
It now functions properly (for me) from drawing to drawing, if lines are
moved or added, or if blocks are deleted.

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

Err.Clear
IsBlockThere = False
sChkPt = Var2String(chkPt)
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 = Var2String(inspt)
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 sRedo As String

On Error Resume Next
ThisDrawing.Utility.InitializeUserInput 0, "Yes No"
sRedo = ThisDrawing.Utility.GetKeyword("Reset collection?[Yes/No]{No} ")
If sRedo = "" Then sRedo = "No"
If sRedo = "Yes" Then
Err.Raise 9999999
ThisDrawing.SelectionSets.Item("ss-blocks").Delete
End If
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" 'Modify to your pipe block
dscale = ThisDrawing.GetVariable("dimscale") 'Modify as desired
ThisDrawing.StartUndoMark
ThisDrawing.Layers.Add "C-MON-SET" 'Modify as desired
For Each oEnt In ss
inspt = oEnt.StartPoint
If IsBlockThere(sbname, inspt) = False Then Ins_Block inspt, sbname,
dscale, 0
inspt = oEnt.EndPoint
If IsBlockThere(sbname, inspt) = False Then Ins_Block inspt, sbname,
dscale, 0
Next
ThisDrawing.EndUndoMark
End Sub

Private Sub Ins_Block(inspt As Variant, sbname As String, dscale As Double,
dRot As Double)
Dim sPoint As String
Dim oBlk As AcadBlockReference
Set oBlk = ThisDrawing.ModelSpace.InsertBlock(inspt, sbname, dscale,
dscale, dscale, dRot)
sPoint = Var2String(inspt)
colBlks.Add colBlks.Count, sPoint
oBlk.Layer = "C-MON-SET" 'Modify as desired
End Sub

Private Function Var2String(vVar As Variant) As String
Var2String = Format(vVar(0), "0.000") & "," & Format(vVar(1), "0.000") &
_
"," & Format(vVar(2), "0.000")
End Function