更改图层名称

comcu · 发表于 2022-7-6 17:24:31

你好

我正在尝试使用VBA自动重命名层。

图层名“TEXT”和TEXT\u Hadrian“存在于当前图形中，我正在尝试将合并到“TEXT\u Hadrian”图层名

我试过以下方法


Private Sub LayerStandards()
Dim MyOldLayerName As AcadLayer
Dim MyNewLayerName As AcadLayer
MyOldLayerName.Name = "TEXT"
MyNewLayerName.Name = "Text_Hadrian"
Set MyOldLayerName.Name = MyNewLayerName.Name
End Sub

有没有人没有我可以修改的例子？

干杯

Col公司

borgunit · 发表于 2022-7-6 17:29:54

如果我理解正确，原因是您试图将相同的名称属性分配给两个不同的对象。你不能那样做。如果希望某个图层上的图元位于另一个图层上，则必须更改这些图元的图层特性，而不是图层本身。IHTH公司

ML0940 · 发表于 2022-7-6 17:34:08

嗨，Col

我有一些前不久创建的代码。
看看你能不能根据自己的需要调整一下
如果你需要帮助，请告诉我
我有两个变量，一个用于当前层，一个用于新层
毫升

copy


Sub ChangeLayNamePrefix()
Dim lay As AcadLayer
Dim crLayNames As String
Dim nwLayNames As String
'Update Layer name prefixs
For Each lay In ThisDrawing.Layers
 If Not lay.Name = "0" Then 'Filter out Layer 0
  If Not lay.Name = "defpoints" Then 'Filter out Layer defpoints
   crLayNames = lay.Name
  'Starting from char 1 of string variable crLayNames, if string "prefix-" exists then
   If InStr(1, crLayNames, "ADT-", vbTextCompare) Then
   'In string variable crLayerName, replace "prefix-" w\ "newprefix-"
    nwLayNames = Replace(crLayNames, "ADT-", "newprefix-", , , vbTextCompare)
    lay.Name = nwLayNames
    Debug.Print "Layer " & crLayNames & " has been changed to " & nwLayNames
   End If
  End If
 End If
Next lay
Set lay = Nothing
End Sub

ML0940 · 发表于 2022-7-6 17:36:59

上校，
我有几分钟的时间，所以我继续努力，把它解决了。
这是你需要的吗？
毫升

copy


Sub ChangeLayName()
Dim lay As AcadLayer
Dim crLayNames As String
Dim nwLayNames As String
'Find and replace Layer name
For Each lay In ThisDrawing.Layers
 If Not lay.Name = "0" Then 'Filter out Layer 0
  If Not lay.Name = "defpoints" Then 'Filter out Layer defpoints
   crLayNames = lay.Name
  'Starting from char 1 of string variable crLayNames, if string exists then
   If InStr(1, crLayNames, "Text", vbTextCompare) Then
  'In string variable crLayerName, replace string crLayNames w\ "Text_Hadrian"
    nwLayNames = Replace(crLayNames, crLayNames, "Text_Hadrian", , , vbTextCompare)
    lay.Name = nwLayNames
    Debug.Print "Layer " & crLayNames & " has been changed to " & nwLayNames
   End If
  End If
 End If
Next lay
Set lay = Nothing
End Sub

smorales02 · 发表于 2022-7-6 17:37:51

为什么不选择文字层上的全部（使用快速选择）更改为其他层并清除？？

ML0940 · 发表于 2022-7-6 17:42:35

是smorales02
你可以这样做，也可以使用express tools中的图层合并，或者Col可能有一个我们不知道的更大的图景

我坚信首先使用应用程序，除非它太麻烦或太耗时

做记号

comcu · 发表于 2022-7-6 17:44:51

毫升，

感谢您花时间编写该代码。我试过了，但问题是，如果层名称Text\u Hadrian已经存在，它就会出错。

我目前确实使用层翻译来完成这项任务，但老实说，我觉得它有点垃圾，也许我不知道如何充分利用它的潜力！！只导入使用层转换器、导入模板然后分配层似乎比保存模板然后执行相同的过程更新层更快。

我们办公室没有图层标准，所以每个人都用不同的图层名称绘制，我不是D.O.经理，所以我不能强迫他们按照标准工作，虽然我已经发布了正确设置的标准模板，但它们并不总是被使用，加上我们修改了很多旧图纸，所以所有旧图纸仍然需要更新。
此外，我们使用许多供应商提供的标准块，它们都使用不同的层名称。
我的想法是有一个按钮，你点击，模仿层翻译，但没有所有的大惊小怪。
我将尝试采用ML的代码来实现这一点，

谢谢你的帮助。

col公司

ML0940 · 发表于 2022-7-6 17:47:06

Col公司
不客气，这很容易调整，因为我已经编写了其他代码。

就层现有部分而言，这也是一个容易解决的问题。
给我10分钟，我会发布修复。

毫升

ML0940 · 发表于 2022-7-6 17:52:32

好的，Col，
我只需要添加一个
出错时，将下一条语句恢复到代码中
请参见红色

copy


Sub ChangeLayName()
Dim lay As AcadLayer
Dim crLayNames As String
Dim nwLayNames As String
'Find and replace Layer name
For Each lay In ThisDrawing.Layers
 If Not lay.Name = "0" Then 'Filter out Layer 0
  If Not lay.Name = "defpoints" Then 'Filter out Layer defpoints
   crLayNames = lay.Name
   'Starting from char 1 of string variable crLayNames, if string "Text" is found then
    If InStr(1, crLayNames, "Text", vbTextCompare) Then
   'Replace string "Text" w\ "Text_Hadrian"
    [color=red]On Error Resume Next[/color]
    nwLayNames = Replace(crLayNames, crLayNames, "Text_Hadrian", , , vbTextCompare)
    lay.Name = nwLayNames
    Debug.Print "Layer " & crLayNames & " has been changed to " & nwLayNames
   End If
  End If
 End If
Next lay
Set lay = Nothing
End Sub

很抱歉，我没有看到，但如果在图形中同时存在图层文字和图层文字，则会出现该错误。
每个图形只能有一个Text\u Hadrian层。

上面的代码解决了这个问题。

看看我的这句话：

copy


Debug.Print "Layer " & crLayNames & " has been changed to " & nwLayNames

如果你只有一个图层文本，那么在即时窗口打开的情况下，运行代码，你就会得到这个结果。

copy


Layer TEXT has been changed to Text_Hadrian

如果layer Text\u Hadrian已经存在，您将得到这个

copy


Layer Text_Hadrian has been changed to Text_Hadrian

无论出于何种目的，这都是好的。

如果图形中同时存在layer TEXT和TEXT_Hadrian，则除了指示VBA忽略错误并继续执行代码外，您无能为力。

无论如何
我想以上就是你想要的。

如果你有任何其他问题，请告诉我

别紧张，上校！

毫升

ML0940 · 发表于 2022-7-6 17:55:22

上校，

这可能超出了您需要的范围，但假设您在图形中已经有一个层Text\u Hadrian，我们可以指示VBA将其重命名为类似Text\u Hadrian-temp的内容。

然后将层文字重命名为Text\u Hadrian

在这种情况下，结果将是一个层
Text\u Hadrian-temp和图形中的图层Text\u Hadrian。

同样，正如我在上面的帖子中所说，我们只是指示VBA忽略错误，并将Text\u Hadrian重命名为Text\u Hadrian，如果它已经存在于图形中。

毫升

[编程交流] 更改图层名称

发表回复

精选推荐