home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / vbPainter-2107903302008.psc / Class / ColorDlg.cls < prev    next >
Text File  |  2006-01-15  |  5KB  |  193 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "CFDialog"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. ' CFDialog  ColorDlg.cls   Color Dialog
  15. ' From vbAccelerator.com
  16.  
  17. Option Explicit
  18.  
  19. ' EG Color
  20. 'Dim CF As CFDialog
  21. 'Dim TheColor As Long
  22. '   Set CF = New CFDialog
  23. '   If CF.VBChooseColor(TheColor, , , , Me.hwnd) Then
  24. '   DrawColor = TheColor
  25. '   Set CF = Nothing
  26.  
  27.  
  28. 'Public Enum EErrorCommonDialog
  29. '    eeBaseCommonDialog = 13450  ' CommonDialog
  30. 'End Enum
  31.  
  32. Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
  33. 'Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
  34. '    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
  35. Private Declare Sub CopyMemoryStr Lib "kernel32" Alias "RtlMoveMemory" ( _
  36.     lpvDest As Any, ByVal lpvSource As String, ByVal cbCopy As Long)
  37.  
  38. Private Type TCHOOSECOLOR
  39.     lStructSize As Long
  40.     hWndOwner As Long
  41.     hInstance As Long
  42.     rgbResult As Long
  43.     lpCustColors As Long
  44.     flags As Long
  45.     lCustData As Long
  46.     lpfnHook As Long
  47.     lpTemplateName As Long
  48. End Type
  49.  
  50. Private Declare Function ChooseColor Lib "comdlg32.dll" Alias _
  51. "ChooseColorA" (pChoosecolor As TCHOOSECOLOR) As Long
  52.  
  53. Public Enum EChooseColor
  54.     CC_RGBInit = &H1
  55.     CC_FullOpen = &H2
  56.     CC_PreventFullOpen = &H4
  57.     CC_ColorShowHelp = &H8
  58. ' Win95 only
  59.     CC_SolidColor = &H80
  60.     CC_AnyColor = &H100
  61. ' End Win95 only
  62.     CC_ENABLEHOOK = &H10
  63.     CC_ENABLETEMPLATE = &H20
  64.     CC_EnableTemplateHandle = &H40
  65. End Enum
  66. Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
  67.  
  68.  
  69.  
  70. Private Declare Function CommDlgExtendedError Lib "COMDLG32" () As Long
  71.  
  72. ' Array of custom colors lasts for life of app
  73. Private alCustom(0 To 15) As Long, fNotFirst As Boolean
  74.  
  75. Private m_lApiReturn As Long
  76. Private m_lExtendedError As Long
  77.  
  78. 'Public Property Get APIReturn() As Long
  79. '    'return object's APIReturn property
  80. '    APIReturn = m_lApiReturn
  81. 'End Property
  82. 'Public Property Get ExtendedError() As Long
  83. '    'return object's ExtendedError property
  84. '    ExtendedError = m_lExtendedError
  85. 'End Property
  86.  
  87. '#If fComponent Then
  88. Private Sub Class_Initialize()
  89.     InitColors
  90. End Sub
  91. '#End If
  92.  
  93. '' ChooseColor wrapper
  94. Function VBChooseColor(Color As Long, _
  95.                        Optional AnyColor As Boolean = True, _
  96.                        Optional FullOpen As Boolean = False, _
  97.                        Optional DisableFullOpen As Boolean = False, _
  98.                        Optional owner As Long = -1, _
  99.                        Optional flags As Long) As Boolean
  100.  
  101.     Dim chclr As TCHOOSECOLOR
  102.     chclr.lStructSize = Len(chclr)
  103.  
  104.     ' Color must get reference variable to receive result
  105.     ' Flags can get reference variable or constant with bit flags
  106.     ' Owner can take handle of owning window
  107.     If owner <> -1 Then chclr.hWndOwner = owner
  108.  
  109.     ' Assign color (default uninitialized value of zero is good default)
  110.     chclr.rgbResult = Color
  111.  
  112.     ' Mask out unwanted bits
  113.     Dim afMask As Long
  114.     afMask = CLng(Not (CC_ENABLEHOOK Or _
  115.                        CC_ENABLETEMPLATE))
  116.     ' Pass in flags
  117.     chclr.flags = afMask And (CC_RGBInit Or _
  118.                   IIf(AnyColor, CC_AnyColor, CC_SolidColor) Or _
  119.                   (-FullOpen * CC_FullOpen) Or _
  120.                   (-DisableFullOpen * CC_PreventFullOpen))
  121.  
  122.     ' If first time, initialize to white
  123.     If fNotFirst = False Then InitColors
  124.  
  125.     chclr.lpCustColors = VarPtr(alCustom(0))
  126.     ' All other fields zero
  127.  
  128.     m_lApiReturn = ChooseColor(chclr)
  129.     
  130.     Select Case m_lApiReturn
  131.     Case 1
  132.         ' Success
  133.         VBChooseColor = True
  134.         Color = chclr.rgbResult
  135.     Case 0
  136.         ' Cancelled
  137.         VBChooseColor = False
  138.         Color = -1
  139.     Case Else
  140.         ' Extended error
  141.         m_lExtendedError = CommDlgExtendedError()
  142.         VBChooseColor = False
  143.         Color = -1
  144.     End Select
  145.  
  146. End Function
  147.  
  148. Private Sub InitColors()
  149.     Dim i As Long
  150.     ' Initialize with first 16 system interface colors
  151.     For i = 0 To 15
  152.         alCustom(i) = GetSysColor(i)
  153.     Next
  154.     fNotFirst = True
  155. End Sub
  156.  
  157.  
  158. Private Sub StrToBytes(ab() As Byte, S As String)
  159.     If IsArrayEmpty(ab) Then
  160.         ' Assign to empty array
  161.         ab = StrConv(S, vbFromUnicode)
  162.     Else
  163.         Dim cab As Long
  164.         ' Copy to existing array, padding or truncating if necessary
  165.         cab = UBound(ab) - LBound(ab) + 1
  166.         If Len(S) < cab Then S = S & String$(cab - Len(S), 0)
  167.         'If UnicodeTypeLib Then
  168.         '    Dim st As String
  169.         '    st = StrConv(s, vbFromUnicode)
  170.         '    CopyMemoryStr ab(LBound(ab)), st, cab
  171.         'Else
  172.             CopyMemoryStr ab(LBound(ab)), S, cab
  173.         'End If
  174.     End If
  175. End Sub
  176.  
  177.  
  178. Private Function BytesToStr(ab() As Byte) As String
  179.     BytesToStr = StrConv(ab, vbUnicode)
  180. End Function
  181.  
  182. Private Function IsArrayEmpty(va As Variant) As Boolean
  183.     Dim v As Variant
  184.     On Error Resume Next
  185.     v = va(LBound(va))
  186.     IsArrayEmpty = (Err <> 0)
  187. End Function
  188.  
  189.  
  190.  
  191.  
  192.  
  193.