| |
Translate to: |
|||||
| Обратная связь | Новости САПР | Программы | Документация | Полезные советы | Обзорные статьи | ||
| Заказ и разработка | Каталог САПР | САПР-конференция | Библиотека ГОСТов | Наши соавторы | Коммерческое ПО | ||
Для вызова диалогового окна "Выбор цвета" здесь используется API функция ChooseColor из файла comdlg32.dll. Поместите следующий код в стандартный модуль:
Option Explicit
Private Declare Function ChooseColor Lib _
"comdlg32.dll" Alias "ChooseColorA" _
(pColorChoice As ColorChoice) As Long
Private Type ColorChoice
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Function ShowColor() As Long
Dim udtClrPick As ColorChoice
Dim lReturn As Long
Dim intCnt As Integer
Dim bytColors() As Byte
udtClrPick.lStructSize = Len(udtClrPick)
ReDim bytColors(0 To 16 * 4 - 1) As Byte
For intCnt = LBound(bytColors) To UBound(bytColors)
bytColors(intCnt) = 0
Next
udtClrPick.lpCustColors = StrConv(bytColors, vbUnicode)
udtClrPick.flags = 0
If ChooseColor(udtClrPick) <> 0 Then
ShowColor = udtClrPick.rgbResult
bytColors = StrConv(udtClrPick.lpCustColors, _
vbFromUnicode)
Else
ShowColor = -1
End If
End Function
|
Теперь создайте форму с именем UserForm1 и поместите в ее модуль следующий код:
Option Explicit
Private Sub UserForm_Click()
Dim lngColor As Long
lngColor = ShowColor
If lngColor > -1 Then
Me.BackColor = lngColor
End If
End Sub
|
Теперь добавьте в стандартный модуль процедуру для запуска формы с именем UserForm1.
Запустите макросe: TEST_ChoiceColor. Если щелкнуть по появившейся форме будет отображено диалоговое окно "Цвет".
Выбранный в этом окне цвет будет присвоен цвету формы UserForm1.
Public Sub TEST_ChoiceColor() UserForm1.Show Unload UserForm1 End Sub |
Public Function AcColorToHex(intColor As Integer) As String
Select Case intColor
Case 1
AcColorToHex = Hex(RGB(255, 0, 0))
Case 2
AcColorToHex = Hex(RGB(255, 255, 0))
Case 3
AcColorToHex = Hex(RGB(0, 255, 0))
Case 4
AcColorToHex = Hex(RGB(0, 255, 255))
Case 5
AcColorToHex = Hex(RGB(0, 0, 255))
Case 6
AcColorToHex = Hex(RGB(255, 0, 255))
Case 7
AcColorToHex = Hex(RGB(255, 255, 255))
Case Else
AcColorToHex = "Non Standard color"
End Select
End Function
|
К моему сожалению, приведенная выше функция переводит в RGB только первые семь стандартных цветов AutoCAD. Думаю, что Вы были бы не прочь проделывать такую операцию со всеми доступными цветами, но использования этого метода породило бы процедуру, занимающую 5 страниц текста (цветов-то 256)! Но ведь имеется способ получить значения цветов в RGB с целых чисел цветов AutoCAD математически. Авторы этой процедуры не описали математический метод. Недостаток времени не позволяет мне заняться этим самому, может кто-нибуть попробует сделать это сам. Если у кого получится, напишите мне на E-Mail tb5@ugm.zsmk.ru. Конечно, для вывода математической закономерности знания значений RGB только для семи первых цветов не достаточно, вот список из первых 20 цветов в RGB
| Цвет AutoCAD | Значения составляющих RGB | ||
| R | G | B | |
| 1 |
255 |
0 |
0 |
| 2 |
255 |
255 |
0 |
| 3 |
0 |
255 |
0 |
| 4 |
0 |
255 |
255 |
| 5 |
0 |
0 |
255 |
| 6 |
255 |
0 |
255 |
| 7 |
255 |
255 |
255 |
| 8 |
65 |
65 |
65 |
| 9 |
128 |
128 |
128 |
| 10 |
255 |
0 |
0 |
| 11 |
255 |
170 |
170 |
| 12 |
189 |
0 |
0 |
| 13 |
189 |
126 |
126 |
| 14 |
129 |
0 |
0 |
| 15 |
129 |
86 |
86 |
| 16 |
104 |
0 |
0 |
| 17 |
104 |
69 |
69 |
| 18 |
79 |
0 |
0 |
| 19 |
79 |
53 |
53 |
| 20 |
255 |
63 |
0 |
Function GetRGB(ACI As Integer, Red As Integer, _
Green As Integer, Blue As Integer) As Long
'~~ Keith Baskette, 9/13/00
'~~ TERMS
'~~ ACI block - each group of 10 ACI values (10-19, 20-29, etc)
'~~ ACI range - group of blocks in which the primary, secondary, _
'And tertiary colors are constant (10-59, 60-89, etc)
'~~ primary color - color (red, green, or blue) with the highest value
'~~ secondary color - color with the middle value
'~~ tertiary color - color with the lowest value
'~~ VARIABLES AND THEIR USES
'~~ nbr, tracks how many steps have been taken within ACI block
'~~ bolAdd, TRUE if ACI range adds and FALSE if it subtracts from base
'~~ intBase, value at which where the ACI range starts (tens digit)
'~~ dblStart, the default value of the secondary color at the _
'beginning of the ACI range
'~~ intSign, positive for adding and negative for subtracting
'~~ dblFactor, the rate at which the values increase or decrease
'~~ dblA, the primary color for the ACI range
'~~ dblB, the secondary color for the ACI range
'~~ dblC, the tertiary color for the ACI range
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
Public Sub TEST_GetRGB()
UserForm1.Show
End Sub
|
Создайте форму с именем UserForm1 ипоместите в ее модуль следующий код:
Private Sub UserForm_Click()
Dim objAcEntity As AcadEntity
Dim varSelPt As Variant
Dim acColor As Integer
Dim intRgb_R As Integer
Dim intRgb_G As Integer
Dim intRgb_B As Integer
UserForm1.Hide
ThisDrawing.Utility.GetEntity objAcEntity, varSelPt, _
"Выберите объект для получении информации о его цвете: "
acColor = objAcEntity.color
Select Case acColor
Case 0
MsgBox "Цвет выбранного объекта - ByBlock"
Case 256
MsgBox "Цвет выбранного объекта - ByLayer"
Case 1 To 255
Me.BackColor = GetRGB(acColor, intRgb_R, intRgb_G, intRgb_B)
Case Else
MsgBox "Неверный цвет " & CStr(acColor)
End Select
UserForm1.Show
End Sub
|
Перед запуском TEST_GetRGB создайте в текущем чертеже несколько объектов и задайте им разные цвета. После запуска TEST_GetRGB будет отображена форма UserForm1. При щелчке по этой форме она будет скрываться, у пользователя будет запрошен примитив чертежа. После выбора примитива, если его цвет не равен ByBlock (По Блоку) или ByLayer (По слою), цвет формы делается таким-же как цвет объекта.
Copyright © Сайт поддержки пользователей САПР