随便写的有关图层代码

王咣生 · 发表于 2004-12-7 09:20:00

ublic g_LayerInfoArray() As LayerInfoObj

'-----------------------------------------------------------------------------

Type LayerInfoObj layerObj As AcadLayer layerName As String isOn As Boolean isLock As Boolean isFreeze As Boolean End Type

'----保存所有图层状态-------------------------------------------------------------------------

Public Sub GetLayerInfoArray() On Error GoTo ErrorHandler ReDim g_LayerInfoArray(0) Dim lay As AcadLayer Dim lays As AcadLayers Set lays = ThisDrawing.Layers Dim i As Integer For i = 0 To lays.count - 1 Set lay = lays.Item(i) ReDim Preserve g_LayerInfoArray(UBound(g_LayerInfoArray) + 1) With g_LayerInfoArray(UBound(g_LayerInfoArray)) Set .layerObj = lay .layerName = lay.name .isOn = lay.LayerOn .isLock = lay.Lock .isFreeze = lay.Freeze End With Next Exit Sub ErrorHandler: Debug.Print "Sub GetLayerInfoArray() occurs errors: " + Err.Description End Sub

'----恢复所有图层状态-----------------------------------------------------

Public Sub SetLayerInfoArray() On Error GoTo ErrorHandler Dim i As Integer Dim lay As AcadLayer For i = 1 To UBound(g_LayerInfoArray) Set lay = g_LayerInfoArray(i).layerObj If LayerExist(lay.name) Then With lay .LayerOn = g_LayerInfoArray(i).isOn .Lock = g_LayerInfoArray(i).isLock If IsCurrentLayer(lay.name) = False Then .Freeze = g_LayerInfoArray(i).isFreeze End If End With End If Next Exit Sub ErrorHandler: Debug.Print "Sub SetLayerInfoArray() occurs errors: " + Err.Description End Sub

Public Sub ClearLayerInfoArray() ReDim g_LayerInfoArray(0) End Sub

'----------------------------------------------------------------------------- '-----------------------------------------------------------------------------

Public Function LayerExist(ByVal layerName As String) As Boolean On Error GoTo ErrorHandler LayerExist = False Dim layerObj As AcadLayer Set layerObj = ThisDrawing.Layers.Item(layerName) LayerExist = True Exit Function ErrorHandler: End Function

Public Function IsCurrentLayer(ByVal layerName As String) As Boolean Dim sysVarName As String Dim varData As Variant sysVarName = "CLAYER" varData = ThisDrawing.GetVariable(sysVarName) If StrComp(UCase$(varData), UCase(layerName)) = 0 Then IsCurrentLayer = True Else IsCurrentLayer = False End If End Function

Public Sub CloseAllLayers() On Error GoTo ErrorHandler Dim layerObj As AcadLayer Dim layersObj As AcadLayers Set layersObj = ThisDrawing.Layers Dim i As Integer For i = 0 To layersObj.count - 1 Set layerObj = layersObj.Item(i) layerObj.LayerOn = False Next Exit Sub ErrorHandler: End Sub

Public Sub OpenLayer(ByVal layerName As String, ByVal bOnOff As Boolean) On Error GoTo ErrorHandler If LayerExist(layerName) Then Dim layerObj As AcadLayer Set layerObj = ThisDrawing.Layers.Item(layName) layerObj.LayerOn = bOnOff End If Exit Sub ErrorHandler: End Sub

Public Sub LockLayer(ByVal layerName As String, ByVal bLock As Boolean) On Error GoTo ErrorHandler If LayerExist(layerName) Then Dim layerObj As AcadLayer Set layerObj = ThisDrawing.Layers.Item(layName) layerObj.Lock = bLock End If Exit Sub ErrorHandler: End Sub

Public Sub FreezeLayer(ByVal layerName As String, ByVal bFreeze As Boolean) On Error GoTo ErrorHandler If LayerExist(layerName) Then Dim layerObj As AcadLayer Set layerObj = ThisDrawing.Layers.Item(layName) layerObj.Lock = bFreeze End If Exit Sub ErrorHandler: End Sub

Public Sub SetClayer(ByVal layerName As String) If IsCurrentLayer(layerName) = False And LayerExist(layerName) Then Dim sysVarName As String Dim sysVarData As Variant sysVarName = "CLAYER" sysVarData = layerName ThisDrawing.SetVariable sysVarName, sysVarData End If End Sub

cadfqd · 发表于 2004-12-7 19:22:00

干啥用的?

王咣生 · 发表于 2004-12-7 22:38:00

在处理数据前保存和恢复图层状态, 以及图层是否存在等等.

mccad · 发表于 2004-12-8 21:51:00

保存和恢复图层状态，本身CAD已经提供了对象来处理,而且也可以通过程序控制：
LayerStateManager 保存和恢复使用图层属性管理器设置的图层。

王咣生 · 发表于 2004-12-8 23:13:00

谢谢mccad,知道了LayerStateManager

账号		自动登录	找回密码
密码			注册

随便写的有关图层代码

回复

回复