[VBA]怎么修改颜色??

bai_cai101

如果实体的颜色是随层显示,怎么样运用选择集有选择地修改其颜色?

bai_cai101

比如一个DWG文件,里面的实体的颜色,图层都很乱,需要按实体颜色的不同进行归入不同的图层,但有些实体的颜色为随层显示,我编的程序对随层显示的实体不起作用,请大家指点;我的程序

bai_cai101

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
' 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
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
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

雪山飞狐_lzh

选择图层为0，且随层，或者颜色为红色的实体： Sub tta()
On Error Resume Next
Dim ss As AcadSelectionSet
ThisDrawing.SelectionSets("Test").Delete
Set ss = ThisDrawing.SelectionSets.Add("Test")
Dim ft(6) As Integer, fd(6)
ft(0) = -4: fd(0) = "<or"
ft(1) = -4: fd(1) = "<and"
ft(2) = 8: fd(2) = "0"
ft(3) = 62: fd(3) = 256
ft(4) = -4: fd(4) = "and>"
ft(5) = 62: fd(5) = 1
ft(6) = -4: fd(6) = "or>"
ss.Select acSelectionSetAll, , , ft, fd
MsgBox ss.Count

bai_cai101

我对DXF不是很懂,也找不到这方面的资料!能否给我传一点过来,我的QQ79570611


邮箱:bai_cai101@163.com,多谢你了!!!!


&lt;or,&lt;and等我都不知道怎么用它???

雪山飞狐_lzh

DXF 参考手册帮助里就有

bai_cai101

谢谢你,

bai_cai101

我看了一下DXF帮助,但没有看到像&lt;or,&lt;and 之类的说明!!版主能否再给几个例子让我模仿一下!多谢你了!!比如我想将实体按颜色归入不同的图层!白色的实体(包括随层,随块颜色)放入图层"0",红色放入"细线"图层,