[CASS二次开发源代码]VB6+AutoCAD---图层控制

时间：2019-10-30 15:34 作者：AcadApp 阅读：1645 评论：1

Windows10

其他

CASS9

Public Sub ILayerOn(ByVal AcadApp As Object) '图层全开
  Dim objLyr As Object
  For Each objLyr In AcadApp.Application.ActiveDocument.Layers
      objLyr.LayerOn = True
  Next
End Sub
Public Sub ILayerOff(ByVal AcadApp As Object) '图层选关
  Dim objLyr As Object, objEnt As Object, sSet As Object
  For Each sSet In AcadApp.Application.ActiveDocument.SelectionSets
      If sSet.Name = "ILayerOff" Then sSet.Delete: Exit For
  Next
  Set sSet = AcadApp.Application.ActiveDocument.SelectionSets.Add("ILayerOff")
  sSet.SelectOnScreen
  If sSet.Count > 0 Then
     For Each objEnt In sSet
         For Each objLyr In AcadApp.Application.ActiveDocument.Layers
             If objLyr.Name = objEnt.Layer Then
                objLyr.LayerOn = False
             End If
         Next
     Next
  End If
  sSet.Delete
End Sub
Public Sub ILayerOffExcept(ByVal AcadApp As Object) '图层指定外关闭
  Dim objLyr As Object, objEnt As Object, sSet As Object
  For Each sSet In AcadApp.Application.ActiveDocument.SelectionSets
      If sSet.Name = "ILayerOffExcept" Then sSet.Delete: Exit For
  Next
  Set sSet = AcadApp.Application.ActiveDocument.SelectionSets.Add("ILayerOffExcept")
  sSet.SelectOnScreen
  If sSet.Count > 0 Then
     For Each objEnt In sSet
         For Each objLyr In AcadApp.Application.ActiveDocument.Layers
             If objLyr.Name <> objEnt.Layer Then
                objLyr.LayerOn = False
             End If
         Next
     Next
  End If
  sSet.Delete
End Sub
Public Sub ILayerLock(ByVal AcadApp As Object) '图层锁定
  Dim objLyr As Object, objEnt As Object, sSet As Object
  For Each sSet In AcadApp.Application.ActiveDocument.SelectionSets
      If sSet.Name = "ILayerLock" Then sSet.Delete: Exit For
  Next
  Set sSet = AcadApp.Application.ActiveDocument.SelectionSets.Add("ILayerLock")
  sSet.SelectOnScreen
  If sSet.Count > 0 Then
     For Each objEnt In sSet
         For Each objLyr In AcadApp.Application.ActiveDocument.Layers
             If objLyr.Name = objEnt.Layer Then
                objLyr.Lock = True
             End If
         Next
     Next
  End If
  sSet.Delete
End Sub
Public Sub ILayerUnlock(ByVal AcadApp As Object) '图层开锁
  Dim objLyr As Object
  For Each objLyr In AcadApp.Application.ActiveDocument.Layers
      objLyr.Lock = False
  Next
End Sub
Public Sub ILayerFreeze(ByVal AcadApp As Object)    '图层冻结
  Dim objEnt As Object, objLyr As Object, pnt As Variant, sSet As Object
  For Each sSet In AcadApp.Application.ActiveDocument.SelectionSets
      If sSet.Name = "ILayerFreeze" Then sSet.Delete: Exit For
  Next
  Set sSet = AcadApp.Application.ActiveDocument.SelectionSets.Add("ILayerFreeze")
  sSet.SelectOnScreen
  If sSet.Count > 0 Then
     For Each objEnt In sSet
         For Each objLyr In AcadApp.Application.ActiveDocument.Layers
             If objLyr.Name = objEnt.Layer Then
                If AcadApp.Application.ActiveDocument.ActiveLayer.Name <> objLyr.Name Then
                   objLyr.Freeze = True
                End If
             End If
         Next
     Next
  End If
  sSet.Delete
End Sub
Public Sub ILayerUnfreeze(ByVal AcadApp As Object)     '图层解冻
  Dim objLyr As Object
  For Each objLyr In AcadApp.Application.ActiveDocument.Layers
      If objLyr.Freeze = True Then objLyr.Freeze = False
  Next
  AcadApp.Application.ActiveDocument.Regen acActiveViewport
End Sub
Public Sub ILayerCur(ByVal AcadApp As Object)   '图层当前
  Dim objEnt As Object, objLyr As Object, pnt As Variant
  On Error Resume Next
  AcadApp.Application.ActiveDocument.Utility.GetEntity objEnt, pnt, vbCr & vbCr & "选择对象:"
  If Err Then Err.Clear: Exit Sub
  Set objLyr = AcadApp.Application.ActiveDocument.Layers(objEnt.Layer)
  AcadApp.Application.ActiveDocument.ActiveLayer = objLyr
End Sub

全部评论

等级:LV30

积分:74546

hkai2658 2019-12-11 08:35

没有看懂

1