Логотип сайта поддержки пользователей САПРО сайте поддержки пользователей САПР Translate to:

Работа с элементами управления

Выбор цвета

Выбор цвета в диалоговом окне с помощью функции API

Для вызова диалогового окна "Выбор цвета" здесь используется 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
 

Перевод стандартных цветов AutoCAD в формат RGB

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

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

Перевод цветов AutoCAD в формат RGB (учтены все 256 цветов)

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 © Сайт поддержки пользователей САПР by Victor Tkachenko