以下程式无法颜色过滤

yuangw1234

问题如下：

假如一条线的颜色是红色，另一条是绿色，颜色不用ByLayer,程式有过滤作用;可是当都是ByLayer刚失效，用此程式失效的结果是两条线都被选择，请问如何解决，本以为将obj.color改成obj.Truecolor，结果不对

Public Sub Ys()
On Error Resume Next
Dim Ssetobj As AcadSelectionSet, Str As Integer, Obj As AcadEntity, Pt As Variant
ThisDrawing.Utility.GetEntity Obj, Pt: Obj.Highlight True
Str = Obj.color
ThisDrawing.SelectionSets("ys").Delete
Err.Clear
Set Ssetobj = ThisDrawing.SelectionSets.Add("ys")
Dim Ftype(1) As Integer, Fdata(1) As Variant
Ftype(0) = 0
Fdata(0) = "*"
Ftype(1) = 62
Fdata(1) = Str
Ssetobj.SelectOnScreen Ftype, Fdata
End Sub

fjfhgdwfn

如果bylayer 哪就再判断下层的颜色吧

yuangw1234

請問一下，下層的顏色是什麼意思？能不能用VBA關鍵字提示一下

fjfhgdwfn

判断下层的颜色

先得到object.layer,

再判断

layer.color

yuangw1234

先謝謝，我去試試

yuangw1234

試了一下，好象不行，大師可不可以在我的程式上修改一下，就如選擇的參考物體的顏色是綠色，那麼我就只要過濾綠色的物體，不管Bylayer是綠色，還是實際是綠色

雪山飞狐_lzh

引用我的增强选择集类（在我的博客里找：）），运行下面的程序

Sub ttx()
    Dim ss As New TlsSelectSet
    ss.Init
    ss.Filter.SetData -4, "<or", 62, acRed
    For Each i In ThisDrawing.Layers
        If i.Color = acRed Then
            ss.Filter.AppendData -4, "<and", 8, i.Name, 62, acByLayer, -4, "and>"
        End If
    Next i
    ss.Filter.AppendData -4, "or>"
    ss.SelectObject acSelectionSetAll
    MsgBox ss.Count
End Sub

或者

Sub ttx()
    Dim ss As New TlsSelectSet
    ss.Init
    For Each i In ThisDrawing.Layers
        If i.Color = acRed Then
            s = s & i.Name & ","
        End If
    Next i
    s = Left(s, Len(s) - 1)
    ss.Filter.SetData -4, "<or", 62, acRed, -4, "<and", 8, s, 62, acByLayer, -4, "and>", -4, "or>"
    ss.SelectObject acSelectionSetAll
    MsgBox ss.Count
End Sub

yuangw1234

请问一下版主，你的那个New TlsSelectSet 是自定义的变量，它是acadselectionset还是什么呢？能不能把那个自定义的变量也发上来，因为我用你的程式，发现也找不到 Init这个属性

雪山飞狐_lzh

不是让你在我的博客上找了么：）

还是贴过来吧：）

下面的代码放在TlsSelectSet类模块中

http://xsfhlzh.139.com/article/325507.html

下面的模块放在TlsResultBuffer类模块中

http://xsfhlzh.139.com/article/332841.html

yuangw1234

先謝謝版主