Информационный портал для профессионалов в области САПР
Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Форумы CADUser → Программирование → VBA → Как преобразовать Color в TrueColor?
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Здравствуйте, добрые люди! Такая вот задачка у меня... У СommonDialog есть свойство Color, а у слоя - TrueColor. Надо слою задать цвет, который вернулся из CommonDialog-a.
Чтобы получить color из TrueColor, есть функция RGB, а вот как обратно? Должно же быть это как-то возможно... Я в некоторой растерянности. Помогите, пожалуйста, кто знает. Буду очень благодарна...
> masha
Посмотри таблицу преобазования цветов здесь:
http://www.jtbworld.com/VBA/colorconversions.htm
а вообще легче использовать для этого
свойство ColorIndex, тогда не нужно ничего преобразовывать. См. Help
~'J'~
Попробуйй так, хотя я точно не помню какое значение принимает CommonDialog.Color
Dim colorObj As AcadAcCmColor
Set colorObj = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
Dim y As Long
y =CommonDialog.Color
colorObj.EntityColor = y
YourLayer.TrueColor = colorObjчего-то я пока не догоняю... :(((
Fatty, по ссылке - функция lookUpRGB принимает на вход Integer, а CommonDialog1.Color есть long, поэтому ругается на overflow. Про ColorIndex я читала, только не поняла, как мне из этого индекса RGB-компоненты вытащить?
Gogi, на сторчке colorObj.EntityColor = y говорит "invalid procedure or argument"
A tak ?
Dim colorObj As New AcadAcCmColor Dim y As Long y =CommonDialog.Color colorObj.EntityColor = y YourLayer.TrueColor = colorObj
Это я уже пробовала, результат тот же. :( Ну не может оно засунуть long в true color...
> masha
А преобразование типов данных?
~'J'~
A CAD [rus]kakoi? V 2007 v khelpe primer doslovno(u menja rabotaet):
[/rus]
Sub Example_EntityColor()
Dim color As AcadAcCmColor
Set color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
Dim y As Long
y = MakeLong(MakeWord(194, 122), MakeWord(133, 144))
color.EntityColor = y
Dim line As AcadLine
Set line = CreateLine
line.TrueColor = color
Dim retcolor As AcadAcCmColor
Set retcolor = line.TrueColor
Dim x As Long
x = retcolor.EntityColor
Dim BreakLong(3) As Byte
BreakLong(0) = x And &HFF&
BreakLong(1) = (x And &HFF00&) \ &H100&
BreakLong(2) = (x And &HFF0000) \ &H10000
BreakLong(3) = (x And &H7F000000) \ &H1000000
If x < 0 Then BreakLong(3) = BreakLong(3) Or &H80
MsgBox "ColorMethod = " & BreakLong(3) & vbCrLf & _
"Red = " & BreakLong(2) & vbCrLf & _
"Green = " & BreakLong(1) & vbCrLf & _
"Blue = " & BreakLong(0)
End Sub
Private Function CreateLine() As AcadLine
Dim lineObj As AcadLine
Dim startPoint(0 To 2) As Double
Dim endPoint(0 To 2) As Double
startPoint(0) = 1#: startPoint(1) = 1#: startPoint(2) = 0#
endPoint(0) = 5#: endPoint(1) = 5#: endPoint(2) = 0#
Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
Set CreateLine = lineObj
ZoomAll
End Function
Private Function MakeLong(WordHi As Variant, WordLo As Integer) As Long
' High word is coerced to a variant on the call, to allow
' it to overflow the limits of multiplication, which shifts
' it left.
MakeLong = (WordHi * &H10000) + (WordLo And &HFFFF&)
End Function
Private Function MakeWord(ByteHi As Byte, ByteLo As Byte) As Integer
' If the high byte would push the final result out of the
' signed integer range, it must be slid back.
If ByteHi > &H7F Then
MakeWord = ((ByteHi * &H100&) + ByteLo) - &H10000
Else
MakeWord = (ByteHi * &H100&) + ByteLo
End If
End Functionтипы мучать - пыталась... Ну, видимо, у меня руки как-то не так заточены. Пока не получается ничего хорошего из этой затеи. может, какое-то особо хитрое преобразование нужно?
Автокад - 2006. Впрочем, под 2007 тоже надо, чтоб работало. Сейчас буду пробовать следовать совету Gogi...
Вот вариант решение данной задачи. Есть код, который нам показал Fatty и есть функция, которая переводит из ACI в RGB. Теперь создаем массив конторлов которые могут менять свой цвет. потом задействуем пару форов для построения матрици цветов подобно той, что что в ACAD а не СommonDialog.
коды ACI в этой матрице расположены закономерно
[18][+10]
[16][+10]
..
[10][+10]
========
[11][+10]
[13][+10]
..
[19][+10]
Теперь окрас контрола мы спросим у функции lookUpRGB покрасим наш контрол.
p.s. Вариант рассматривать можно тем, кто работает как я, не на новых версиях и у кого нет таких прекрас как AcCmColor и чегото подобного, все решаем по старинке и работать будет везде :)
Спасибо большое!!! Версия от Gogi работает!!! Кстати, в своём хелпе я так и не обнаружила этого замечательного фрагмента... Насчёт версий - про раньше 2006 у меня речь не шла, так что сделаю, как проще. :)
Таблица перевода ACI в VBColor. Когда начал писать эту функцию сильно удивился т.к. объекты окрашивались в цвет отличный от RGB кода. Оказалось что VB для окрашивания объекта необходимо использовать BGR. Далее привожу таблицу перевода ACI в BGR. Данная функция использовалась для построения матрицы о которой я писал выше.
Public Function ACItoBGR(ByVal ACI As Integer) As String
Dim BGR As String
'vbObject.BackColor= "&H00" & BlueColor & GreenColor & RedColor & "&"
Select Case ACI
Case 0
BGR = 0
Case 1
BGR = "0000FF"
Case 2
BGR = "00FFFF"
Case 3
BGR = "00FF00"
Case 4
BGR = "FFFF00"
Case 5
BGR = "FF0000"
Case 6
BGR = "FF00FF"
Case 7
BGR = "FFFFFF"
Case 8
BGR = "808080"
Case 9
BGR = "C0C0C0"
Case 10
BGR = "0000FF"
Case 11
BGR = "7F7FFF"
Case 12
BGR = "0000CC"
Case 13
BGR = "6666CC"
Case 14
BGR = "000098"
Case 15
BGR = "4C4C98"
Case 16
BGR = "00007F"
Case 17
BGR = "3F3F7F"
Case 18
BGR = "00004C"
Case 19
BGR = "26264C"
Case 20
BGR = "003FFF"
Case 21
BGR = "7F9FFF"
Case 22
BGR = "0033CC"
Case 23
BGR = "667FCC"
Case 24
BGR = "002698"
Case 25
BGR = "4C5F98"
Case 26
BGR = "001F7F"
Case 27
BGR = "3F4F7F"
Case 28
BGR = "00134C"
Case 29
BGR = "262F4C"
Case 30
BGR = "007FFF"
Case 31
BGR = "7FBFFF"
Case 32
BGR = "0066CC"
Case 33
BGR = "6699CC"
Case 34
BGR = "004C98"
Case 35
BGR = "4C7298"
Case 36
BGR = "003F7F"
Case 37
BGR = "3F5F7F"
Case 38
BGR = "00264C"
Case 39
BGR = "26394C"
Case 40
BGR = "00BFFF"
Case 41
BGR = "7FDFFF"
Case 42
BGR = "0099CC"
Case 43
BGR = "66B2CC"
Case 44
BGR = "004C98"
Case 45
BGR = "4C8598"
Case 46
BGR = "005F7F"
Case 47
BGR = "3F6F7F"
Case 48
BGR = "00394C"
Case 49
BGR = "26424C"
Case 50
BGR = "00FFFF"
Case 51
BGR = "7FFFFF"
Case 52
BGR = "00CCCC"
Case 53
BGR = "66CCCC"
Case 54
BGR = "009898"
Case 55
BGR = "4C9898"
Case 56
BGR = "007F7F"
Case 57
BGR = "3F7F7F"
Case 58
BGR = "004C4C"
Case 59
BGR = "264C4C"
Case 60
BGR = "00FFBF"
Case 61
BGR = "7FFFDF"
Case 62
BGR = "00CC99"
Case 63
BGR = "66CCB2"
Case 64
BGR = "009872"
Case 65
BGR = "4C9885"
Case 66
BGR = "007F5F"
Case 67
BGR = "3F7F6F"
Case 68
BGR = "004C39"
Case 69
BGR = "264C42"
Case 70
BGR = "00FF7F"
Case 71
BGR = "7FFFBF"
Case 72
BGR = "00CC66"
Case 73
BGR = "66CC99"
Case 74
BGR = "00984C"
Case 75
BGR = "4C9872"
Case 76
BGR = "007F3F"
Case 77
BGR = "3F7F5F"
Case 78
BGR = "004C26"
Case 79
BGR = "264C39"
Case 80
BGR = "00FF3F"
Case 81
BGR = "7FFF9F"
Case 82
BGR = "00CC33"
Case 83
BGR = "66CC7F"
Case 84
BGR = "009826"
Case 85
BGR = "4C985F"
Case 86
BGR = "007F1F"
Case 87
BGR = "3F7F4F"
Case 88
BGR = "004C13"
Case 89
BGR = "264C2F"
Case 90
BGR = "00FF00"
Case 91
BGR = "7FFF7F"
Case 92
BGR = "00CC00"
Case 93
BGR = "66CC66"
Case 94
BGR = "009800"
Case 95
BGR = "4C984C"
Case 96
BGR = "007F00"
Case 97
BGR = "3F7F3F"
Case 98
BGR = "004C00"
Case 99
BGR = "264C26"
Case 100
BGR = "3FFF00"
Case 101
BGR = "9FFF7F"
Case 102
BGR = "33CC00"
Case 103
BGR = "7FCC66"
Case 104
BGR = "269800"
Case 105
BGR = "5F984C"
Case 106
BGR = "1F7F00"
Case 107
BGR = "4F7F3F"
Case 108
BGR = "134C00"
Case 109
BGR = "2F4C26"
Case 110
BGR = "7FFF00"
Case 111
BGR = "BFFF7F"
Case 112
BGR = "66CC00"
Case 113
BGR = "99CC66"
Case 114
BGR = "4C9800"
Case 115
BGR = "72984C"
Case 116
BGR = "3F7F00"
Case 117
BGR = "5F7F3F"
Case 118
BGR = "264C00"
Case 119
BGR = "394C26"
Case 120
BGR = "BFFF00"
Case 121
BGR = "DFFF7F"
Case 122
BGR = "99CC00"
Case 123
BGR = "B2CC66"
Case 124
BGR = "729800"
Case 125
BGR = "85984C"
Case 126
BGR = "5F7F00"
Case 127
BGR = "6F7F3F"
Case 128
BGR = "424C26"
Case 129
BGR = "424C26"
Case 130
BGR = "FFFF00"
Case 131
BGR = "FFFF7F"
Case 132
BGR = "CCCC00"
Case 133
BGR = "CCCC66"
Case 134
BGR = "989800"
Case 135
BGR = "98984C"
Case 136
BGR = "7F7F00"
Case 137
BGR = "7F7F3F"
Case 138
BGR = "4C4C00"
Case 139
BGR = "4C4C26"
Case 140
BGR = "FFBF00"
Case 141
BGR = "FFDF7F"
Case 142
BGR = "CC9900"
Case 143
BGR = "CCB266"
Case 144
BGR = "987200"
Case 145
BGR = "98854C"
Case 146
BGR = "7F5F00"
Case 147
BGR = "7F6F3F"
Case 148
BGR = "4C3900"
Case 149
BGR = "4C4226"
Case 150
BGR = "FF7F00"
Case 151
BGR = "FFBF7F"
Case 152
BGR = "CC6600"
Case 153
BGR = "CC9966"
Case 154
BGR = "984C00"
Case 155
BGR = "98724C"
Case 156
BGR = "7F3F00"
Case 157
BGR = "7F5F3F"
Case 158
BGR = "4C2600"
Case 159
BGR = "4C3926"
Case 160
BGR = "FF3F00"
Case 161
BGR = "FF9F7F"
Case 162
BGR = "CC3300"
Case 163
BGR = "CC7F66"
Case 164
BGR = "982600"
Case 165
BGR = "985F4C"
Case 166
BGR = "7F1F00"
Case 167
BGR = "7F4F3F"
Case 168
BGR = "4C1300"
Case 169
BGR = "4C2F26"
Case 170
BGR = "FF0000"
Case 171
BGR = "FF7F7F"
Case 172
BGR = "CC0000"
Case 173
BGR = "CC6666"
Case 174
BGR = "980000"
Case 175
BGR = "984C4C"
Case 176
BGR = "7F0000"
Case 177
BGR = "7F3F3F"
Case 178
BGR = "4C0000"
Case 179
BGR = "4C2626"
Case 180
BGR = "FF003F"
Case 181
BGR = "FF7F9F"
Case 182
BGR = "CC0033"
Case 183
BGR = "CC667F"
Case 184
BGR = "980026"
Case 185
BGR = "984C5F"
Case 186
BGR = "7F001F"
Case 187
BGR = "7F3F4F"
Case 188
BGR = "4C0013"
Case 189
BGR = "4C262F"
Case 190
BGR = "FF007F"
Case 191
BGR = "FF7FBF"
Case 192
BGR = "CC0066"
Case 193
BGR = "CC6699"
Case 194
BGR = "98004C"
Case 195
BGR = "984C72"
Case 196
BGR = "7F003F"
Case 197
BGR = "7F3F5F"
Case 198
BGR = "4C0026"
Case 199
BGR = "4C2639"
Case 200
BGR = "FF00BF"
Case 201
BGR = "FF7FDF"
Case 202
BGR = "CC0099"
Case 203
BGR = "CC66B2"
Case 204
BGR = "980072"
Case 205
BGR = "984C85"
Case 206
BGR = "7F005F"
Case 207
BGR = "7F3F6F"
Case 208
BGR = "4C0039"
Case 209
BGR = "4C2642"
Case 210
BGR = "FF00FF"
Case 211
BGR = "FF7FFF"
Case 212
BGR = "CC00CC"
Case 213
BGR = "CC66CC"
Case 214
BGR = "980098"
Case 215
BGR = "984C98"
Case 216
BGR = "7F007F"
Case 217
BGR = "7F3F7F"
Case 218
BGR = "4C004C"
Case 219
BGR = "4C264C"
Case 220
BGR = "BF00FF"
Case 221
BGR = "DF7FFF"
Case 222
BGR = "9900CC"
Case 223
BGR = "B266CC"
Case 224
BGR = "9900CC"
Case 225
BGR = "854C98"
Case 226
BGR = "5F007F"
Case 227
BGR = "6F3F7F"
Case 228
BGR = "39004C"
Case 229
BGR = "42264C"
Case 230
BGR = "7F00FF"
Case 231
BGR = "BF7FFF"
Case 232
BGR = "6600CC"
Case 233
BGR = "9966CC"
Case 234
BGR = "4C0098"
Case 235
BGR = "724C98"
Case 236
BGR = "3F007F"
Case 237
BGR = "5F3F7F"
Case 238
BGR = "26004C"
Case 239
BGR = "39264C"
Case 240
BGR = "3F00FF"
Case 241
BGR = "9F7FFF"
Case 242
BGR = "3300CC"
Case 243
BGR = "7F66CC"
Case 244
BGR = "260098"
Case 245
BGR = "5F4C98"
Case 246
BGR = "1F007F"
Case 247
BGR = "4F3F7F"
Case 248
BGR = "13004C"
Case 249
BGR = "2F264C"
Case 250
BGR = "333333"
Case 251
BGR = "5B5B5B"
Case 252
BGR = "848484"
Case 253
BGR = "ADADAD"
Case 254
BGR = "D6D6D6"
Case 255
BGR = "FFFFFF"
End Select
ACItoBGR = "&H00" & BGR
End Functionпример использования
Public LastColor As Integer
Private Sub Form_Load()
Dim cnt As Long
For cnt = 1 To 9
Load Picture1(cnt)
With Picture1(cnt)
'.Left = 330 * (cnt)
.Left = Picture1(cnt - 1).Left + 330
.Visible = True
.BackColor = ACItoBGR(cnt)
End With
Next
'...
End Sub
Public Sub Picture1_Click(Index As Integer)
Picture1(LastColor).Appearance = 0
Picture1(LastColor).BackColor = ACItoBGR(LastColor)
Picture1(Index).Appearance = 1
Picture1(Index).BackColor = ACItoBGR(Index)
LastColor = Index
End SubСтраницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Форумы CADUser → Программирование → VBA → Как преобразовать Color в TrueColor?
Форум работает на PunBB, при поддержке Informer Technologies, Inc
