OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Developer Forums > VBA > CorelDRAW/Corel DESIGNER VBA

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 12-12-2007, 19:14
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default 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

Usage:
Code:
dim clr as color
........
if wxColorUserAssignEx(clr, wxColorUAFocusName) then
' OK pressed, now clr has new color
else
' Cancel pressed
endif
wxColorUserAssignEx
put the code below into a new Module
Code:
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

Last edited by wOxxOm; 12-12-2007 at 19:29.
Reply With Quote
Reply


Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)
 
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is Off

Forum Jump

Similar Threads
Thread Thread Starter Forum Replies Last Post
Color.UserAssignEx??? masterchiefph CorelDRAW/Corel DESIGNER VBA 2 10-07-2007 21:50
Handling objects on Master Pages akayani CorelDRAW/Corel DESIGNER VBA 6 27-03-2006 18:16


All times are GMT -5. The time now is 16:00.


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