怎样修改实体的颜色和图层?

bai_cai101

我的前辈用CAD R14画的DWG文件,其线宽是以颜色来区分的,一个图层里的实体有各种颜色,线宽,现在我想编一个程序,以图层,颜色为标准,将白色的实体放入"0"图层,其它颜色的实体放入"细线"图层.颜色都改为红色.但在我的这个程序中,程序对随层显示的实体不起作用,都直接将其归入了"0"图层 ,颜色改为白/黑色.请各位高手指点一下,我的程序如下: Sub qingli()
Dim tuceng As AcadLayer
On Error Resume Next
If IsNull(ThisDrawing.Layers.Item("0")) Then
Set tuceng = ThisDrawing.Layers.Add("0")
tuceng.color = 7
tuceng.Lineweight = acLnWt035
End If If IsNull(ThisDrawing.Layers.Item("细线")) Then
Set tuceng = ThisDrawing.Layers.Add("细线")
tuceng.color = 1
tuceng.Lineweight = acLnWt013
End If
Dim SSset As AcadSelectionSet '建立选择集"SS1"
Dim enti As AcadEntity
If Not IsNull(ThisDrawing.SelectionSets.Item("SS1")) Then
Set SSset = ThisDrawing.SelectionSets.Item("SS1")
SSset.Delete
End If
Set SSset = ThisDrawing.SelectionSets.Add("SS1")
Dim filterType As Integer
Dim filterData As Variant
filterType = 8
For Each tuceng In ThisDrawing.Layers
filterType = tuceng.Name
SSset.Select acSelectionSetAll
For Each enti In SSset If enti.Layer = "0" Then '图层"0"
If tuceng.color = 7 Then
If enti.color = acByLayer Or enti.color = 7 Or enti.color = acByBlock Then '就在这里,不管其图层设置的颜色如何,都将随层颜色的实体归入了"0"图层
' MsgBox tuceng.Name & "," & enti.color
enti.color = 7
enti.Update
Else
'MsgBox tuceng.Name & "," & enti.color
enti.color = 1
enti.Layer = "细线"
enti.Update
End If
ElseIf tuceng.color = 1 Then
If enti.color = 7 Or enti.color = acByBlock Then
enti.color = 7
enti.Update
Else
enti.color = 1
enti.Layer = "细线"
enti.Update
End If
Else
If enti.color = 7 Or enti.color = acByBlock Then
enti.color = 7
enti.Update
Else
enti.color = 1
enti.Layer = "细线"
enti.Update
End If
End If
'End If
ElseIf enti.Layer = "细线" Then '图层"细线"
If tuceng.color = 7 Then '就在这里,不管其图层设置的颜色如何,都将随层颜色的实体归入了"0"图层

If enti.color = acByLayer Or enti.color = 7 Or enti.color = acByBlock Then
MsgBox tuceng.Name & tuceng.color & enti.color
enti.color = 7
enti.Layer = "0"
enti.Update
Else
'MsgBox tuceng.Name & "," & enti.color
enti.color = 1
'enti.Layer = "细线"
enti.Update
End If
ElseIf tuceng.color = 1 Then
If enti.color = 7 Or enti.color = acByBlock Then
enti.color = 7
enti.Layer = "0"
enti.Update
Else
enti.color = 1
'enti.Layer = "细线"
enti.Update
End If
Else
If enti.color = 7 Or enti.color = acByBlock Then
enti.color = 7
enti.Layer = "0"
enti.Update
Else
enti.color = 1
'enti.Layer = "细线"
enti.Update
End If
End If
'End If
Else ' enti.Layer <> "细线" And enti.Layer <> "0" Then '图层"其它"
If tuceng.color = 7 Then '就在这里,不管其图层设置的颜色如何,都将随层颜色的实体归入了"0"图层

If enti.color = acByLayer Or enti.color = 7 Or enti.color = acByBlock Then
MsgBox tuceng.Name '& "," & enti.color
enti.color = 7
enti.Layer = "0"
enti.Update
Else
'MsgBox tuceng.Name & "," & enti.color
enti.color = 1
enti.Layer = "细线"
enti.Update
End If
ElseIf tuceng.color = 1 Then
If enti.color = 7 Or enti.color = acByBlock Then
enti.color = 7
enti.Layer = "0"
enti.Update
Else
enti.color = 1
enti.Layer = "细线"
enti.Update
End If
Else
If enti.color = 7 Or enti.color = acByBlock Then
enti.color = 7
enti.Layer = "0"
enti.Update
Else
enti.color = 1
enti.Layer = "细线"
enti.Update
End If
End If
End If Next enti
Next tuceng
For Each tuceng In ThisDrawing.Layers
If tuceng.Name = "0" Then
tuceng.color = 7
tuceng.Lineweight = acLnWt035
End If
If tuceng.Name = "细线" Then
tuceng.color = 1
tuceng.Lineweight = acLnWt013
End If
If tuceng.Name <> "0" And tuceng.Name <> "细线" And tuceng.Name <> "定义点" And tuceng.Name <> "Defpoints" Then
tuceng.Delete
End If
Next tuceng
SSset.clease
SSset.Delete End Sub