[编程交流] 无法使用selec删除文本

 ss.Select acSelectionSetCrossing, ip, ipCross

    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

    ' 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

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