全部转换为按图层乐筑天下 - Powered by Discuz! Archiver

nivuahc 发表于 2006-2-1 10:22:04

全部转换为按图层

**** Hidden Message *****

nivuahc 发表于 2006-2-1 10:27:32

这应该很容易做到。你有什么样的时间框架？

nivuahc 发表于 2006-2-1 10:28:28

所以我想你想解锁所有层。
删除所有图层FROZEN和/或OFF。
创建您需要的图层（E-BASE PLAN）。
将颜色设置为您保留的图层。
对于mspace中的每个对象，获取图层，获取图层的线型，将线型设置为对象。
将每个对象放在E-BASE PLAN。

ronjonp 发表于 2006-2-1 10:49:46

如果，你说的时间框架是指“你有多少时间可以花在这件事上？...
不多。我现在埋在一堆图纸下，看不到真正的结局。
如果，按时间框架，你男人“你在寻找解决方案的速度有多快？...
没有时间框架。我没有压力去做这个，这只会让我现在做的很多事情变得更容易，从而释放我的一些时间。
我愿意学习，尽管在VBA方面我不能保证出色的结果（我以前尝试过，但总是被拉向另一个方向，所以很快就忘记了我学到了什么）。
我正在查看您上面发布的代码，并试图理解它。一旦我完成，我会在这里发帖，告诉你
我认为它
的作用。这应该让你了解我与VBA
的立场

nivuahc 发表于 2006-2-1 10:52:48

太棒了！！！你能做到的！我也为你准备了下一部分
Option Explicit
Public Sub FIXLAYERS()
Call DELETELAYERS
Call SETUPLAYERS
Call SETCOLORLINETYPE
Call CHANGELAYER
End Sub
Private Sub DELETELAYERS()
Dim objLayer As AcadLayer
Dim objSelected As Object
Dim OBJSELSET As AcadSelectionSet
Dim n As Integer
ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")
For Each objLayer In ThisDrawing.Layers
   If objLayer.Name = "0" Then
         objLayer.Lock = False
         objLayer.LayerOn = True
         'objLayer.Freeze = False
   Else
         objLayer.Lock = False
   End If
Next
ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")
ThisDrawing.Application.Update
ThisDrawing.Regen acAllViewports
For Each objLayer In ThisDrawing.Layers
   If objLayer.LayerOn = False Then
         If ThisDrawing.SelectionSets.Count > 0 Then
            For n = 0 To ThisDrawing.SelectionSets.Count - 1
               If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then
                     ThisDrawing.SelectionSets("layerdelete").Delete
               End If
            Next n
         End If
         Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")
         OBJSELSET.Select acSelectionSetAll
         For Each objSelected In OBJSELSET
            If objSelected.Layer = objLayer.Name Then
               objSelected.Delete
            End If
         Next
         objLayer.Delete
   End If
Next

For Each objLayer In ThisDrawing.Layers
   If objLayer.Freeze = True Then
         If ThisDrawing.SelectionSets.Count > 0 Then
            For n = 0 To ThisDrawing.SelectionSets.Count - 1
               If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then
                     ThisDrawing.SelectionSets("layerdelete").Delete
               End If
            Next n
         End If
         Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")
         OBJSELSET.Select acSelectionSetAll
         For Each objSelected In OBJSELSET
            If objSelected.Layer = objLayer.Name Then
               objSelected.Delete
            End If
         Next
         objLayer.Delete
   End If
Next
End Sub
Private Sub SETUPLAYERS()
Dim objLay As AcadLayer
Set objLay = ThisDrawing.Layers.Add("E-BASE-PLAN")
objLay.color = 252
End Sub
Private Sub SETCOLORLINETYPE()
Dim objLayer As AcadLayer
Dim objSelected As Object
Dim OBJSELSET As AcadSelectionSet
Dim n As Integer
If ThisDrawing.SelectionSets.Count > 0 Then
   For n = 0 To ThisDrawing.SelectionSets.Count - 1
         If ThisDrawing.SelectionSets.Item(n).Name = "changecolorline" Then
            ThisDrawing.SelectionSets("changecolorline").Delete
         End If
   Next n
End If
Set OBJSELSET = ThisDrawing.SelectionSets.Add("changecolorline")
OBJSELSET.Select acSelectionSetAll
'this is where we are at so far
End Sub
Private Sub CHANGELAYER()
MsgBox "CHANGE LAYER"
End Sub

nivuahc 发表于 2006-2-1 10:55:31

这主要是你想要的地方
Option Explicit
Public Sub FIXLAYERS()
Call DELETELAYERS
Call SETUPLAYERS
Call SETCOLORLINETYPE
Call CHANGELAYER
End Sub
Private Sub DELETELAYERS()
Dim objLayer As AcadLayer
Dim objSelected As Object
Dim OBJSELSET As AcadSelectionSet
Dim n As Integer
ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")
For Each objLayer In ThisDrawing.Layers
   If objLayer.Name = "0" Then
         objLayer.Lock = False
         objLayer.LayerOn = True
         'objLayer.Freeze = False
   Else
         objLayer.Lock = False
   End If
Next
ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")
ThisDrawing.Application.Update
ThisDrawing.Regen acAllViewports
For Each objLayer In ThisDrawing.Layers
   If objLayer.LayerOn = False Then
         If ThisDrawing.SelectionSets.Count > 0 Then
            For n = 0 To ThisDrawing.SelectionSets.Count - 1
               If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then
                     ThisDrawing.SelectionSets("layerdelete").Delete
               End If
            Next n
         End If
         Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")
         OBJSELSET.Select acSelectionSetAll
         For Each objSelected In OBJSELSET
            If objSelected.Layer = objLayer.Name Then
               objSelected.Delete
            End If
         Next
         objLayer.Delete
   End If
Next
ThisDrawing.SelectionSets("layerdelete").Delete
For Each objLayer In ThisDrawing.Layers
   If objLayer.Freeze = True Then
         If ThisDrawing.SelectionSets.Count > 0 Then
            For n = 0 To ThisDrawing.SelectionSets.Count - 1
               If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then
                     ThisDrawing.SelectionSets("layerdelete").Delete
               End If
            Next n
         End If
         Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")
         OBJSELSET.Select acSelectionSetAll
         For Each objSelected In OBJSELSET
            If objSelected.Layer = objLayer.Name Then
               objSelected.Delete
            End If
         Next
         objLayer.Delete
   End If
Next
End Sub
Private Sub SETUPLAYERS()
Dim objLay As AcadLayer
Set objLay = ThisDrawing.Layers.Add("E-BASE-PLAN")
objLay.color = 252
End Sub
Private Sub SETCOLORLINETYPE()
Dim objLayer As AcadLayer
Dim objSelected As Object
Dim OBJSELSET As AcadSelectionSet
Dim n As Integer
Dim strLinetype As String
Dim strLayer As String
If ThisDrawing.SelectionSets.Count > 0 Then
   For n = 0 To ThisDrawing.SelectionSets.Count - 1
         If ThisDrawing.SelectionSets.Item(n).Name = "ChangeLine" Then
            ThisDrawing.SelectionSets("ChangeLine").Delete
         End If
   Next n
End If
Set OBJSELSET = ThisDrawing.SelectionSets.Add("ChangeLine")
OBJSELSET.Select acSelectionSetAll
For Each objSelected In OBJSELSET
strLinetype = ThisDrawing.Layers(objSelected.Layer).Linetype
objSelected.Linetype = strLinetype
Next
ThisDrawing.SelectionSets("ChangeLine").Delete
End Sub
Private Sub CHANGELAYER()
Dim ENT As AcadEntity
On Error Resume Next
For Each ENT In ThisDrawing.ModelSpace
   ENT.Layer = "E-BASE-PLAN"
Next ENT
ThisDrawing.Regen acAllViewports
End Sub

剩下的就是处理块和属性

nivuahc 发表于 2006-2-1 11:21:08

第二回合...
Option Explicit
Public Sub FIXLAYERS()
Call DELETELAYERS
Call SETUPLAYERS
Call SETCOLORLINETYPE
Call CHANGELAYER
End Sub
这是我们将使用的实际“函数”（FIXLAYERS），它将按照所示顺序调用其他函数
以下是我们的第一个称为子函数（DELETELAYERS）
Private Sub DELETELAYERS()
Dim objLayer As AcadLayer
Dim objSelected As Object
Dim OBJSELSET As AcadSelectionSet
Dim n As Integer
ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")
使第0层当前
For Each objLayer In ThisDrawing.Layers
   If objLayer.Name = "0" Then
         objLayer.Lock = False
         objLayer.LayerOn = True
         'objLayer.Freeze = False
   Else
         objLayer.Lock = False
   End If
确保层“0”既未锁定也不冻结，并在需要时将其打开。确保图形中的其余图层已解锁（如果它们已锁定）。
Next
ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")
ThisDrawing.Application.Update
ThisDrawing.Regen acAllViewports
好的...除了 Application.Update（这到底有什么作用？）和 regen 之外，我们不是已经将层 '0' 设置为当前吗？我们为什么要再做一次？
For Each objLayer In ThisDrawing.Layers
   If objLayer.LayerOn = False Then
         If ThisDrawing.SelectionSets.Count > 0 Then
            For n = 0 To ThisDrawing.SelectionSets.Count - 1
               If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then
                     ThisDrawing.SelectionSets("layerdelete").Delete
               End If
            Next n
         End If
好吧，我承认我并不完全了解这里发生了什么......
看起来你正在做的是检查某个特定层是否关闭，如果是，呃......
嗯......
然后呢？
         Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")
         OBJSELSET.Select acSelectionSetAll
         For Each objSelected In OBJSELSET
            If objSelected.Layer = objLayer.Name Then
               objSelected.Delete
            End If
         Next
         objLayer.Delete
   End If
Next
哇！
我想
这就是我们删除所有已关闭图层并删除它们的地方......但我不能说我们是怎么做到的。

For Each objLayer In ThisDrawing.Layers
   If objLayer.Freeze = True Then
         If ThisDrawing.SelectionSets.Count > 0 Then
            For n = 0 To ThisDrawing.SelectionSets.Count - 1
               If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then
                     ThisDrawing.SelectionSets("layerdelete").Delete
               End If
            Next n
         End If
         Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")
         OBJSELSET.Select acSelectionSetAll
         For Each objSelected In OBJSELSET
            If objSelected.Layer = objLayer.Name Then
               objSelected.Delete
            End If
         Next
         objLayer.Delete
   End If
Next
与关闭的层相同，只是这是对冻结层的处理。仍然不确定是否发生了这个过程。
End Sub
这是我们第一个称为子函数（DELETELAYERS）的结尾）
接下来是我们的第二个称为子函数（SETUPLAYERS）
Private Sub SETUPLAYERS()
Dim objLay As AcadLayer
Set objLay = ThisDrawing.Layers.Add("E-BASE-PLAN")
objLay.color = 252
End Sub
这是我们的第二个称为子函数（SETUPLAYERS）的结束
）它创建了一个名为E-BASE-PLAN的层，并为其分配了252的颜色
接下来是我们的第三个称为子函数（SETCOLORLINETYPE）
Private Sub SETCOLORLINETYPE()
Dim objLayer As AcadLayer
Dim objSelected As Object
Dim OBJSELSET As AcadSelectionSet
Dim n As Integer
If ThisDrawing.SelectionSets.Count > 0 Then
   For n = 0 To ThisDrawing.SelectionSets.Count - 1
         If ThisDrawing.SelectionSets.Item(n).Name = "changecolorline" Then
            ThisDrawing.SelectionSets("changecolorline").Delete
         End If
   Next n
End If
Set OBJSELSET = ThisDrawing.SelectionSets.Add("changecolorline")
OBJSELSET.Select acSelectionSetAll
um...同样的东西，只是不同。
'this is where we are at so far
评论！
End Sub
这是我们第三个称为子函数（SETCOLORLINETYPE）的结尾
，接下来是我们的第四个称为子函数（CHANGELAYER）
Private Sub CHANGELAYER()
MsgBox "CHANGE LAYER"
End Sub
这是第四个称为子函数（CHANGELAYER）的结尾
，它弹出一个MSGBOX，上面写着“CHANGE LAYER”
我该怎么办？
嘿！更多代码要完成！

nivuahc 发表于 2006-2-1 11:33:52

您正在为这个绘图图层集合中的每个图层进行精细翻译，如果它关闭（layeron=false），则选择ALL集，然后对于SS中的每个obj，如果obj.Layer=ObjLayer.name（关闭图层的名称），删除对象，重复下一个obj。然后从DB中删除图层

ronjonp 发表于 2006-2-1 11:36:22

Private Sub CHANGELAYER()
Dim ENT As AcadEntity
On Error Resume Next
For Each ENT In ThisDrawing.ModelSpace
ENT.Layer = "E-BASE-PLAN"
Next ENT
ThisDrawing.Regen acAllViewports
End Sub
除了命名法的变化（“ChangeLine”）之外，我认为这就是所有变化。这似乎将绘图中每个实体的图层更改为E-BASE PLAN图层。
不过，我们不应该在SETCOlorLINETYPE子级中放这样的东西吗？
objLayer.Color = acByLayer

页: [1]

乐筑天下's Archiver

全部转换为按图层