[VBA函数]：转层问题

savasava

我刚刚在学习 VBA开发CAD。我的工作主要是用CAD处理地图，其中很多工作是把某一层的图形转到另一个层。举例来说 如 在A层中线宽为1，颜色为红的直线需转到B层（如果B层不存在则，新建一个B层），请问用VBA程序如何实现 不胜感激
（我用CAD2000）

efan2000

给你个例子，如果不明白的地方可以看看帮助文件。

2. 
   
3.   [FONT=courier new]
   
4. 
   
5. Private Sub Test()
   
6.     On Error Resume Next
   
7.     '引用选择集，如不存在则创建
   
8.     Dim SSetObj As AcadSelectionSet
   
9.     Set SSetObj = ThisDrawing.SelectionSets("ChangeLayer")
   
10.     If Err Then
    
11.         Err.Clear
    
12.         Set SSetObj = ThisDrawing.SelectionSets.Add("ChangeLayer")
    
13.     End If
    
14.     SSetObj.Clear
    
15.     Dim fType(0 To 3) As Integer
    
16.     Dim fData(0 To 3) As Variant
    
17.     fType(0) = 0
    
18.     fData(0) = "LWPOLYLINE" '实体类型
    
19.     fType(1) = 8
    
20.     fData(1) = "A" '层
    
21.     fType(2) = 62
    
22.     fData(2) = acRed '颜色
    
23.     fType(3) = 43
    
24.     fData(3) = 1 '线宽
    
25.     SSetObj.Select acSelectionSetAll, , , fType, fData
    
26.     If SSetObj.Count = 0 Then Exit Sub
    
27.     '引用层，如不存在则创建
    
28.     Dim LayerObj As AcadLayer
    
29.     Set LayerObj = ThisDrawing.Layers("B")
    
30.     If Err Then
    
31.         Err.Clear
    
32.         Set LayerObj = ThisDrawing.Layers.Add("B")
    
33.     End If
    
34.     Dim i As Integer
    
35.     For i = 0 To SSetObj.Count - 1
    
36.         SSetObj(i).Layer = LayerObj.Name '更改层名
    
37.     Next
    
38.     Set LayerObj = Nothing
    
39.     Set SSetObj = Nothing
    
40. End Sub
    
41. 
    
42.   [/FONT]
    

<br />   [FONT=courier new]<br /> <br /> Private Sub Test()<br />     On Error Resume Next<br />     '引用选择集，如不存在则创建<br />     Dim SSetObj As AcadSelectionSet<br />     Set SSetObj = ThisDrawing.SelectionSets("ChangeLayer")<br />     If Err Then<br />         Err.Clear<br />         Set SSetObj = ThisDrawing.SelectionSets.Add("ChangeLayer")<br />     End If<br />     SSetObj.Clear<br />     Dim fType(0 To 3) As Integer<br />     Dim fData(0 To 3) As Variant<br />     fType(0) = 0<br />     fData(0) = "LWPOLYLINE" '实体类型<br />     fType(1) = 8<br />     fData(1) = "A" '层<br />     fType(2) = 62<br />     fData(2) = acRed '颜色<br />     fType(3) = 43<br />     fData(3) = 1 '线宽<br />     SSetObj.Select acSelectionSetAll, , , fType, fData<br />     If SSetObj.Count = 0 Then Exit Sub<br />     '引用层，如不存在则创建<br />     Dim LayerObj As AcadLayer<br />     Set LayerObj = ThisDrawing.Layers("B")<br />     If Err Then<br />         Err.Clear<br />         Set LayerObj = ThisDrawing.Layers.Add("B")<br />     End If<br />     Dim i As Integer<br />     For i = 0 To SSetObj.Count - 1<br />         SSetObj(i).Layer = LayerObj.Name '更改层名<br />     Next<br />     Set LayerObj = Nothing<br />     Set SSetObj = Nothing<br /> End Sub<br /> <br />   [/FONT]<br />

savasava

楼上仁兄的程序
    SSetObj.Select acSelectionSetAll, , , fType, fData
    调试不通。我只好去掉acselectionsetall 后面所有参数，结果把所有层的内容都转到指定层，有没有其他方式过滤数据请赐教

efan2000

我机器上安装的也是AutoCAD R2000，调试成功。如果运行有错的话，可以参照一下帮助文件或者相关资料，了解一下选择集和过滤机制的用法。