沙漠骆驼工具箱源码-2图层操作

woxing1987

工具条：图层操作：界面和代码如下
1界面：


2 代码如下



Private Sub closelayerssub()  '关闭对象所在的图层1
    Dim s1 As AcadSelectionSet
    Dim element As AcadEntity
    On Error Resume Next
    Set s1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then '如果选择集存在
        Err.Clear
        Set s1 = ThisDrawing.SelectionSets.Item("ss1")
        s1.Clear                '清空选择集
    End If
    s1.SelectOnScreen
    If s1.count = 0 Then Exit Sub
    For Each element In s1     '遍历选择集
        ThisDrawing.Layers.Item(element.Layer).LayerOn = False
    Next

    'ThisDrawing.Regen acActiveViewport
End Sub


Private Sub uncloselayerssub() '反向打开关闭图层  2
    Dim count As Integer, i As Integer
    count = ThisDrawing.Layers.count
    'MsgBox count & "  " & ThisDrawing.Layers.Item(3).Name
    For i = 0 To count - 1
        If ThisDrawing.Layers.Item(i).LayerOn = True Then
            ThisDrawing.Layers.Item(i).LayerOn = False
        Else
            ThisDrawing.Layers.Item(i).LayerOn = True
        End If
    Next
    ThisDrawing.Regen acActiveViewport
End Sub

Private Sub locklayerssub() '锁定对象所在的图层  3
    Dim s1 As AcadSelectionSet
    Dim element As AcadEntity
    On Error Resume Next
    Set s1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then '如果选择集存在
        Err.Clear
        Set s1 = ThisDrawing.SelectionSets.Item("ss1")
        s1.Clear                '清空选择集
    End If
    s1.SelectOnScreen
    If s1.count = 0 Then Exit Sub
    For Each element In s1     '遍历选择集
        ThisDrawing.Layers.Item(element.Layer).Lock = True
    Next
    'ThisDrawing.Regen acActiveViewport
End Sub


Private Sub clearlocklayerssub() '解锁对象所在的图层 4
    Dim s1 As AcadSelectionSet
    Dim element As AcadEntity
    On Error Resume Next
    Set s1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then '如果选择集存在
        Err.Clear
        Set s1 = ThisDrawing.SelectionSets.Item("ss1")
        s1.Clear                '清空选择集
    End If
    s1.SelectOnScreen
    If s1.count = 0 Then Exit Sub
    For Each element In s1     '遍历选择集
        ThisDrawing.Layers.Item(element.Layer).Lock = False
    Next
    'ThisDrawing.Regen acActiveViewport
End Sub


Private Sub openalllayerssub() '打开所有图层 5
    Dim count As Integer, i As Integer
    count = ThisDrawing.Layers.count
    For i = 0 To count - 1
        ThisDrawing.Layers.Item(i).LayerOn = True
    Next
    'ThisDrawing.Regen acActiveViewport
End Sub

Private Sub closealllayerssub() '关闭所有图层 6
    Dim count As Integer, i As Integer
    count = ThisDrawing.Layers.count
    For i = 0 To count - 1
        ThisDrawing.Layers.Item(i).LayerOn = False
    Next
    'ThisDrawing.Regen acActiveViewport
End Sub

Private Sub freezealllayerssub() '冻结所有图层 7
    Dim count As Integer, i As Integer
    count = ThisDrawing.Layers.count
    On Error Resume Next
    For i = 0 To count - 1
        ThisDrawing.Layers.Item(i).Freeze = True
    Next
    'ThisDrawing.Regen acActiveViewport
End Sub

Private Sub unfreezealllayerssub() '解冻所有图层 8
    Dim count As Integer, i As Integer
    count = ThisDrawing.Layers.count
    On Error Resume Next
    For i = 0 To count - 1
        ThisDrawing.Layers.Item(i).Freeze = False
    Next
    ThisDrawing.SendCommand "REGEN" & vbCr
    'ThisDrawing.Regen acActiveViewport
End Sub

Private Sub lockalllayerssub() '锁定所有图层 9
    Dim count As Integer, i As Integer
    count = ThisDrawing.Layers.count
    For i = 0 To count - 1
        ThisDrawing.Layers.Item(i).Lock = True
    Next
    'ThisDrawing.Regen acActiveViewport
End Sub


Private Sub unlockalllayerssub() '解锁所有图层 10
    Dim count As Integer, i As Integer
    count = ThisDrawing.Layers.count
    For i = 0 To count - 1
        ThisDrawing.Layers.Item(i).Lock = False
    Next
    'ThisDrawing.Regen acActiveViewport
End Sub


Private Sub unlocklayerssub() '反向锁定图层  11
    Dim count As Integer, i As Integer
    count = ThisDrawing.Layers.count
    For i = 0 To count - 1
        If ThisDrawing.Layers.Item(i).Lock = True Then
            ThisDrawing.Layers.Item(i).Lock = False
        Else
            ThisDrawing.Layers.Item(i).Lock = True
        End If
    Next
    'ThisDrawing.Regen acActiveViewport
End Sub


Private Sub closelocklayerssub() '关闭锁定的图层  12
    Dim count As Integer, i As Integer
    count = ThisDrawing.Layers.count
    For i = 0 To count - 1
        If ThisDrawing.Layers.Item(i).Lock = True Then
            ThisDrawing.Layers.Item(i).LayerOn = False
        End If
    Next
    'ThisDrawing.Regen acActiveViewport
End Sub


Private Sub closeotherlayerssub()  '关闭选取对象以外的图层  13
    Dim s1 As AcadSelectionSet
    Dim element As AcadEntity
    Dim count As Integer, i As Integer
    count = ThisDrawing.Layers.count
    On Error Resume Next
    Set s1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then '如果选择集存在
        Err.Clear
        Set s1 = ThisDrawing.SelectionSets.Item("ss1")
        s1.Clear                '清空选择集
    End If
    s1.SelectOnScreen
    If s1.count = 0 Then Exit Sub
    For i = 0 To count - 1
        ThisDrawing.Layers.Item(i).LayerOn = False
    Next
    For Each element In s1     '遍历选择集
        ThisDrawing.Layers.Item(element.Layer).LayerOn = True
    Next
    'ThisDrawing.Regen acActiveViewport
End Sub

Private Sub freezelayerssub() '冻结选取图层  14
    Dim s1 As AcadSelectionSet
    Dim element As AcadEntity
    On Error Resume Next
    Set s1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then '如果选择集存在
        Err.Clear
        Set s1 = ThisDrawing.SelectionSets.Item("ss1")
        s1.Clear                '清空选择集
    End If
    s1.SelectOnScreen
    If s1.count = 0 Then Exit Sub
    For Each element In s1     '遍历选择集
        ThisDrawing.Layers.Item(element.Layer).Freeze = True
    Next
    'ThisDrawing.Regen acActiveViewport
End Sub


Private Sub Freezeotherlayerssub()  '冻结选取外图层  15
    Dim s1 As AcadSelectionSet
    Dim element As AcadEntity
    Dim count As Integer, i As Integer
    count = ThisDrawing.Layers.count
    On Error Resume Next
    Set s1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then '如果选择集存在
        Err.Clear
        Set s1 = ThisDrawing.SelectionSets.Item("ss1")
        s1.Clear                '清空选择集
    End If
    s1.SelectOnScreen
    If s1.count = 0 Then Exit Sub
    For i = 0 To count - 1
        ThisDrawing.Layers.Item(i).Freeze = True
    Next
    For Each element In s1     '遍历选择集
        ThisDrawing.Layers.Item(element.Layer).Freeze = False
    Next
    'ThisDrawing.Regen acActiveViewport
End Sub


Private Sub alllayersopensub()  '打开全部图层 16
    Dim count As Integer, i As Integer
    count = ThisDrawing.Layers.count
    On Error Resume Next
    For i = 0 To count - 1
        With ThisDrawing.Layers.Item(i)
            .LayerOn = True
            .Lock = False
            .Freeze = False
        End With
    Next
    ThisDrawing.Regen acActiveViewport
End Sub

Private Sub unFreezelayerssub() '反向冻结图层  17
    Dim count As Integer, i As Integer
    count = ThisDrawing.Layers.count
    On Error Resume Next
    For i = 0 To count - 1
        If ThisDrawing.Layers.Item(i).Freeze = True Then
            ThisDrawing.Layers.Item(i).Freeze = False
        Else
            ThisDrawing.Layers.Item(i).Freeze = True
        End If
    Next
    ThisDrawing.SendCommand "REGEN" & vbCr
    'ThisDrawing.Regen acActiveViewport
End Sub

Private Sub CommandButton1_Click()
    tuceng.Hide
    Call closelayerssub
    tuceng.show
End Sub

Private Sub CommandButton10_Click()
    tuceng.Hide
    Call Freezeotherlayerssub
    tuceng.show
End Sub

Private Sub CommandButton11_Click()
    Call unFreezelayerssub
End Sub

Private Sub CommandButton12_Click()
    Call unfreezealllayerssub
End Sub

Private Sub CommandButton13_Click()
    Call alllayersopensub
End Sub

Private Sub CommandButton14_Click()
    Dim element As AcadEntity
    Dim basepnt As Variant
    On Error Resume Next
    ThisDrawing.Utility.GetEntity element, basepnt, "请拾取对象以获取图层名称:"
    'MsgBox element.Layer
    If Err Then
        Err.Clear
        Me.show
    End If
    ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(element.Layer)
End Sub

Private Sub CommandButton15_Click() '冻结隐藏图层
    Dim count As Integer, i As Integer
    count = ThisDrawing.Layers.count
    On Error Resume Next
    For i = 0 To count - 1
        If ThisDrawing.Layers.Item(i).LayerOn = False Then ThisDrawing.Layers.Item(i).Freeze = True
    Next
End Sub

Private Sub CommandButton16_Click() '锁定隐藏图层
    Dim count As Integer, i As Integer
    count = ThisDrawing.Layers.count
    On Error Resume Next
    For i = 0 To count - 1
        If ThisDrawing.Layers.Item(i).LayerOn = False Then ThisDrawing.Layers.Item(i).Lock = True
    Next
End Sub

Private Sub CommandButton2_Click()
    tuceng.Hide
    Call closeotherlayerssub
    tuceng.show
End Sub
Private Sub CommandButton3_Click()
    Call uncloselayerssub
End Sub

Private Sub CommandButton4_Click()
    Call openalllayerssub
End Sub

Private Sub CommandButton5_Click()
    tuceng.Hide
    Call locklayerssub
    tuceng.show
End Sub

Private Sub CommandButton6_Click()
    tuceng.Hide
    Call clearlocklayerssub
    tuceng.show
End Sub

Private Sub CommandButton7_Click()
    Call unlocklayerssub
End Sub

Private Sub CommandButton8_Click()
    Call unlockalllayerssub
End Sub

Private Sub CommandButton9_Click()
    tuceng.Hide
    Call freezelayerssub
    tuceng.show
End Sub

tiancao100

支持使用vb的兄弟

woxing1987

tiancao100 发表于 2022-2-9 17:33
支持使用vb的兄弟

希望对大家有一些帮助

来武影

同行啊，而且还是水利地质口的

cherisan

谢谢楼主分享！

willing0

感谢楼主的大公无私