OberonPlace.com Forums

OberonPlace.com Forums (http://forum.oberonplace.com/index.php)
-   CorelDRAW/Corel DESIGNER VBA (http://forum.oberonplace.com/forumdisplay.php?f=16)
-   -   Color.UserAssignEx with Tab,Esc,Enter handling (http://forum.oberonplace.com/showthread.php?t=4439)

wOxxOm 12-12-2007 19:14

Color.UserAssignEx with Tab,Esc,Enter handling
here's my first attempt of making Color.UserAssign actually User-friendly by adding processing of Tab, ShiftTab, Enter, Escape hotkey handling into the dialog.

Currently the specified hotkeys work on all controls of the first page (Color Model) only.

Not implemented yet:
correct handling of hotkeys if a form is shown
hotkey handling on 2nd & 3rd dialog pages


dim clr as color
if wxColorUserAssignEx(clr, wxColorUAFocusName) then
' OK pressed, now clr has new color
' Cancel pressed

put the code below into a new Module

Option Explicit

Public Enum wxColorUAEnumFocus
  wxColorUAFocusName 'text name of colors combobox
  wxColorUAFocusComp1 'first color component
End Enum

Private lCBTHook&, hDlg&, idTimer&, lOldProc As Collection, T0!, hwndName&, hwndComp1&, hwndMixers&, hwndPalettes&, hFocusAt&

Private Declare Function UnhookWindowsHookEx& Lib "user32" (ByVal zMBX_Hook&)
Private Declare Function GetCurrentThreadId& Lib "kernel32" ()
Private Declare Function SetWindowsHookExW& Lib "user32" (ByVal idHook&, ByVal lpfn&, ByVal hmod&, ByVal dwThreadId&)
Private Declare Function CallNextHookEx& Lib "user32" (ByVal hhk&, ByVal nCode%, ByVal wParam&, ByVal lParam&)

Private Declare Function EnumChildWindows& Lib "user32" (ByVal hWndParent&, ByVal lpEnumFunc&, ByVal lParam&)
Private Declare Function IsWindowVisible Lib "user32" (ByVal hWnd&) As Integer
Private Declare Function GetDlgItem& Lib "user32" (ByVal hDlg&, ByVal ID&)
Private Declare Function SetFocus& Lib "user32" (ByVal hWnd&)
Private Declare Function GetParent& Lib "user32" (ByVal hWnd&)

Private Declare Function SetTimer& Lib "user32" (ByVal hWnd&, ByVal nID&, ByVal uElapse&, ByVal lpFunc&)
Private Declare Function KillTimer& Lib "user32" (ByVal hWnd&, ByVal uID&)

Private Declare Function PostMessageW& Lib "user32" (ByVal hWnd&, ByVal Msg As Integer, ByVal wParam&, ByVal lParam&)
Private Declare Function GetKeyState& Lib "user32" (ByVal vKey&)
Private Declare Function GetClassNameW Lib "user32" (ByVal hWnd&, ByVal lpwClassName&, ByVal nMaxCount%) As Long

Private Declare Function CallWindowProcW& Lib "user32" (ByVal lpPrevWndFunc&, ByVal hWnd&, ByVal uMsg&, ByVal wParam&, ByVal lParam&)

Function wxColorUserAssignEx _
                          (c As Color, _
                            Optional focusField As wxColorUAEnumFocus = wxColorUAFocusComp1, _
                            Optional lParentHwnd&) As Boolean

  Const WH_CBT& = 5, GWL_HINSTANCE& = -6
  T0 = Timer: hDlg = 0: hwndName = 0: hwndComp1 = 0: Set lOldProc = New Collection: hFocusAt = focusField
  lCBTHook = SetWindowsHookExW(WH_CBT, AddressOf CBTProc, GetWindowLongW(AppWindow.Handle, GWL_HINSTANCE), GetCurrentThreadId())
  wxColorUserAssignEx = c.UserAssignEx(lParentHwnd)
  End Function

Private _
Function CBTProc& _
  (ByVal Lmsg&, ByVal wParam&, ByVal lParam&)

  Dim s$, h&, hc&, ctls As Collection
  CBTProc = CallNextHookEx(lCBTHook, Lmsg, wParam, lParam)
  Select Case Lmsg
      Case 3 'HCBT_CREATEWND
                  If hDlg = 0 Then hDlg = wParam: Exit Function
      Case 5 'HCBT_ACTIVATE
                  If hDlg Then
                    If wParam = hDlg Then
                        idTimer = SetTimer(0, 0, 50, AddressOf TimerProc)
                        T0 = 0!
                    End If
                  End If
  End Select
  If Timer - T0 > 1! Then UnhookWindowsHookEx lCBTHook
  End Function

Private _
Sub TimerProc _
  (ByVal hWnd&, ByVal uMsg&, ByVal idEvent&, ByVal dwTime&)
  If IsWindowVisible(hDlg) Then
      EnumChildWindows hDlg, AddressOf EnumChildProc, 0
      Select Case hFocusAt
        Case wxColorUAFocusComp1
            If hwndComp1 Then
              SetFocus hwndComp1
              PostMessageW hwndComp1, &HB1, 0, -1 'EM_SETSEL
            End If
        Case wxColorUAFocusName
            If hwndName Then
              SetFocus hwndName
              PostMessageW GetParent(hwndName), &H14F, True, 0  'CB_SHOWDROPDOWN
            End If
      End Select
      KillTimer 0, idTimer: idTimer = -1
  End If
  End Sub

Private _
Function EnumChildProc& _
  (ByVal hWnd&, ByVal lParam&)
  lOldProc.Add GetWindowLongW(hWnd, -4), Hex$(hWnd)
  SetWindowLongW hWnd, -4, AddressOf DlgProc
  If hwndName = 0 Then
      If IsWindowVisible(hWnd) Then _
        If StrComp(apiGetClassName(hWnd), "Edit", 1) = 0 Then hwndName = hWnd
  ElseIf hwndComp1 = 0 Then
      If IsWindowVisible(hWnd) Then
        If StrComp(apiGetClassName(hWnd), "Edit", 1) = 0 Then
            If (GetWindowLongW(hWnd, -16) And &H800) = 0 Then ' ! ES_READONLY
              hwndComp1 = hWnd
            End If
        End If
      End If
  End If
  EnumChildProc = True
  End Function

Private _
Function DlgProc& _
  (ByVal hWnd&, ByVal uMsg&, ByVal wParam&, ByVal lParam&)

  DlgProc = CallWindowProcW(lOldProc(Hex$(hWnd)), hWnd, uMsg, wParam, lParam)
  Select Case uMsg
      Case &H100 'WM_KEYDOWN
        Select Case wParam
            Case vbKeyTab:
              wParam = GetKeyState(vbKeyShift) And &H8000
              PostMessageW hDlg, &H28, wParam, 0 'WM_NEXTDLGCTL
            Case vbKeyEscape: PostMessageW hDlg, &H10, 0, 0 'WM_CLOSE
            Case vbKeyReturn: lParam = SendMessageW(hDlg, &H400, 0, 0) And &HFFFF: 'DM_GETDEFID
                              PostMessageW hDlg, &H111, 1, GetDlgItem(hDlg, 1) 'WM_COMMAND
        End Select
      Case 2 'WM_DESTROY
        On Error Resume Next
        SetWindowLongW hWnd, -4, lOldProc(Hex$(hWnd))
  End Select
  End Function

Private _
Function apiGetClassName$ _
  (ByVal hWnd&)
  Dim L&: apiGetClassName = Space$(255): L = GetClassNameW(hWnd, StrPtr(apiGetClassName), 255)
  apiGetClassName = Left$(apiGetClassName, L)
  End Function

All times are GMT -5. The time now is 09:57.

Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2021, Jelsoft Enterprises Ltd.
Copyright © 2011, Oberonplace.com