沙漠骆驼工具箱源码-3快速选择

woxing1987

文本操作1，界面和代码如下：
1 界面：


2代码如下：






Dim layerobj As AcadLayer
Dim filtertype() As Integer '定义选择过滤器类型的dsf组码， 动态数组
Dim filterdata() As Variant '定义过滤器的值，为动态数组
Dim selectobjname As String '确定选择对象名称
Dim selectlayername As String '确定选择图层名称
Dim selectcolor As Integer    '确定选择颜色0-256
Dim selectblockname As String '确定选择块名称
Dim selectwidth As Double   '确定选择宽度
Dim syscolor As String    '系统变量 当前颜色值 0～256


Private Sub CheckBox1_Click()  '列出当前所有图层
    ComboBox1.Enabled = CheckBox1.value
    ComboBox1.Clear
    For Each layerobj In ThisDrawing.Layers
        ComboBox1.AddItem Trim(layerobj.name)
    Next
    ComboBox1.Text = ComboBox1.List(0)
    If CheckBox1.value = True Then selectlayername = "0"
End Sub


Private Sub CheckBox2_Click() '获取当前模型空间颜色 0-256 颜色索引值
    If CheckBox2.value = True Then
        syscolor = ThisDrawing.GetVariable("cecolor")
        ThisDrawing.SendCommand "color "
        Label1.Caption = ThisDrawing.GetVariable("cecolor")
        selectcolor = ThisDrawing.GetVariable("cecolor")
        If LCase(selectcolor) = "bylayer" Then selectcolor = 256
        If LCase(selectcolor) = "byblock" Then selectcolor = 0
    End If
End Sub


Private Sub CheckBox3_Click()   '列出当前所有图块名称 ，默认情况下0-2 是一个模型加两个布局
    ComboBox3.Enabled = CheckBox3.value
    ComboBox3.Clear
    Dim str As String
    Dim i As Integer, j As Integer
    For i = 0 To ThisDrawing.Blocks.count - 1
        str = Left(ThisDrawing.Blocks.Item(i).name, 1)
        If str = "*" Then j = j + 1
    Next
    For i = j To ThisDrawing.Blocks.count - 1
        ComboBox3.AddItem ThisDrawing.Blocks.Item(i).name
    Next
    If ComboBox3.ListCount > 0 Then
        ComboBox3.Text = ComboBox3.List(0)
        selectblockname = ComboBox3.List(0)
    Else
        selectblockname = ""
        CheckBox3.value = False
        ComboBox3.Enabled = False
    End If
End Sub


Private Sub CheckBox4_Click()
    ComboBox4.Enabled = CheckBox4.value
    If CheckBox4.value = True Then selectwidth = ComboBox4.Text
End Sub


Private Sub ComboBox1_Click()
    selectlayername = ComboBox1.Text
End Sub


Private Sub ComboBox3_Click()
    selectblockname = ComboBox3.Text
End Sub


Private Sub ComboBox4_Click()
    selectwidth = ComboBox4.Text
End Sub


Private Sub CommandButton1_Click()
    Me.Hide
    If selectobjname = "block" Then '选择块，排除多线，
        If CheckBox1.value = False And CheckBox2.value = False And CheckBox3.value = False Then
'            ReDim filtertype(4) '全关闭 选择所有块
'            ReDim filterdata(4)
'            filtertype(0) = 2
'            filterdata(0) = "*"
'            filtertype(1) = -4
'            filterdata(1) = "<not"
'            filtertype(2) = 0
'            filterdata(2) = "hatch"
'            filtertype(3) = 0
'            filterdata(3) = "mline"
'            filtertype(4) = -4
'            filterdata(4) = "not>"
            Call createssetfilter(filtertype, filterdata, 0, "insert")
        ElseIf CheckBox1.value = True And CheckBox2.value = True And CheckBox3.value = True Then
            ReDim filtertype(2)  '图层，颜色，块名 全打开
            ReDim filterdata(2)
            filtertype(0) = 2
            filterdata(0) = selectblockname
            filtertype(1) = 8
            filterdata(1) = selectlayername
            filtertype(2) = 62
            filterdata(2) = selectcolor
        ElseIf CheckBox1.value = True And CheckBox2.value = False And CheckBox3.value = False Then
'            ReDim filtertype(4)   '图层打开
'            ReDim filterdata(4)
'            filtertype(0) = 2
'            filterdata(0) = "*"
'            filtertype(1) = 8
'            filterdata(1) = selectlayername
'            filtertype(2) = -4
'            filterdata(2) = "<not"
'            filtertype(3) = 0
'            filterdata(3) = "hatch"
'            filtertype(4) = -4
'            filterdata(4) = "not>"
            Call createssetfilter(filtertype, filterdata, 0, "insert", 8, selectlayername)
        ElseIf CheckBox1.value = False And CheckBox2.value = True And CheckBox3.value = False Then
'            ReDim filtertype(4)      '颜色打开
'            ReDim filterdata(4)
'            filtertype(0) = 2
'            filterdata(0) = "*"
'            filtertype(1) = 62
'            filterdata(1) = selectcolor
'            filtertype(2) = -4
'            filterdata(2) = "<not"
'            filtertype(3) = 0
'            filterdata(3) = "hatch"
'            filtertype(4) = -4
'            filterdata(4) = "not>"
            Call createssetfilter(filtertype, filterdata, 0, "insert", 62, selectcolor)
        ElseIf CheckBox1.value = False And CheckBox2.value = False And CheckBox3.value = True Then
            ReDim filtertype(0)     '块名打开
            ReDim filterdata(0)
            filtertype(0) = 2
            filterdata(0) = selectblockname
        ElseIf CheckBox1.value = True And CheckBox2.value = True And CheckBox3.value = False Then
'            ReDim filtertype(5)     '图层打开，颜色打开
'            ReDim filterdata(5)
'            filtertype(0) = 2
'            filterdata(0) = "*"
'            filtertype(1) = 8
'            filterdata(1) = selectlayername
'            filtertype(2) = 62
'            filterdata(2) = selectcolor
'            filtertype(3) = -4
'            filterdata(3) = "<not"
'            filtertype(4) = 0
'            filterdata(4) = "hatch"
'            filtertype(5) = -4
'            filterdata(5) = "not>"
            Call createssetfilter(filtertype, filterdata, 0, "insert", 8, selectlayername, 62, selectcolor)
        ElseIf CheckBox1.value = True And CheckBox2.value = False And CheckBox3.value = True Then
            ReDim filtertype(1)    '图层打开，块名打开
            ReDim filterdata(1)
            filtertype(0) = 2
            filterdata(0) = selectblockname
            filtertype(1) = 8
            filterdata(1) = selectlayername
        ElseIf CheckBox1.value = False And CheckBox2.value = True And CheckBox3.value = True Then
            ReDim filtertype(1)    '颜色打开，块名打开
            ReDim filterdata(1)
            filtertype(0) = 2
            filterdata(0) = selectblockname
            filtertype(1) = 62
            filterdata(1) = selectcolor
        End If
    ElseIf selectobjname = "lwpolyline" Then   '选择多段线
        If CheckBox1.value = False And CheckBox2.value = False And CheckBox4.value = False Then
            ReDim filtertype(3) '全关闭 选择所有多段线ok
            ReDim filterdata(3)
            filtertype(0) = -4
            filterdata(0) = "<or"
            filtertype(1) = 0
            filterdata(1) = "lwpolyline"
            filtertype(2) = 0
            filterdata(2) = "POLYLINE"
            filtertype(3) = -4
            filterdata(3) = "or>"
        ElseIf CheckBox1.value = True And CheckBox2.value = True And CheckBox4.value = True Then
            ReDim filtertype(3)   '图层，颜色，宽度 全打开 ok
            ReDim filterdata(3)
            filtertype(0) = 0
            filterdata(0) = selectobjname
            filtertype(1) = 8
            filterdata(1) = selectlayername
            filtertype(2) = 62
            filterdata(2) = selectcolor
            filtertype(3) = 43
            filterdata(3) = selectwidth
        ElseIf CheckBox1.value = True And CheckBox2.value = False And CheckBox4.value = False Then
            ReDim filtertype(4)     '图层打开 ok
            ReDim filterdata(4)
            filtertype(0) = -4
            filterdata(0) = "<or"
            filtertype(1) = 0
            filterdata(1) = "lwpolyline"
            filtertype(2) = 0
            filterdata(2) = "POLYLINE"
            filtertype(3) = -4
            filterdata(3) = "or>"
            filtertype(4) = 8
            filterdata(4) = selectlayername
        ElseIf CheckBox1.value = False And CheckBox2.value = True And CheckBox4.value = False Then
            ReDim filtertype(4)      '颜色打开 ok
            ReDim filterdata(4)
            filtertype(0) = -4
            filterdata(0) = "<or"
            filtertype(1) = 0
            filterdata(1) = "lwpolyline"
            filtertype(2) = 0
            filterdata(2) = "POLYLINE"
            filtertype(3) = -4
            filterdata(3) = "or>"
            filtertype(4) = 62
            filterdata(4) = selectcolor
        ElseIf CheckBox1.value = False And CheckBox2.value = False And CheckBox4.value = True Then
            ReDim filtertype(1)       '宽度打开 ok
            ReDim filterdata(1)
            filtertype(0) = 0
            filterdata(0) = selectobjname
            filtertype(1) = 43
            filterdata(1) = selectwidth
        ElseIf CheckBox1.value = True And CheckBox2.value = True And CheckBox4.value = False Then
            ReDim filtertype(5)     '图层打开，颜色打开 ok
            ReDim filterdata(5)
            filtertype(0) = -4
            filterdata(0) = "<or"
            filtertype(1) = 0
            filterdata(1) = "lwpolyline"
            filtertype(2) = 0
            filterdata(2) = "POLYLINE"
            filtertype(3) = -4
            filterdata(3) = "or>"
            filtertype(4) = 8
            filterdata(4) = selectlayername
            filtertype(5) = 62
            filterdata(5) = selectcolor
        ElseIf CheckBox1.value = True And CheckBox2.value = False And CheckBox4.value = True Then
            ReDim filtertype(2)    '图层打开，宽度打开ok
            ReDim filterdata(2)
            filtertype(0) = 0
            filterdata(0) = selectobjname
            filtertype(1) = 8
            filterdata(1) = selectlayername
            filtertype(2) = 43
            filterdata(2) = selectwidth
        ElseIf CheckBox1.value = False And CheckBox2.value = True And CheckBox4.value = True Then
            ReDim filtertype(2)    '颜色打开，宽度打开ok
            ReDim filterdata(2)
            filtertype(0) = 0
            filterdata(0) = selectobjname
            filtertype(1) = 62
            filterdata(1) = selectcolor
            filtertype(2) = 43
            filterdata(2) = selectwidth
        End If
    Else       '选择text,mtext ,point ,circle,dimension,hatch
        If CheckBox1.value = False And CheckBox2.value = False Then
            ReDim filtertype(0) '图层，颜色全关闭 选择所有
            ReDim filterdata(0)
            filtertype(0) = 0
            filterdata(0) = selectobjname
        ElseIf CheckBox1.value = True And CheckBox2.value = True Then
            ReDim filtertype(2)   '图层，颜色 全打开
            ReDim filterdata(2)
            filtertype(0) = 0
            filterdata(0) = selectobjname
            filtertype(1) = 8
            filterdata(1) = selectlayername
            filtertype(2) = 62
            filterdata(2) = selectcolor
        ElseIf CheckBox1.value = True And CheckBox2.value = False Then
            ReDim filtertype(1)   '图层 打开
            ReDim filterdata(1)
            filtertype(0) = 0
            filterdata(0) = selectobjname
            filtertype(1) = 8
            filterdata(1) = selectlayername
        ElseIf CheckBox1.value = False And CheckBox2.value = True Then
            ReDim filtertype(1)   '颜色 打开
            ReDim filterdata(1)
            filtertype(0) = 0
            filterdata(0) = selectobjname
            filtertype(1) = 62
            filterdata(1) = selectcolor
        End If
    End If
    Call selectobjprograme(filtertype, filterdata)
    Erase filtertype
    Erase filterdata
    ThisDrawing.SetVariable "cecolor", syscolor
    Me.show
End Sub
Private Sub CommandButton2_Click()
    Me.Hide
End Sub
Private Sub Image1_Click()
    ThisDrawing.SendCommand "color "
    Image1.BackColor = cirobj.color
    Label1.Caption = ThisDrawing.GetVariable("cecolor")
End Sub




Private Sub CommandButton3_Click()
    MsgBox "时间：2011年11月19日    " & vbCr & _
           "名称：快速选择 V1.0    " & vbCr & _
           "by  ：沙漠骆驼    " & vbCr & _
           "qq  ：549738552    " & vbCr & vbCr & _
           "当前时间：" & Now, vbInformation, "快速选择--by沙漠骆驼"
End Sub


Private Sub Label1_Click()
    If CheckBox2.value = True Then
        ThisDrawing.SendCommand "color "
        Label1.Caption = ThisDrawing.GetVariable("cecolor")
        selectcolor = ThisDrawing.GetVariable("cecolor")
        If LCase(selectcolor) = "bylayer" Then selectcolor = "256"
        If LCase(selectcolor) = "byblock" Then selectcolor = "0"
    End If
End Sub


Private Sub OptionButton1_Click()
    CheckBox3.Enabled = False
    CheckBox3.value = False
    CheckBox4.Enabled = False
    CheckBox4.value = False
    selectobjname = "text"
End Sub


Private Sub OptionButton2_Click()
    CheckBox3.Enabled = False
    CheckBox3.value = False
    CheckBox4.Enabled = False
    CheckBox4.value = False
    selectobjname = "mtext"
End Sub


Private Sub OptionButton3_Click()
    CheckBox3.Enabled = False
    CheckBox3.value = False
    CheckBox4.Enabled = False
    CheckBox4.value = False
    selectobjname = "circle"
End Sub


Private Sub OptionButton4_Click()
    CheckBox3.Enabled = False
    CheckBox3.value = False
    CheckBox4.Enabled = False
    CheckBox4.value = False
    selectobjname = "point"
End Sub


Private Sub OptionButton5_Click()
    CheckBox3.Enabled = False
    CheckBox3.value = False
    CheckBox4.Enabled = True
    selectobjname = "lwpolyline"
End Sub


Private Sub OptionButton6_Click()
    CheckBox3.Enabled = False
    CheckBox3.value = False
    CheckBox4.Enabled = False
    CheckBox4.value = False
    selectobjname = "dimension"
End Sub


Private Sub OptionButton7_Click()
    CheckBox3.Enabled = True
    CheckBox4.Enabled = False
    CheckBox4.value = False
    selectobjname = "block"
End Sub


Private Sub OptionButton8_Click()
    CheckBox3.Enabled = False
    CheckBox3.value = False
    CheckBox4.Enabled = False
    CheckBox4.value = False
    selectobjname = "hatch"
End Sub


Private Sub UserForm_Initialize()
    '初始化 当前图层 当前颜色 多段线宽度
    'On Error Resume Next
    ComboBox1.Text = ThisDrawing.Layers.Item(0).name
    Dim i As Integer
    For i = 0 To 39
        ComboBox4.AddItem Format((i + 1) * 0.05, "0.00"), i
    Next
    ComboBox4.AddItem Format(2.5, "0.00")
    ComboBox4.AddItem Format(3, "0.00")
    ComboBox4.Text = ComboBox4.List(2)
   
    Label1.Caption = ThisDrawing.GetVariable("cecolor")
    selectobjname = "text"
    syscolor = "256"
End Sub


'条件选择过滤器函数,以夹点方式显示选择集
Private Sub selectobjprograme(filtertype() As Integer, filterdata() As Variant)
    Dim sset1 As AcadSelectionSet
    Dim element As AcadEntity
    On Error Resume Next
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请选择对象:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        ThisDrawing.Utility.prompt "-------请重新选择过滤条件进行选择-------" & vbCrLf
        Exit Sub
    End If
    ThisDrawing.SetVariable "nomutt", 1
    With ThisDrawing
        .SendCommand "(setq ss1 (ssget ""p""))" '命令行(setq ss1 (ssget "p"))
        .SendCommand "(sssetfirst nil ss1)" & vbCr
        .Utility.prompt "正在选择......" & vbCrLf
    End With
    ThisDrawing.SetVariable "NOMUTT", 0
    ThisDrawing.Utility.prompt "-------选择成功-------by沙漠骆驼-------" & vbCrLf
    ThisDrawing.Utility.prompt "一共选择了  " & sset1.count & "  个对象。" & vbCrLf
    sset1.Clear
    sset1.Delete
End Sub

vladimirputin

如果能有lisp代码那就好了。谢谢楼主分享啊。

jxy308

怎么没人支持这么好的源码

ZJKUSO

可以同时选择多个图层吗？

语过添晴

看不懂，先留个脚印

tiancao100

支持一下VBA

hhh454

感谢分享代码，学习了，一直用lisp，对这个不是太了解