ChooseColor ! предварительные настройки

Private Const TOOLTIP_WARNING_ICON = 3
Private Const TOOLTIP_ERROR_ICON = 2
Private Const TOOLTIP_INFO_ICON = 1

If Title <> vbNullString Then 'если мы хотим, чтобы был заголовок или значок
            SendMessage mHwnd, TTM_SETTITLE, TOOLTIP_INFO_ICON, ByVal Title
        End If

'----------------------------------------------------------[ Enums ]
Public Enum ttStyleEnum
    TTStandard
    TTBalloon
End Enum
 
Public Enum ttDelayTimeConstants 'Константы времени задержки
    [Задержка по умолчанию] = 0
    [Повторный просмотр] = 1
    [Задержка показа] = 2
    [Начальная задержка] = 3
End Enum
 
Public Enum ttIconsConst 'Отображение иконок
    [Восклецательный знак] = 3
    [Знак ошибки] = 2
    [Важная информация] = 1
End Enum

Event Help(NameControl$, Title$, Message$, ttIcon%)
 
Private Sub Is_Help(Obj As Object, Button As Integer)
    Dim Title$, Message$, ttIcon%
    If Button = 2 Then
        Title = Obj.Caption
        RaiseEvent Help(Obj.Name, Title$, Message, ttIcon)
        If Len(Message) Then
            mToolTip.Create Obj.hwnd, Title, Message, TTBalloon, ttIcon
        End If
    End If
End Sub

Private Sub dlgColor1_Help(NameControl As String, Title As String, Message As String, ttIcon As Integer)
    '
    '   Пример возникновения события подсказки и вызова окна с сообщением
    '
    ttIcon = 2
     If NameControl = "Command1" Then
        Message = "вызванна из dlgColor1"
    End If
End Sub

Public Enum ttIconsConst 'Отображение иконок
    [Важная информация] = 1
    [Восклецательный знак] = 2
    [Знак ошибки] = 3
End Enum

Declare Function MoveWindow Lib "user32.dll" (ByVal hwnd As _
Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As _
Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
 
' hWnd это окна диалога
retval = MoveWindow(hWnd, 200, 150, 175, 300, 1)

Option Explicit
 
Public Type tagChooseColor
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As Long
    flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
 
Public Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As tagChooseColor) As Long
Public Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
 
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOZORDER = &H4
Public Const CC_ENABLEHOOK = &H10&
Public Const WM_INITDIALOG = &H110
 
Public CustomColor(15) As Long
 
Public Function ColorDlg(ByVal hWnd As Long, Ret As Long) As Boolean
    Dim cc As tagChooseColor
    
    cc.lStructSize = Len(cc)
    cc.hwndOwner = hWnd
    cc.lpCustColors = VarPtr(CustomColor(0))
    cc.flags = CC_ENABLEHOOK
    cc.lpfnHook = GetAddr(AddressOf CCHookProc)
    
    ColorDlg = ChooseColor(cc)
    
    Ret = cc.rgbResult
End Function
Public Function CCHookProc(ByVal hWnd As Long, ByVal uiMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case uiMsg
    Case WM_INITDIALOG
        Dim x As Long, y As Long
        x = 1000: y = 0 ' Çàäàåì ïîçèöèþ
        SetWindowPos hWnd, 0, x, y, 0, 0, SWP_NOZORDER Or SWP_NOSIZE
    End Select
End Function
 
Public Function GetAddr(ByVal Addr As Long) As Long
    GetAddr = Addr
End Function

Option Explicit
 
Public Type tagChooseColor
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As Long
    flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As tagChooseColor) As Long
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Public Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
 
Public Const GWL_ID = (-12)
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOZORDER = &H4
Public Const CC_ENABLEHOOK = &H10&
Public Const WM_INITDIALOG = &H110
Public Const WM_COMMAND = &H111
Public Const WM_DESTROY = &H2
 
Public Const IDOK = 1
Public Const IDCANCEL = 2
Public Const IDMYBUTTON = 12345
 
Public CustomColor(15) As Long
 
Dim cmd As CommandButton
 
Public Function ColorDlg(ByVal hwnd As Long, Ret As Long) As Boolean
    Dim cc As tagChooseColor
    
    cc.lStructSize = Len(cc)
    cc.hwndOwner = hwnd
    cc.lpCustColors = VarPtr(CustomColor(0))
    cc.flags = CC_ENABLEHOOK
    cc.lpfnHook = GetAddr(AddressOf CCHookProc)
    
    ColorDlg = ChooseColor(cc)
    
    Ret = cc.rgbResult
End Function
Public Function CCHookProc(ByVal hwnd As Long, ByVal uiMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case uiMsg
    Case WM_INITDIALOG
        Dim hOk As Long, hCancel As Long, hMy As Long, _
            rc As RECT, w As Long, h As Long, x As Long, _
            y As Long
        
        Set cmd = frmMain.Controls.Add("VB.CommandButton", "cmd")
        cmd.Visible = True
        cmd.Caption = "Кликни!"
        
        SetParent cmd.hwnd, hwnd
        SetWindowLong cmd.hwnd, GWL_ID, IDMYBUTTON
        
        hOk = GetDlgItem(hwnd, IDOK)
        hCancel = GetDlgItem(hwnd, IDCANCEL)
        hMy = cmd.hwnd
        GetClientRect hwnd, rc
        y = rc.Bottom
        w = rc.Right - rc.Left
        w = (w - 4) \ 3
        h = 23
        y = y - h - 4
        
        SetWindowPos hOk, 0, 4, y, w - 4, h, SWP_NOZORDER
        SetWindowPos hCancel, 0, 4 + w, y, w - 4, h, SWP_NOZORDER
        SetWindowPos hMy, 0, 4 + w * 2, y, w - 4, h, SWP_NOZORDER
    Case WM_COMMAND
        Select Case wParam
        Case IDMYBUTTON
            MsgBox "Привет FelixMacintosh!"
            CCHookProc = 1
        End Select
    Case WM_DESTROY
        frmMain.Controls.Remove ("cmd")
        Set cmd = Nothing
    End Select
End Function
 
Public Function GetAddr(ByVal Addr As Long) As Long
    GetAddr = Addr
End Function