[请帮帮我]我想

bienda · 发表于 2022-7-6 21:53:28

我有剧本

Sub ChangeLayer(ByVal FullDwgName)
On Error Resume Next
Dim AcadApp
Dim Thisdrawing
Set AcadApp = GetObject(,"Autocad.Application")
If Err Then
        Err.Clear
        Set AcadApp =CreateObject("Autocad.Application")
End If
Dim LayerObj
        
Dim strOldLayerName(4)        'old name of Layer
strOldLayerName(0) ="STV-DIM"
strOldLayerName(1) ="STV-CENTER"
strOldLayerName(2) ="STV-HIDDEN"
strOldLayerName(3) ="STV-REF"
strOldLayerName(4) ="STV-PRIMARY"
Dim strNewLayerName(4)        'New Name of Layer
strNewLayerName(0) ="PT-DIM"                'Name for new Layer 1
strNewLayerName(1) ="PT-CENTER"                'Name for new Layer 2
strNewLayerName(2) ="PT-HIDDEN"                'Name for new Layer 3
strNewLayerName(3) ="PT-REF"                'Name for new Layer 4
strNewLayerName(4) ="PT-PRIMARY"        'Name for new Layer 5
Dim intNewLayerColor(4)
intNewLayerColor(0)=1        'Color for Layer 1
intNewLayerColor(1)=2        'Color for Layer 2
intNewLayerColor(2)=3        'Color for Layer 3
intNewLayerColor(3)=4        'Color for Layer 4
intNewLayerColor(4)=5        'Color for Layer 5
Dim strNewLayerLineType(4)
strNewLayerLineType(0)="CENTER"
strNewLayerLineType(1)="Continuous"
strNewLayerLineType(2)="HIDDEN"
strNewLayerLineType(3)="PHANTOM"
strNewLayerLineType(4)="Continuous"
Set Thisdrawing = AcadApp.Documents.Open(FullDwgName)
Dim intA
For Each LayerObj In Thisdrawing.Layers
                
                For intA=0 To 4
                        If LayerObj.Name = strOldLayerName(intA) Then
                                
                                LayerObj.Name = strNewLayerName(intA)
                                LayerObj.color = intNewLayerColor(intA)
                                Thisdrawing.Linetypes.Load strNewLayerLineType(intA),"acad.lin"
                                LayerObj.Linetype=strNewLayerLineType(intA)
                                AcadApp.Update
                        End If
                Next
Next
'Close drawing
Thisdrawing.Close True
End Sub

旧层：A1、A2、A3、A4、A5、A6、A7、A8、A9
新层：B1、B2、B3、B4

所以我想把A1，A3，A5变成B1
A2、A4、A6、A7=>B2
A8=>B3
A9=>B4

我该怎么办？

提前谢谢你

BIGAL · 发表于 2022-7-6 22:14:26

首先，你有vba代码而不是脚本，想想lisp，script，vba&。网

上面的代码更改了图层属性而不是对象，如果要获取4层对象并生成一个图层，则不能将4个图层重命名为一个图层。

手动使用layiso选择4个图层选择所有对象、chprop或使用特性。

脚本示例

copy


(setq ss (ssget "x" '((8 . "A2,A4,A6,A7")))) (command "-chprop" ss "" "la" "B2" "")(setq ss nil)
(setq ss (ssget "x" '((8 . "A8")))) (command "-chprop" ss "" "la" "B3" "")(setq ss nil)
(setq ss (ssget "x" '((8 . "A9")))) (command "-chprop" ss "" "la" "B4" "")(setq ss nil)

bienda · 发表于 2022-7-6 22:20:45

这是我的文件更改层。rar公司
如果我想取4层对象并制作一层，我该怎么办？因为我想更改许多CAD文件。
帮我更改此文件。
提前谢谢你

BIGAL · 发表于 2022-7-6 22:33:11

只要让我发布的脚本做所有的工作，是的，一个lisp会做得更好，但一个真正的快速回答。

copy


Open dwg1
(setq ss (ssget "x" '((8 . "A2,A4,A6,A7")))) (command "-chprop" ss "" "la" "B2" "")(setq ss nil)
(setq ss (ssget "x" '((8 . "A8")))) (command "-chprop" ss "" "la" "B3" "")(setq ss nil)
(setq ss (ssget "x" '((8 . "A9")))) (command "-chprop" ss "" "la" "B4" "")(setq ss nil)
close Y
Open dwg2
(setq ss (ssget "x" '((8 . "A2,A4,A6,A7")))) (command "-chprop" ss "" "la" "B2" "")(setq ss nil)
(setq ss (ssget "x" '((8 . "A8")))) (command "-chprop" ss "" "la" "B3" "")(setq ss nil)
(setq ss (ssget "x" '((8 . "A9")))) (command "-chprop" ss "" "la" "B4" "")(setq ss nil)
close Y
Open dwg3
(setq ss (ssget "x" '((8 . "A2,A4,A6,A7")))) (command "-chprop" ss "" "la" "B2" "")(setq ss nil)
(setq ss (ssget "x" '((8 . "A8")))) (command "-chprop" ss "" "la" "B3" "")(setq ss nil)
(setq ss (ssget "x" '((8 . "A9")))) (command "-chprop" ss "" "la" "B4" "")(setq ss nil)
close Y

bienda · 发表于 2022-7-6 22:42:25

你能帮我把你的代码放到我的脚本文件里吗？
请

BIGAL · 发表于 2022-7-6 23:01:35

我发布了脚本文件all ready dwg1=drawing name 1等等。

将我第一篇文章中的3行另存为layers4321。通过记事本复制和粘贴。在命令行中键入SCRIPT，选择layers4321，它应该会更改当前图形。

[编程交流] [请帮帮我]我想

发表回复

精选推荐