如何在插入块时根据输入的属性的不同来改变块的颜色？
我制作了一些块，其中有一两个属性，大家知道在插入块时会要求输入属性值，我想根据输入的属性值来自动设置块的颜色。比如属性如果为A颜色就为红色，为C颜色就为黄色等等。 我用下面的方法试了一下，但是它是事件触发后CAD才弹出修改块属性的对话框，而我是想修改好属性后才根据属性值来修改颜色的，请帮帮忙啦！不太好办，用我以前做的“永久反应器”试试 我又修改了那个例子，可以实现简单的功能，当插入或修改块属性时相应修改颜色。
但是当块有2个以上属性时不知为啥没有按照代码设置颜色。还有一个问题就是插入块的时候运行到
strAtt = ThisDrawing.Utility.GetString(True, vbCrLf & "Enter Value for " & varAttributes(I).TagString & ":")
的时候stratt的值会多出_.acad...(记不清了），所以就加了下面一句才行。
strAtt = ThisDrawing.Utility.GetString(False, "")
请高手看看。
Dim objBlock As AcadBlockReference
Dim strAtt As String
Private Sub AcadDocument_EndCommand(ByVal CommandName As String)
MsgBox CommandName
' 确认从设计中心的拖放操作
If CommandName = "DROPGEOM" Or CommandName = "INSERT" Or CommandName = "EATTEDIT" Then
Dim basePoint As Variant
Dim objItem As AcadObject
Dim ssetObj As AcadSelectionSet
' 创建新的选择集
Set ssetObj = ThisDrawing.SelectionSets.Add("ADCROT")
' 将拖放的对象添加到选择集中
ssetObj.Select acSelectionSetLast
' 如果对象并非块，则退出
For Each objItem In ssetObj
' 如果对象不是块
If Not objItem.ObjectName = "AcDbBlockReference" Then
' 删除选择集
ThisDrawing.SelectionSets.Item("ADCROT").Delete
' 退出
GoTo QuitNow
End If
Next objItem
'On Error GoTo 0
' 旋转选择集中的每个对象
For Each objItem In ssetObj
'修改
Dim varAttributes As Variant
varAttributes = objItem.GetAttributes
' Move the attribute tags and values into a string to be displayed in a Msgbox
'Dim strAttributes As String
Dim I As Integer
Dim color As AcadAcCmColor
Set color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
For I = LBound(varAttributes) To UBound(varAttributes)
If CommandName = "DROPGEOM" Then
strAtt = ThisDrawing.Utility.GetString(False, "")
strAtt = ThisDrawing.Utility.GetString(True, vbCrLf & "Enter Value for " & varAttributes(I).TagString & ":")
If Trim(strAtt) = "" Then
strAtt = varAttributes(I).TagString
End If
varAttributes(I).TextString = strAtt
End If
If varAttributes(I).TagString = "MEDIA" Then
color.ColorIndex = SetColorIndex(varAttributes(I).TextString)
objItem.TrueColor = color
End If
Next I
Next objItem
' 删除选择集
ThisDrawing.SelectionSets.Item("ADCROT").Delete
End If
QuitNow:
End Sub
Sub temp()
ThisDrawing.SelectionSets.Item("ADCROT").Delete
End Sub
Function SetColorIndex(Media As String) As Integer
Select Case Media
Case "CO2", "N"
SetColorIndex = 253
Case "F"
SetColorIndex = 52
Case "H"
SetColorIndex = 45
Case "P"
SetColorIndex = 255
Case "W"
SetColorIndex = 82
Case Else
End Select
End Function
页:
[1]