关于颜色的经典VBA自定义函数【CAD-vba】

时　间:2012-05-30 09:17:50
作　者:欢乐小爪   ID：20149  城市：杭州
摘　要:关于颜色的经典VBA自定义函数【CAD-vba】
正　文:

Public Function ACI2RGB(ByVal intACI As Integer) As Long
Dim col As New AcadAcCmColor
col.ColorIndex = intACI
ACI2RGB = RGB(col.Red, col.Green, col.Blue)
End Function

cad索引颜色值换算成vba颜色值

Public Function RGB2ACI(ByVal lngRGB As Long) As Integer
Dim col As New AcadAcCmColor
Dim r As Byte, g As Byte, b As Byte
'split color into rgb components
r = (lngRGB Mod 256 ^ 2) Mod 256
g = (lngRGB Mod 256 ^ 2) \ 256
b = lngRGB \ 256 ^ 2
col.SetRGB r, g, b
RGB2ACI = col.ColorIndex
End Function

得到3色的值

Function GetRGB(ACI As Integer, Red As Integer, _
Green As Integer, Blue As Integer) As Long

Dim nbr As Double
nbr = Right(ACI, 1) / 2

Dim bolAdd As Boolean, intBase As Integer
Select Case ACI
Case Is < 1
MsgBox "Invalid ACI number (0-255 valid)."
Exit Function
Case Is < 10: GoTo SkipCalc
Case Is < 60: bolAdd = True: intBase = 1
Case Is < 90: bolAdd = False: intBase = 6
Case Is < 140: bolAdd = True: intBase = 9
Case Is < 170: bolAdd = False: intBase = 14
Case Is < 220: bolAdd = True: intBase = 17
Case Is < 250: bolAdd = False: intBase = 22
Case Is < 256: GoTo SkipCalc
Case Else
MsgBox "Invalid ACI number (0-255 valid)."
Exit Function
End Select

Dim dblStart As Double
If bolAdd Then
dblStart = IIf(nbr = Int(nbr), 0, 0.5)
Else
dblStart = IIf(nbr = Int(nbr), 0.75, 0.875)
End If

Dim intSign As Integer, dblFactor As Double
intSign = IIf(bolAdd, 1, -1)
dblFactor = IIf(nbr = Int(nbr), 0.25, 0.125)

Dim dblA As Double, dblB As Double, dblC As Double
dblA = Choose(Fix(nbr) + 1, 1, 0.65, 0.5, 0.3, 0.15)
dblB = (dblStart + intSign * _
(Left(ACI, Len(CStr(ACI)) - 1) - intBase) * dblFactor) * dblA
dblC = ((2 * nbr) Mod 2) * 0.5 * dblA

SkipCalc:
Select Case ACI
Case 1: Red = 255: Green = 0: Blue = 0
Case 2: Red = 255: Green = 255: Blue = 0
Case 3: Red = 0: Green = 255: Blue = 0
Case 4: Red = 0: Green = 255: Blue = 255
Case 5: Red = 0: Green = 0: Blue = 255
Case 6: Red = 255: Green = 0: Blue = 255
Case 7, 8, 9
Red = 0: Green = 0: Blue = 0
Case Is < 60
Red = 255 * dblA: Green = 255 * dblB: Blue = 255 * dblC
Case Is < 90
Red = 255 * dblB: Green = 255 * dblA: Blue = 255 * dblC
Case Is < 140
Red = 255 * dblC: Green = 255 * dblA: Blue = 255 * dblB
Case Is < 170
Red = 255 * dblC: Green = 255 * dblB: Blue = 255 * dblA
Case Is < 220
Red = 255 * dblB: Green = 255 * dblC: Blue = 255 * dblA
Case Is < 250
Red = 255 * dblA: Green = 255 * dblC: Blue = 255 * dblB
Case Is < 256
Red = 255 * Choose(nbr * 2 + 1, 0.33, 0.464, _
0.598, 0.732, 0.866, 1)
Green = Red: Blue = Red
End Select

GetRGB = RGB(Red, Green, Blue)
End Function