Cannot delete text using selection set

[sanderson]

I am going crazy with this...

 

This works, but I do not want to have to select on the screen...

 ss.SelectOnScreen

 

I tried to select a crossing of two coordinates, that didn't work...

 ss.Select acSelectionSetCrossing, ip, ipCross

 

My next step was to filter for TEXT and LAYERNAME, but that didn't work either...

    Dim FilterType(0 To 1) As Variant
   Dim FilterData(0 To 1) As Variant
   FilterType(0) = 0: FilterData(0) = "TEXT"
   FilterType(1) = 8: FilterData(1) = "FILEPATHTEXT"
   ss.Select acSelectionSetAll, , , FilterType, FilterData

 

So I have this great little program to add text, and just want to delete it first if it already exists, and I just cannot do it. Help is greatly appreciated.

 

    ' Define Text String coordinates
   Dim dwgscale As Integer
   dwgscale = ThisDrawing.GetVariable("DIMSCALE")
   
   Dim h As Double
   h = 0.1 * dwgscale
   
   Dim minext As Variant
   minext = ThisDrawing.GetVariable("EXTMIN")

   Dim min(0 To 2) As Double
   min(0) = minext(0)
   min(1) = minext(1)
   min(2) = minext(2)

   Dim ip(0 To 2) As Double
   ip(0) = min(0)
   ip(1) = min(1) + negret(h * 1.3)
   ip(2) = 0
   
   ' Check for Text String at coordinates and delete
   Dim ipCross(0 To 2) As Double
   ipCross(0) = ip(0) + h
   ipCross(1) = ip(1) + h
   ipCross(2) = 0
           
   Dim ss As AcadSelectionSet
   On Error Resume Next
   Set ss = ThisDrawing.SelectionSets.Add("DEL")
   Set ss = ThisDrawing.SelectionSets.Item("DEL")
   
   ' ss.Select acSelectionSetCrossing, ip, ipCross ' This doesn't work
   ' ss.SelectOnScreen ' This Works!

   Dim FilterType(0 To 1) As Variant
   Dim FilterData(0 To 1) As Variant
   FilterType(0) = 0: FilterData(0) = ""
   FilterType(1) = 8: FilterData(1) = "FILEPATHTEXT"
   ss.Select acSelectionSetAll, , , FilterType, FilterData
       
   Dim Ent As AcadEntity
   Dim c As Integer
   c = ss.Count
   For c = 0 To ss.Count - 1
       Ent = ss.Item(c)
       Ent.Erase
       Ent.Update
   
   Next

   ss.Update
   ss.Delete
   'ThisDrawing.SelectionSets.Item("DEL").Delete

 

Thanks in advance.

[jammie]

Hi,

 

Just looking at the logic of your code. Are you satisfied that the objects you are filtering does/will always fall between your calculated points ip & ipCross?

 

Whats does the negret function do?

 

Regards

 

Jammie

[sanderson]

It is supposed to be a crossing. Anyhow, I nixed that one. Now if I could just get all the text on one layer I would be happy, but this isn't working either.

[SEANT]

I can't test it myself but what happens if you change:

 

Dim FilterType(0 To 1) As Variant

 

to:

 

Dim FilterType(0 To 1) As Integer

[SEANT]

Also, this looks a bit suspect:

 

FilterType(0) = 0: FilterData(0) = ""

[sanderson]

Int, variant, makes no difference. The other line actually reads.

FilterType(0) = 0: FilterData(0) = "TEXT"

[sanderson]

negret returns a negative #. Thus, 3 = -3, and -3 = -3.

[sanderson]

Ok, I figured this out. Here is the code. It would be nice to see selection sets work though.

 

My only further dilemma is getting zoom extents to work. In the full listing below, I have this:

    ' Regen after deletion
   ThisDrawing.SendCommand "ZOOM" & vbCr & "EXTENTS"
   ThisDrawing.Regen acActiveViewport

 

 

The purpose behind the regen is to restablish the EXTMIN variable after the text in the lower left corner is deleted. If I delete it and regen manually, the program works great. However when done programatically as shown above, it keeps adding to the EXTMIN, making the text dome in at a lower delta-Y every time.

 

Thanks again...

 

Full Listing:

Sub AddPath()
   ' Julian Date Conversion Issues
   Dim lastsave As String
   lastsave = ThisDrawing.GetVariable("TDUPDATE")
   ' *****************************
   
   ' Set Layer to 'BORDER'
   ' Get current layer
   Dim currLayer As String
   currLayer = ThisDrawing.GetVariable("CLAYER")
          
   ' Set new layer
   Dim layerObj As AcadLayer
   Set layerObj = ThisDrawing.Layers.Add("FILEPATHTEXT")
   ThisDrawing.ActiveLayer = layerObj
      
   ' Set Style to 'SIMPLEX
   ' Get current style
   Dim currStyle As String
   currStyle = ThisDrawing.GetVariable("DIMTXSTY")
   
   ' Set new style
   Dim styleObj As AcadTextStyle
   Set styleObj = ThisDrawing.TextStyles.Add("SIMPLEX")
   styleObj.fontFile = "simplex.shx"
   styleObj.Width = 1
   styleObj.Height = 0
   ThisDrawing.ActiveTextStyle = styleObj
   
   ' Zoom extents to recalculate extmin
   Application.Application.ZoomExtents
   
   ' Define Text String coordinates
   Dim dwgscale As Integer
   dwgscale = ThisDrawing.GetVariable("DIMSCALE")
   
   Dim h As Double
   h = 0.1 * dwgscale
   
   Dim minext As Variant
   minext = ThisDrawing.GetVariable("EXTMIN")

   Dim min(0 To 2) As Double
   min(0) = minext(0)
   min(1) = minext(1)
   min(2) = minext(2)

   Dim ip(0 To 2) As Double
   ip(0) = min(0)
   ip(1) = min(1) + negret(h * 1.3)
   ip(2) = 0
   
   ' Check for Text String at coordinates and delete - Option 1
   'Dim ipCross(0 To 2) As Double
   'ipCross(0) = ip(0) + h
   'ipCross(1) = ip(1) + h
   'ipCross(2) = 0
           
   'Dim ss As AcadSelectionSet
   'Dim Ent As AcadEntity
     
   'On Error Resume Next
   'Set ss = ThisDrawing.SelectionSets.Add("DEL")
   'Set ss = ThisDrawing.SelectionSets.Item("DEL")
   
   ' ss.Select acSelectionSetCrossing, ip, ipCross ' This doesn't work
   ' ss.SelectOnScreen ' This Works!
   
   'Dim FilterType(0 To 1) As Variant
   'Dim FilterData(0 To 1) As Variant
   'FilterType(0) = 0: FilterData(0) = "TEXT"
   'FilterType(1) = 8: FilterData(1) = "FILEPATHTEXT"
   'ss.Select acSelectionSetAll, , , FilterType, FilterData
           
   'Dim Ent As AcadEntity
   'Dim c As Integer
   'c = ss.Count
   'For c = 0 To ss.Count - 1
   '    Ent = ss.Item(c)
   '    Ent.Erase
   '
   'Next
   '
   'For Each Ent In ss
   '    Ent.Erase
   '
   'Next
   '
   'ss.Clear
   'ss.Delete
   'Set ss = Nothing
   
   ' Check for Text String at coordinates and delete - Option 2
   Dim objDataBase As AcadDatabase
   Dim objBlock As AcadBlock
   Dim Ent As AcadEntity
   Dim c As Integer
   Dim i As Integer
   Dim entCollection As Collection
   Dim varHandle As Variant
       
   Set entCollection = New Collection
   
   For Each objBlock In ThisDrawing.Blocks
       c = objBlock.Count
       For i = 0 To c - 1
           If TypeOf objBlock.Item(i) Is AcadEntity Then
               If objBlock.Item(i).Layer = "FILEPATHTEXT" Then
                   entCollection.Add (objBlock.Item(i).Handle)
           
               End If
       
           End If
           
       Next
               
       On Error Resume Next
       For Each varHandle In entCollection
           Set Ent = ThisDrawing.HandleToObject(CStr(varHandle))
           Ent.Delete
           
       Next
       
       On Error GoTo 0
       
   Next
       
   ' Regen after deletion
   ThisDrawing.SendCommand "ZOOM" & vbCr & "EXTENTS"
   ThisDrawing.Regen acActiveViewport
   
   ' Add Text String
   Dim dir As String
   dir = ThisDrawing.GetVariable("DWGPREFIX")

   Dim fil As String
   fil = ThisDrawing.GetVariable("DWGNAME")
       
   Dim objText2 As AcadText
   Dim textString As String
   textString = dir & fil
   Set objText2 = ThisDrawing.ModelSpace.AddText(textString, ip, h)

   ' Set layer back
   Dim layerObjOrig As AcadLayer
   Set layerObjOrig = ThisDrawing.Layers.Add(currLayer)
   ThisDrawing.ActiveLayer = layerObjOrig
   
   ' Set style back
   Dim styleObjOrig As AcadTextStyle
   Set styleObjOrig = ThisDrawing.TextStyles.Add(currStyle)
   ThisDrawing.ActiveTextStyle = styleObjOrig

End Sub

Function negret(ByVal n As Single) As Single
   If n > 0 Then
       negret = n - (n * 2)

   Else
       negret = n

   End If
 
End Function