更改图层名称
你好我正在尝试使用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公司 如果我理解正确，原因是您试图将相同的名称属性分配给两个不同的对象。你不能那样做。如果希望某个图层上的图元位于另一个图层上，则必须更改这些图元的图层特性，而不是图层本身。IHTH公司 嗨，Col
我有一些前不久创建的代码。
看看你能不能根据自己的需要调整一下
如果你需要帮助，请告诉我
我有两个变量，一个用于当前层，一个用于新层
毫升
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
上校，
我有几分钟的时间，所以我继续努力，把它解决了。
这是你需要的吗？
毫升
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
你可以这样做，也可以使用express tools中的图层合并，或者Col可能有一个我们不知道的更大的图景
我坚信首先使用应用程序，除非它太麻烦或太耗时
做记号 毫升，
感谢您花时间编写该代码。我试过了，但问题是，如果层名称Text\u Hadrian已经存在，它就会出错。
我目前确实使用层翻译来完成这项任务，但老实说，我觉得它有点垃圾，也许我不知道如何充分利用它的潜力！！只导入使用层转换器、导入模板然后分配层似乎比保存模板然后执行相同的过程更新层更快。
我们办公室没有图层标准，所以每个人都用不同的图层名称绘制，我不是D.O.经理，所以我不能强迫他们按照标准工作，虽然我已经发布了正确设置的标准模板，但它们并不总是被使用，加上我们修改了很多旧图纸，所以所有旧图纸仍然需要更新。
此外，我们使用许多供应商提供的标准块，它们都使用不同的层名称。
我的想法是有一个按钮，你点击，模仿层翻译，但没有所有的大惊小怪。
我将尝试采用ML的代码来实现这一点，
谢谢你的帮助。
col公司 Col公司
不客气，这很容易调整，因为我已经编写了其他代码。
就层现有部分而言，这也是一个容易解决的问题。
给我10分钟，我会发布修复。
毫升 好的，Col，
我只需要添加一个
出错时，将下一条语句恢复到代码中
请参见红色
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"
On Error Resume Next
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层。
上面的代码解决了这个问题。
看看我的这句话：
Debug.Print "Layer " & crLayNames & " has been changed to " & nwLayNames
如果你只有一个图层文本，那么在即时窗口打开的情况下，运行代码，你就会得到这个结果。
Layer TEXT has been changed to Text_Hadrian
如果layer Text\u Hadrian已经存在，您将得到这个
Layer Text_Hadrian has been changed to Text_Hadrian
无论出于何种目的，这都是好的。
如果图形中同时存在layer TEXT和TEXT_Hadrian，则除了指示VBA忽略错误并继续执行代码外，您无能为力。
无论如何
我想以上就是你想要的。
如果你有任何其他问题，请告诉我
别紧张，上校！
毫升 上校，
这可能超出了您需要的范围，但假设您在图形中已经有一个层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，如果它已经存在于图形中。
毫升
页:
[1]
2