woxing1987 发表于 2022-2-9 15:14:12

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

工具条：图层操作：界面和代码如下
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 发表于 2022-2-9 17:33:23

支持使用vb的兄弟

woxing1987 发表于 2022-2-10 14:34:45

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

希望对大家有一些帮助

来武影 发表于 2022-3-11 11:44:48

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

cherisan 发表于 2022-5-8 00:43:16

谢谢楼主分享！

willing0 发表于 2022-6-7 18:12:21

感谢楼主的大公无私
页: [1]
查看完整版本: 沙漠骆驼工具箱源码-2图层操作