无法使用selec删除文本
我快疯了。。。这是可行的，但我不想在屏幕上选择。。。
ss.SelectOnScreen
我试图选择两个坐标的交叉点，但没有成功。。。
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
提前谢谢。 你好
只要看看代码的逻辑。您是否对正在过滤的对象始终位于计算点ip和ip之间感到满意？
negret函数做什么？
当做
杰米 这应该是一个十字路口。无论如何，我否决了那一条。现在，如果我能把所有的文字放在一个图层上，我会很高兴，但这也不行。 我自己无法测试，但如果你改变会发生什么：
Dim FilterType（0到1）作为变体
收件人：
Dim FilterType（0到1）为整数 此外，这看起来有点可疑：
FilterType（0）=0:FilterData（0）=“” Int，variant，没有区别。另一行实际上是这样写的。
FilterType（0）=0:FilterData（0）=“TEXT” negret返回负#。因此，3=-3和-3=-3。 好吧，我想出来了。这是代码。不过，很高兴看到选择集可以工作。
我唯一的进退维谷是让最大化工作。在下面的完整列表中，我有以下内容：
' Regen after deletion
ThisDrawing.SendCommand "ZOOM" & vbCr & "EXTENTS"
ThisDrawing.Regen acActiveViewport
regen的目的是在删除左下角的文本后重新Blish EXTMIN变量。如果我删除它并手动重新生成，程序运行得很好。然而，当按如上所示编程完成时，它会不断添加到EXTMIN，使文本每次都以较低的delta-Y插入。
再次感谢。。。
完整列表：
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
页:
[1]