乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 ☆ ☆ ☆ 尊重版权，从我做起，拒绝盗版，拒绝倒卖 ☆ ☆ ☆ 签到、发布资源、邀请好友注册，可以获得银币 ☆ ☆ ☆ 请注意保管好自己的密码，避免账户资金被盗
查看： 129|回复： 8

全部转换为按图层

[复制链接]
nivuahc

3

主题

44

帖子

3

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
58
发表于 2006-2-1 10:22:04 | 显示全部楼层 |阅读模式

本帖以下内容被隐藏保护；需要你回复后，才能看到！

游客，如果您要查看本帖隐藏内容请回复
回复

使用道具 举报

nivuahc

3

主题

44

帖子

3

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
58
发表于 2006-2-1 10:27:32 | 显示全部楼层
这应该很容易做到。 你有什么样的时间框架？
回复

使用道具 举报

nivuahc

3

主题

44

帖子

3

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
58
发表于 2006-2-1 10:28:28 | 显示全部楼层
所以我想你想解锁所有层。
删除所有图层FROZEN和/或OFF。
创建您需要的图层（E-BASE PLAN）。
将颜色设置为您保留的图层。
对于mspace中的每个对象，获取图层，获取图层的线型，将线型设置为对象。
将每个对象放在E-BASE PLAN。
回复

使用道具 举报

ronjonp

58

主题

3353

帖子

33

银币

顶梁支柱

Rank: 50Rank: 50

铜币
1761
发表于 2006-2-1 10:49:46 | 显示全部楼层

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

使用道具 举报

nivuahc

3

主题

44

帖子

3

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
58
发表于 2006-2-1 10:52:48 | 显示全部楼层
太棒了！！！你能做到的！我也为你准备了下一部分
  1. Option Explicit

  2. Public Sub FIXLAYERS()

  3.     Call DELETELAYERS

  4.     Call SETUPLAYERS

  5.     Call SETCOLORLINETYPE

  6.     Call CHANGELAYER

  7. End Sub

  8. Private Sub DELETELAYERS()

  9. Dim objLayer As AcadLayer

  10. Dim objSelected As Object

  11. Dim OBJSELSET As AcadSelectionSet

  12. Dim n As Integer

  13.     ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")

  14.     For Each objLayer In ThisDrawing.Layers

  15.         If objLayer.Name = "0" Then

  16.             objLayer.Lock = False

  17.             objLayer.LayerOn = True

  18.             'objLayer.Freeze = False

  19.         Else

  20.             objLayer.Lock = False

  21.         End If

  22.     Next

  23.     ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")

  24.     ThisDrawing.Application.Update

  25.     ThisDrawing.Regen acAllViewports

  26.     For Each objLayer In ThisDrawing.Layers

  27.         If objLayer.LayerOn = False Then

  28.             If ThisDrawing.SelectionSets.Count > 0 Then

  29.                 For n = 0 To ThisDrawing.SelectionSets.Count - 1

  30.                     If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then

  31.                         ThisDrawing.SelectionSets("layerdelete").Delete

  32.                     End If

  33.                 Next n

  34.             End If

  35.             Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")

  36.             OBJSELSET.Select acSelectionSetAll

  37.             For Each objSelected In OBJSELSET

  38.                 If objSelected.Layer = objLayer.Name Then

  39.                     objSelected.Delete

  40.                 End If

  41.             Next

  42.             objLayer.Delete

  43.         End If

  44.     Next

  45.     

  46.     

  47.     For Each objLayer In ThisDrawing.Layers

  48.         If objLayer.Freeze = True Then

  49.             If ThisDrawing.SelectionSets.Count > 0 Then

  50.                 For n = 0 To ThisDrawing.SelectionSets.Count - 1

  51.                     If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then

  52.                         ThisDrawing.SelectionSets("layerdelete").Delete

  53.                     End If

  54.                 Next n

  55.             End If

  56.             Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")

  57.             OBJSELSET.Select acSelectionSetAll

  58.             For Each objSelected In OBJSELSET

  59.                 If objSelected.Layer = objLayer.Name Then

  60.                     objSelected.Delete

  61.                 End If

  62.             Next

  63.             objLayer.Delete

  64.         End If

  65.     Next

  66. End Sub

  67. Private Sub SETUPLAYERS()

  68. Dim objLay As AcadLayer

  69.     Set objLay = ThisDrawing.Layers.Add("E-BASE-PLAN")

  70.     objLay.color = 252

  71. End Sub

  72. Private Sub SETCOLORLINETYPE()

  73. Dim objLayer As AcadLayer

  74. Dim objSelected As Object

  75. Dim OBJSELSET As AcadSelectionSet

  76. Dim n As Integer

  77.     If ThisDrawing.SelectionSets.Count > 0 Then

  78.         For n = 0 To ThisDrawing.SelectionSets.Count - 1

  79.             If ThisDrawing.SelectionSets.Item(n).Name = "changecolorline" Then

  80.                 ThisDrawing.SelectionSets("changecolorline").Delete

  81.             End If

  82.         Next n

  83.     End If

  84.     Set OBJSELSET = ThisDrawing.SelectionSets.Add("changecolorline")

  85.     OBJSELSET.Select acSelectionSetAll

  86. 'this is where we are at so far

  87. End Sub

  88. Private Sub CHANGELAYER()

  89.     MsgBox "CHANGE LAYER"

  90. End Sub

回复

使用道具 举报

nivuahc

3

主题

44

帖子

3

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
58
发表于 2006-2-1 10:55:31 | 显示全部楼层
这主要是你想要的地方
  1. Option Explicit

  2. Public Sub FIXLAYERS()

  3.     Call DELETELAYERS

  4.     Call SETUPLAYERS

  5.     Call SETCOLORLINETYPE

  6.     Call CHANGELAYER

  7. End Sub

  8. Private Sub DELETELAYERS()

  9. Dim objLayer As AcadLayer

  10. Dim objSelected As Object

  11. Dim OBJSELSET As AcadSelectionSet

  12. Dim n As Integer

  13.     ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")

  14.     For Each objLayer In ThisDrawing.Layers

  15.         If objLayer.Name = "0" Then

  16.             objLayer.Lock = False

  17.             objLayer.LayerOn = True

  18.             'objLayer.Freeze = False

  19.         Else

  20.             objLayer.Lock = False

  21.         End If

  22.     Next

  23.     ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")

  24.     ThisDrawing.Application.Update

  25.     ThisDrawing.Regen acAllViewports

  26.     For Each objLayer In ThisDrawing.Layers

  27.         If objLayer.LayerOn = False Then

  28.             If ThisDrawing.SelectionSets.Count > 0 Then

  29.                 For n = 0 To ThisDrawing.SelectionSets.Count - 1

  30.                     If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then

  31.                         ThisDrawing.SelectionSets("layerdelete").Delete

  32.                     End If

  33.                 Next n

  34.             End If

  35.             Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")

  36.             OBJSELSET.Select acSelectionSetAll

  37.             For Each objSelected In OBJSELSET

  38.                 If objSelected.Layer = objLayer.Name Then

  39.                     objSelected.Delete

  40.                 End If

  41.             Next

  42.             objLayer.Delete

  43.         End If

  44.     Next

  45. ThisDrawing.SelectionSets("layerdelete").Delete

  46.     For Each objLayer In ThisDrawing.Layers

  47.         If objLayer.Freeze = True Then

  48.             If ThisDrawing.SelectionSets.Count > 0 Then

  49.                 For n = 0 To ThisDrawing.SelectionSets.Count - 1

  50.                     If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then

  51.                         ThisDrawing.SelectionSets("layerdelete").Delete

  52.                     End If

  53.                 Next n

  54.             End If

  55.             Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")

  56.             OBJSELSET.Select acSelectionSetAll

  57.             For Each objSelected In OBJSELSET

  58.                 If objSelected.Layer = objLayer.Name Then

  59.                     objSelected.Delete

  60.                 End If

  61.             Next

  62.             objLayer.Delete

  63.         End If

  64.     Next

  65. End Sub

  66. Private Sub SETUPLAYERS()

  67. Dim objLay As AcadLayer

  68.     Set objLay = ThisDrawing.Layers.Add("E-BASE-PLAN")

  69.     objLay.color = 252

  70. End Sub

  71. Private Sub SETCOLORLINETYPE()

  72. Dim objLayer As AcadLayer

  73. Dim objSelected As Object

  74. Dim OBJSELSET As AcadSelectionSet

  75. Dim n As Integer

  76. Dim strLinetype As String

  77. Dim strLayer As String

  78.     If ThisDrawing.SelectionSets.Count > 0 Then

  79.         For n = 0 To ThisDrawing.SelectionSets.Count - 1

  80.             If ThisDrawing.SelectionSets.Item(n).Name = "ChangeLine" Then

  81.                 ThisDrawing.SelectionSets("ChangeLine").Delete

  82.             End If

  83.         Next n

  84.     End If

  85.     Set OBJSELSET = ThisDrawing.SelectionSets.Add("ChangeLine")

  86.     OBJSELSET.Select acSelectionSetAll

  87.     For Each objSelected In OBJSELSET

  88. strLinetype = ThisDrawing.Layers(objSelected.Layer).Linetype

  89. objSelected.Linetype = strLinetype

  90.     Next

  91. ThisDrawing.SelectionSets("ChangeLine").Delete

  92. End Sub

  93. Private Sub CHANGELAYER()

  94. Dim ENT As AcadEntity

  95.     On Error Resume Next

  96.     For Each ENT In ThisDrawing.ModelSpace

  97.         ENT.Layer = "E-BASE-PLAN"

  98.     Next ENT

  99.     ThisDrawing.Regen acAllViewports

  100. End Sub

剩下的就是处理块和属性
回复

使用道具 举报

nivuahc

3

主题

44

帖子

3

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
58
发表于 2006-2-1 11:21:08 | 显示全部楼层
第二回合...
  1. Option Explicit

  2. Public Sub FIXLAYERS()

  3.     Call DELETELAYERS

  4.     Call SETUPLAYERS

  5.     Call SETCOLORLINETYPE

  6.     Call CHANGELAYER

  7. End Sub

这是我们将使用的实际“函数”（FIXLAYERS），它将按照所示顺序调用其他函数
以下是我们的第一个称为子函数（DELETELAYERS）
  1. Private Sub DELETELAYERS()

  2. Dim objLayer As AcadLayer

  3. Dim objSelected As Object

  4. Dim OBJSELSET As AcadSelectionSet

  5. Dim n As Integer

  6.     ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")

使第0层当前
  1.     For Each objLayer In ThisDrawing.Layers

  2.         If objLayer.Name = "0" Then

  3.             objLayer.Lock = False

  4.             objLayer.LayerOn = True

  5.             'objLayer.Freeze = False

  6.         Else

  7.             objLayer.Lock = False

  8.         End If

确保层“0”既未锁定也不冻结，并在需要时将其打开。确保图形中的其余图层已解锁（如果它们已锁定）。
  1.     Next

  2.     ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")

  3.     ThisDrawing.Application.Update

  4.     ThisDrawing.Regen acAllViewports

好的...除了 Application.Update（这到底有什么作用？）和 regen 之外，我们不是已经将层 '0' 设置为当前吗？我们为什么要再做一次？
  1.     For Each objLayer In ThisDrawing.Layers

  2.         If objLayer.LayerOn = False Then

  3.             If ThisDrawing.SelectionSets.Count > 0 Then

  4.                 For n = 0 To ThisDrawing.SelectionSets.Count - 1

  5.                     If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then

  6.                         ThisDrawing.SelectionSets("layerdelete").Delete

  7.                     End If

  8.                 Next n

  9.             End If

好吧，我承认我并不完全了解这里发生了什么......
看起来你正在做的是检查某个特定层是否关闭，如果是，呃......
嗯......
然后呢？
  1.             Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")

  2.             OBJSELSET.Select acSelectionSetAll

  3.             For Each objSelected In OBJSELSET

  4.                 If objSelected.Layer = objLayer.Name Then

  5.                     objSelected.Delete

  6.                 End If

  7.             Next

  8.             objLayer.Delete

  9.         End If

  10.     Next

哇！
我想
这就是我们删除所有已关闭图层并删除它们的地方......但我不能说我们是怎么做到的。

  1.     For Each objLayer In ThisDrawing.Layers

  2.         If objLayer.Freeze = True Then

  3.             If ThisDrawing.SelectionSets.Count > 0 Then

  4.                 For n = 0 To ThisDrawing.SelectionSets.Count - 1

  5.                     If ThisDrawing.SelectionSets.Item(n).Name = "layerdelete" Then

  6.                         ThisDrawing.SelectionSets("layerdelete").Delete

  7.                     End If

  8.                 Next n

  9.             End If

  10.             Set OBJSELSET = ThisDrawing.SelectionSets.Add("layerdelete")

  11.             OBJSELSET.Select acSelectionSetAll

  12.             For Each objSelected In OBJSELSET

  13.                 If objSelected.Layer = objLayer.Name Then

  14.                     objSelected.Delete

  15.                 End If

  16.             Next

  17.             objLayer.Delete

  18.         End If

  19.     Next

与关闭的层相同，只是这是对冻结层的处理。仍然不确定是否发生了这个过程。
  1. End Sub

这是我们第一个称为子函数（DELETELAYERS）的结尾）
接下来是我们的第二个称为子函数（SETUPLAYERS）
  1. Private Sub SETUPLAYERS()

  2. Dim objLay As AcadLayer

  3.     Set objLay = ThisDrawing.Layers.Add("E-BASE-PLAN")

  4.     objLay.color = 252

  5. End Sub

这是我们的第二个称为子函数（SETUPLAYERS）的结束
）它创建了一个名为E-BASE-PLAN的层，并为其分配了252的颜色
接下来是我们的第三个称为子函数（SETCOLORLINETYPE）
  1. Private Sub SETCOLORLINETYPE()

  2. Dim objLayer As AcadLayer

  3. Dim objSelected As Object

  4. Dim OBJSELSET As AcadSelectionSet

  5. Dim n As Integer

  6.     If ThisDrawing.SelectionSets.Count > 0 Then

  7.         For n = 0 To ThisDrawing.SelectionSets.Count - 1

  8.             If ThisDrawing.SelectionSets.Item(n).Name = "changecolorline" Then

  9.                 ThisDrawing.SelectionSets("changecolorline").Delete

  10.             End If

  11.         Next n

  12.     End If

  13.     Set OBJSELSET = ThisDrawing.SelectionSets.Add("changecolorline")

  14.     OBJSELSET.Select acSelectionSetAll

um...同样的东西，只是不同。
  1. 'this is where we are at so far

评论！
  1. End Sub

这是我们第三个称为子函数（SETCOLORLINETYPE）的结尾
，接下来是我们的第四个称为子函数（CHANGELAYER）
  1. Private Sub CHANGELAYER()

  2.     MsgBox "CHANGE LAYER"

  3. End Sub

这是第四个称为子函数（CHANGELAYER）的结尾
，它弹出一个MSGBOX，上面写着“CHANGE LAYER”
我该怎么办？
嘿！更多代码要完成！
回复

使用道具 举报

nivuahc

3

主题

44

帖子

3

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
58
发表于 2006-2-1 11:33:52 | 显示全部楼层

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

使用道具 举报

ronjonp

58

主题

3353

帖子

33

银币

顶梁支柱

Rank: 50Rank: 50

铜币
1761
发表于 2006-2-1 11:36:22 | 显示全部楼层 
  1. Private Sub CHANGELAYER()

  2. Dim ENT As AcadEntity

  3.     On Error Resume Next

  4.     For Each ENT In ThisDrawing.ModelSpace

  5.         ENT.Layer = "E-BASE-PLAN"

  6.     Next ENT

  7.     ThisDrawing.Regen acAllViewports

  8. End Sub

除了命名法的变化（“ChangeLine”）之外，我认为这就是所有变化。这似乎将绘图中每个实体的图层更改为E-BASE PLAN图层。
不过，我们不应该在SETCOlorLINETYPE子级中放这样的东西吗？
  1. objLayer.Color = acByLayer
回复

使用道具 举报

返回列表 发帖

发表回复

高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

精选推荐

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-7-5 00:19 , Processed in 0.678479 second(s), 71 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表