Cool RefEdit Alternative - (Made with a standard TextBox !)

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,656
Office Version
  1. 2016
Platform
  1. Windows
Hi all.

In a previous thread ,our member Jon Von Der Heyden kindly brought my attention to this recent blog by (John Peltier) about using RefEdit control alternatives. This is what gave me the idea to work on the solution I am providing here.

We know all too well how buggy and unreliable the RefEdit Control is yet it has a nice functionality.

John Peltier's alternative is based on the use of a standard textbox with a DropDown click button but the way he went about it is not , in my humble opinion, elegant or practical as one still has to go through an annoying intermediate Excel InputBox which just seems too clumsy and kind of defeats the whole purpose.(you can see this by downloading his workbook example from the above blog link)

Here, I provide a large improvement on John Peltier's solution. It is based on the same idea but it is far closer to the real RefEdit feel, look and functionality.Obviously more complex code is involved.

Workbook Demo.

Project code : (Needs a UserForm, 2 Buttons and 1 TextBox)

Add a Class module to the Project and give it the name of : (CRefEdit)

1- Class code :
Code:
Option Explicit
 
Private WithEvents TextBoxDropButton_Click As MSForms.TextBox
 
Private WithEvents WbEvents As Workbook
 
Private Sub Class_Initialize()
 
    Set WbEvents = ThisWorkbook
 
End Sub
                             [B][COLOR=seagreen]'Remove the Red[/COLOR][/B] [COLOR=red][B]*[/B][/COLOR]
Private Sub TextBoxDropButton_Click_DropButton[COLOR=red][B]*[/B][/COLOR]Click() 
 
    Call ShowWindow(FindWindow("ThunderDFrame", vbNullString), 0)
    Call StartHook(True)
    Call ShowWindow(FindWindow("ThunderDFrame", vbNullString), 1)
 
End Sub
 
Public Sub TransformTextBoxIntoRefEdit _
(ByVal TextBox As MSForms.TextBox)
 
    Set TextBoxDropButton_Click = TextBox
    Set oTextBox = TextBoxDropButton_Click
    TextBox.DropButtonStyle = fmDropButtonStyleReduce
    TextBox.ShowDropButtonWhen = fmShowDropButtonWhenAlways
 
End Sub
 
Private Sub WbEvents_BeforeClose(Cancel As Boolean)
 
    SendMessage lInputBoxhwnd, WM_CLOSE, 0, 0
 
End Sub

2- Code in the UserForm module

Code:
Option Explicit
 
Private MyRefEditClass As CRefEdit
 
Private Sub UserForm_Activate()
 
    Set MyRefEditClass = New CRefEdit
 
    MyRefEditClass.TransformTextBoxIntoRefEdit TextBox1
 
End Sub
 
Private Sub CommandButton1_Click()
 
        MsgBox "You selected range : " & vbNewLine _
        & sRangeAddress, vbInformation
 
End Sub
 
Private Sub CommandButton2_Click()
 
    Unload Me
 
End Sub
 
Private Sub UserForm_Terminate()
 
    sRangeAddress = ""
 
End Sub

3- Main code in a Standard module :

Code:
Option Explicit
 
[COLOR=seagreen]'\\ Private declarations.[/COLOR]
[COLOR=seagreen]'=========================[/COLOR]
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long
 
Private Declare Function FindWindowEx Lib "user32.dll" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
 
Private Declare Function GetWindow Lib "user32.dll" _
(ByVal hwnd As Long, ByVal wCmd As Long) As Long
 
Private Declare Function GetWindowRect Lib "user32.dll" _
(ByVal hwnd As Long, ByRef lpRect As RECT) As Long
 
Private Declare Function GetClientRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpRect As RECT) As Long
 
Private Declare Function SetWindowsHookEx Lib _
"user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
 
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
 
Private Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, _
ByVal ncode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
 
Private Declare Function GetCurrentThreadId _
Lib "kernel32" () As Long
 
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
 
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
 
Private Declare Function GetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
 
Private Declare Function GetWindowText Lib "user32" _
Alias "GetWindowTextA" _
(ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) As Long
 
Private 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
 
Private Declare Function CreateWindowEx Lib "user32" _
Alias "CreateWindowExA" _
(ByVal dwExStyle As Long, ByVal lpClassName As String, _
ByVal lpWindowName _
As String, ByVal dwStyle As Long, ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hWndParent As Long, _
ByVal hMenu As Long, ByVal hInstance As Long, _
lpParam As Any) As Long
 
Private Declare Function SetParent Lib "user32.dll" _
(ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
 
Private Declare Function GetDC Lib "user32.dll" _
(ByVal hwnd As Long) As Long
 
Private Declare Function GetDeviceCaps Lib "gdi32.dll" _
(ByVal hdc As Long, _
ByVal nIndex As Long) As Long
 
Private Const WH_CBT As Long = 5
Private Const GWL_WNDPROC As Long = -4
Private Const HCBT_ACTIVATE As Long = 5
Private Const GW_CHILD As Long = 5
Private Const SWP_NOSIZE As Long = &H1
Private Const SWP_NOMOVE As Long = &H2
Private Const SM_CYCAPTION As Long = 4
Private Const LOGPIXELSY As Long = 90
Private Const WS_CHILD As Long = &H40000000
Private Const WS_EX_CLIENTEDGE As Long = &H200&
Private Const WM_LBUTTONDOWN As Long = &H201
 
Private lhHook As Long
Private bHookEnabled As Boolean
Private lCustomBtnHwnd As Long
Private EditBoxhwnd As Long
Private lPrvWndProc As Long
 
[COLOR=seagreen]'\\ Public declarations.[/COLOR]
[COLOR=seagreen]'=========================[/COLOR]
Public Declare Function FindWindow Lib "user32.dll" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
 
Public Declare Function ShowWindow Lib "user32.dll" _
(ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
 
Public Declare Function SendMessage Lib "user32.dll" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByRef lParam As Any) As Long
 
Public Const WM_CLOSE As Long = &H10
 
Public lInputBoxhwnd As Long
Public sRangeAddress As String
Public oTextBox As MSForms.TextBox
 
Sub StartHook(Dummy As Boolean)
 
    Dim sBuffer As String
    Dim lRet As Long
    Dim lhwnd As Long
    Dim sFormCaption As String
 
    lhwnd = FindWindow("ThunderDFrame", vbNullString)
    sBuffer = Space(256)
    lRet = GetWindowText(lhwnd, sBuffer, 256)
    sFormCaption = Left(sBuffer, lRet)
    If Not bHookEnabled Then
        lhHook = SetWindowsHookEx _
        (WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId)
        bHookEnabled = True
        Application.InputBox "", sFormCaption, Type:=8
    End If
 
End Sub
 
Private Sub TerminateHook()
 
    UnhookWindowsHookEx lhHook
    bHookEnabled = False
 
End Sub
 
Private Function HookProc _
(ByVal idHook As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
 
 
    Dim tRect1 As RECT
    Dim tRect2 As RECT
    Dim sBuffer As String
    Dim PixelPerInch As Single
    Dim lRetVal As Long
 
 
    On Error Resume Next
 
    If idHook = HCBT_ACTIVATE Then
        sBuffer = Space(256)
        lRetVal = GetClassName(wParam, sBuffer, 256)
        If Left(sBuffer, lRetVal) = "bosa_sdm_XL9" Then
            lInputBoxhwnd = wParam
            PixelPerInch = _
            GetDeviceCaps(GetDC(0), LOGPIXELSY) / 72
            EditBoxhwnd = GetWindow(wParam, GW_CHILD)
            GetClientRect wParam, tRect1
            Call TerminateHook
            SetWindowPos EditBoxhwnd, 0, 2, 0, _
            0, 0, SWP_NOSIZE
            GetWindowRect EditBoxhwnd, tRect2
            SetWindowPos wParam, 0, 0, 0, _
            tRect1.Right - tRect1.Left, _
            (tRect2.Bottom - tRect2.Top) * PixelPerInch + _
            GetSystemMetrics(SM_CYCAPTION) _
            + GetSystemMetrics(6) * 2, SWP_NOMOVE
            With tRect2
                lCustomBtnHwnd = CreateWindowEx _
                (WS_EX_CLIENTEDGE, "Button", "...", WS_CHILD, _
                255, 0, _
                (tRect1.Right - tRect1.Left) _
                - (.Right - .Left) + 10, _
                .Bottom - .Top + 4, wParam, 0, 0, 0)
            End With
            SetParent lCustomBtnHwnd, wParam
            ShowWindow lCustomBtnHwnd, 1
            lPrvWndProc = SetWindowLong _
            (lCustomBtnHwnd, GWL_WNDPROC, AddressOf CallBack)
        End If
    End If
 
    HookProc = CallNextHookEx _
    (lhHook, idHook, ByVal wParam, ByVal lParam)
 
End Function
 
Private Function CallBack _
(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
 
    Dim sBuffer As String
    Dim lRet As Long
 
    On Error Resume Next
 
    Select Case Msg
        Case Is = WM_LBUTTONDOWN
            sBuffer = Space(256)
            lRet = GetWindowText(EditBoxhwnd, sBuffer, 256)
            If InStr(1, Left(sBuffer, lRet), "!") Then
                sRangeAddress = Left(sBuffer, lRet)
            Else
                sRangeAddress = ActiveSheet.Name & "!" & _
                Left(sBuffer, lRet)
            End If
            oTextBox.Text = sRangeAddress
            SendMessage lInputBoxhwnd, WM_CLOSE, 0, 0
    End Select
 
    CallBack = CallWindowProc _
    (lPrvWndProc, hwnd, Msg, wParam, ByVal lParam)
 
End Function

This works on the activesheet, on different sheets and on other open workbooks.

Also, thanks to placing the code into a Class, one can have multiple TextBoxes simultaniously transformed into RefEdit-like controls not just one textbox.

I am still looking to improve a bit the look of the Collapsing Button and hope to post an update soon.

Worde well in Excel2003 Win XP. Not tested on other versions.
 
Last edited:

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Thank you.
With new version, TextBox_Change-Event doesn't fired by my Excel...

Try this variant :
AlternativeRefEdit._V2.xls


Modified bas API code:
VBA Code:
Option Explicit
 
Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrW" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    #End If
    Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Any, ByVal Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hKBhook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hKBhook As LongPtr) As Long
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String) As Long
    Private Declare PtrSafe Function SetActiveWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function EnableWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal fEnable As Long) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongPtr

    Private hCBTHook As LongPtr, hKBhook As LongPtr, lPrvWndProc As LongPtr, RefEditHwnd As LongPtr, hwndFrm As LongPtr
#Else
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Any, ByVal Source As Any, ByVal Length As Long)
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private 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
    Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hKBhook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hKBhook As Long) As Long
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function SetActiveWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function GetFocus Lib "user32" () As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

    Private hCBTHook As Long, hKBhook As Long, lPrvWndProc As Long, RefEditHwnd As Long, hwndFrm As Long
#End If

Private dblTextboxwidth As Double
Private oTextBox As Object
Private sTextBoxText As String
Private bEnableKeyBoardInput As Boolean



'____________________________________________PUBLIC ROUTINES_________________________________________
Public Sub ShowForm(ByVal Frm As Object, ByVal Show As Boolean)

    Const GWL_EXSTYLE = (-20)
    Const WH_KEYBOARD = 2
    Const WS_EX_LAYERED = &H80000
    Const LWA_ALPHA = &H2&

    Call SetWindowLong(hwndFrm, GWL_EXSTYLE, GetWindowLong(hwndFrm, GWL_EXSTYLE) Or WS_EX_LAYERED)
    Call SetLayeredWindowAttributes(hwndFrm, 0, IIf(Show = False, 0, 255), LWA_ALPHA)
    Call SetActiveWindow(Application.hwnd)
    Call ShowWindow(hwndFrm, -CLng(Show))
    If Frm.Tag Then EnableWindow Application.hwnd, 0
   
    If Show = False Then
        If hKBhook = 0 Then
            hKBhook = SetWindowsHookEx(WH_KEYBOARD, AddressOf KeyboardProc, _
            GetModuleHandle(vbNullString), GetCurrentThreadId)
        End If
        ActiveWindow.RangeSelection.Cells(1).Select
    Else
        Call UnhookWindowsHookEx(hKBhook)
        hKBhook = 0
    End If

 End Sub

Public Sub ShowRefEdit(ByVal EnableKeyBoardInput As Boolean)
 
    #If Win64 Then
        Dim lVBEhwnd As LongLong
    #Else
        Dim lVBEhwnd As Long
    #End If
   
    Const WH_CBT = 5
    Dim sBuffer As String
    Dim lRet As Long
   
    lVBEhwnd = FindWindow("wndclass_desked_gsk", vbNullString)
    Call ShowWindow(lVBEhwnd, 0)
    sBuffer = VBA.Space(256)
    lRet = GetWindowText(hwndFrm, sBuffer, 256)
    bEnableKeyBoardInput = EnableKeyBoardInput
    If hCBTHook = 0 Then
        hCBTHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId)
    End If
    DoEvents
    Call Application.Dialogs(xlDialogGoalSeek).Show
    bEnableKeyBoardInput = False
    Call EnableWindow(Application.hwnd, True)
 
End Sub

Public Sub StoreTextboxWidth(ByVal Textbox As Object)
    Set oTextBox = Textbox
    dblTextboxwidth = Textbox.Width
End Sub

Public Function IsFormModal(Frm As Object) As Boolean
    IsFormModal = Not CBool(SetFocus(Application.hwnd))
    Call IUnknown_GetWindow(Frm, VarPtr(hwndFrm))
    Call SetFocus(hwndFrm)
End Function


'____________________________________________PRIVATE ROUTINES_________________________________________
Private Sub TerminateHook()
    Call UnhookWindowsHookEx(hCBTHook)
    Call EnableWindow(Application.hwnd, True)
    hCBTHook = 0
End Sub
 
#If Win64 Then
    Private Function HookProc(ByVal idHook As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
     Dim lp As LongLong
#Else
    Private Function HookProc(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
     Dim lp As Long
#End If
 
    Const HCBT_ACTIVATE = 5
    Const GWL_WNDPROC = -4
    Const GWL_EXSTYLE = (-20)
    Const WS_EX_CONTEXTHELP = &H400
    Const SWP_SHOWWINDOW = &H40
    Const SWP_NOACTIVATE = &H10
    Const GW_CHILD = 5
    Const MK_LBUTTON = &H1
    Const WM_LBUTTONUP = &H202
    Const WM_LBUTTONDOWN = &H201
 
    Dim tFrmRect As RECT, tRefRect As RECT
    Dim p1 As POINTAPI, p2 As POINTAPI
    Dim sBuffer As String
    Dim PixelPerInch As Single
    Dim lRet As Long
   
    If idHook = HCBT_ACTIVATE Then
        sBuffer = VBA.Space(256)
        lRet = GetClassName(wParam, sBuffer, 256)
        If VBA.Left(sBuffer, lRet) = "bosa_sdm_XL9" Then
            Call TerminateHook
            RefEditHwnd = GetWindow(wParam, GW_CHILD)
            Call GetWindowRect(hwndFrm, tFrmRect)
            Call GetWindowRect(RefEditHwnd, tRefRect)
            With tRefRect
                p1.x = .Left: p1.y = .Top
                p2.x = .Right + 15: p2.y = .Bottom
            End With
            Call ScreenToClient(wParam, p1)
            Call ScreenToClient(wParam, p2)
            lp = MakeLong_32_64(p2.x, p1.y)
            With tFrmRect
                Call SetWindowPos(wParam, -1, .Left, .Top, _
                       PTtoPX(dblTextboxwidth, False), 0, SWP_SHOWWINDOW + SWP_NOACTIVATE)
            End With
            Call SetWindowLong(wParam, GWL_EXSTYLE, _
                   GetWindowLong(wParam, GWL_EXSTYLE) And Not WS_EX_CONTEXTHELP)
            Call PostMessage(RefEditHwnd, WM_LBUTTONDOWN, MK_LBUTTON, lp)
            Call PostMessage(RefEditHwnd, WM_LBUTTONUP, MK_LBUTTON, lp)
            lPrvWndProc = SetWindowLong(wParam, GWL_WNDPROC, AddressOf CallBack)
        End If
    End If
 
    HookProc = CallNextHookEx(hCBTHook, idHook, ByVal wParam, ByVal lParam)
 
End Function

#If Win64 Then
    Private Function KeyboardProc(ByVal ncode As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
#Else
    Private Function KeyboardProc(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If

    Const HC_ACTION = 0
    Const WM_KEYDOWN = &H100
    Const WM_KEYUP = &H101

    If ncode = HC_ACTION Then
        If wParam = vbKeyEscape Or wParam = vbKeyReturn Then
            Call PostMessage(RefEditHwnd, WM_KEYDOWN, wParam, 0)
            Call PostMessage(RefEditHwnd, WM_KEYUP, wParam, 0)
            Call ShowWindow(RefEditHwnd, False)
            DoEvents
            Exit Function
        End If
         If bEnableKeyBoardInput = False Then
            KeyboardProc = -1
            Exit Function
            End If
    End If

    KeyboardProc = CallNextHookEx(hKBhook, ncode, wParam, lParam)
   
End Function

#If Win64 Then
    Private Function CallBack(ByVal hwnd As LongLong, ByVal Msg As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
#Else
    Private Function CallBack(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
 
    Const GWL_WNDPROC = -4
    Const WM_LBUTTONDOWN = &H201
    Const WM_LBUTTONUP = &H202
    Const WM_SYSCOMMAND = &H112
    Const WM_CLOSE As Long = &H10
    Const SC_CLOSE = &HF060&
 
    Dim sBuffer1 As String, sBuffer2 As String, sBuffer3 As String
    Dim lRet1 As Long, lRet2 As Long, lRet3 As Long
    
    sBuffer1 = VBA.Space(256): sBuffer2 = VBA.Space(256)
    lRet1 = GetWindowText(RefEditHwnd, sBuffer1, 256): lRet2 = GetWindowText(hwnd, sBuffer2, 256)
  
    If InStr(1, VBA.Left(sBuffer1, lRet1), "!") = 0 Then
        Call SetWindowText(RefEditHwnd, ActiveSheet.Name & "!" & VBA.Left(sBuffer1, lRet1))
    End If
   
    If VBA.Left(sBuffer2, lRet2) <> "RefEditEx" Then
        Call SetWindowText(hwnd, "RefEditEx")
    End If

    If GetAsyncKeyState(VBA.vbKeyReturn) Or GetAsyncKeyState(VBA.vbKeySeparator) Then
        sBuffer3 = VBA.Space(256)
        lRet3 = GetWindowText(RefEditHwnd, sBuffer3, 256)
        sTextBoxText = VBA.Left(sBuffer3, lRet3)
        Call SetTimer(Application.hwnd, 0, 100, AddressOf SelectRange)
        Call PostMessage(hwnd, WM_CLOSE, 0, 0)
    End If
   
    If GetAsyncKeyState(VBA.vbKeyEscape) Then
        Call PostMessage(hwnd, WM_CLOSE, 0, 0)
    End If

    Select Case Msg
        Case Is = WM_SYSCOMMAND
            If wParam = SC_CLOSE Then
                ShowWindow hwnd, 0
                Call SetActiveWindow(Application.hwnd)
                Call PostMessage(hwnd, WM_CLOSE, 0, 0)
                sTextBoxText = VBA.Left(sBuffer1, lRet1)
                Call SetTimer(Application.hwnd, 0, 0, AddressOf SelectRange)
            End If
        Case WM_LBUTTONDOWN, WM_LBUTTONUP
            Call SetActiveWindow(Application.hwnd)
            Call PostMessage(hwnd, WM_CLOSE, 0, 0)
            sTextBoxText = VBA.Left(sBuffer1, lRet1)
            Call SetTimer(Application.hwnd, 0, 0, AddressOf SelectRange)
        Case Is = WM_CLOSE
            Call SetWindowLong(hwnd, GWL_WNDPROC, lPrvWndProc)
    End Select

    CallBack = CallWindowProc(lPrvWndProc, hwnd, Msg, wParam, ByVal lParam)
 
End Function

Private Sub SelectRange()
    Call KillTimer(Application.hwnd, 0)
    On Error Resume Next
    Range(sTextBoxText).Select
    oTextBox.Text = sTextBoxText
    sTextBoxText = vbNullString
End Sub

#If Win64 Then
    Function MakeLong_32_64(ByVal wLow As Long, ByVal wHigh As Long) As LongPtr
    Dim retVal As LongLong, b(3) As Byte
   
    Call MoveMemory(ByVal VarPtr(b(0)), ByVal VarPtr(wLow), 4)
    Call MoveMemory(ByVal VarPtr(b(2)), ByVal VarPtr(wHigh), 4)
    Call MoveMemory(ByVal VarPtr(retVal), ByVal VarPtr(b(0)), 8)
    MakeLong_32_64 = retVal
#Else
    Function MakeLong_32_64(ByVal wLow As Integer, ByVal wHigh As Integer) As Long
    Dim retVal As Long, b(3) As Byte
   
    Call MoveMemory(ByVal VarPtr(b(0)), ByVal VarPtr(wLow), 2)
    Call MoveMemory(ByVal VarPtr(b(2)), ByVal VarPtr(wHigh), 2)
    Call MoveMemory(ByVal VarPtr(retVal), ByVal VarPtr(b(0)), 4)
    MakeLong_32_64 = retVal
#End If
    End Function
   
Private Function ScreenDPI(bVert As Boolean) As Long

    Const LOGPIXELSX = 88
    Const LOGPIXELSY = 90

    Static lDPI(1), lDC

    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
   
End Function
 
Private Function PTtoPX(Points As Double, bVert As Boolean) As Long
    Const POINTS_PER_INCH = 72
    PTtoPX = Points * ScreenDPI(bVert) / POINTS_PER_INCH
End Function

Codes in the CRefEdit Class and UserForm stay the same.
 
Upvote 0
Hi Jaafar,

Thank you for making this code available. I have been reading through it and testing it over the last few days. I'm curious if you would have an opinion on how to implement some new functionality.

If the user has the focus on a TextBox of the CRefEdit class and hits F2, I would like the same code in oTextBox_DropButtonClick() to run. That way, the alternative refEdits are more keyboard-friendly.
 
Upvote 0
If the user has the focus on a TextBox of the CRefEdit class and hits F2, I would like the same code in oTextBox_DropButtonClick() to run.
Sorry for responding late.

Just edit the oTextBox_KeyDown event routine located in the CRefEdit class module as follows:

VBA Code:
Private Sub oTextBox_KeyDown(ByVal KeyCode As msforms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = VBA.vbKeyF2 Then Call oTextBox_DropButtonClick
    If Not bEnableKeyBoardInput Then KeyCode = 0
End Sub
 
Upvote 0
Sorry for responding late.
You are all good! I'll give this a go! I was thinking of adding something new to the class, but was not sure if that was a good idea because of your prior thread with wsDAH.

I'm just curious: How does the textbox retain the modifications added to it by the CRefEdit Class? I'm having a tough time understanding what's going on.

My thought was that upon initialization, there's a Userform with TextBoxes. In the Userform activation event, the CRefEdit Class is called like "control wrapper" that changes the properties of the TextBox. I was thinking it's some kind of wrapper because whenever you access the value of the Textbox, you still use TextboxName.value, not reTextboxName.Value (Such that reTextboxName is the CRefEdit instance used for that textbox).

So, because of this, I thought I wouldn't need to have the RefEdit collection with all the instances of the CRefEdit "wrappers." But when I didn't include those lines in the Userform activation event, I lost the functionality of clicking the drop-down button and having the xlDialogGoalSeek pop up so I could reference some cells.

So, is there some kind of inheritance going on? Does the TextBox inherit the functionality of the CRefEdit Class and the source code (basAPI) when the instance is in scope? It just seems strange because the behavior implies that the CRefEdit is the superclass of the subclass Textbox modified by the CRefEdit instance. Is this the right thinking?
 
Upvote 0
There isn't any inheritance going on. Each Class instance hooks its own textbox events (DropButtonClick and KeyDown) . So everytime the drop-down button is clicked, the class executes the corresponding routines that are located in the bas module and whose job is to simply resize and move the native xlDialogGoalSeekclass based on the underlying textbox size and location.

Once the refEdit is dismissed, the underlying textbox retains the address of the range that was selected by calling the *SelectRange* routine from the *CallBack* function.
 
Last edited:
Upvote 0
@Jaafar Tribak

First off thank you so much for the F2 functionality recommendation. Works like a charm. Second, I apologize for not getting back sooner. Still getting use to my first job and adjusting to work life after school. Time management for these side projects is a big one on the To Figure Out list.

I'm unfamiliar with hooks, but have been revisiting Techopedia to reread this article, link. I also found this post on Stack Overflow and noticed the reference to Subclassing and Hooking with Visual Basic (O'Reilly, 2001). I ordered it as it seems like learning hooks could be useful to extend the functionality of objects in VBA. I'm curious, are there any other resources that you would recommend? How did you learn hooks and what use cases have you found for them in VBA other than this project?
 
Upvote 0
@Riley Johnson
I'm unfamiliar with hooks, but have been revisiting Techopedia to reread this article, link.
The explanation in that article sums up pretty much what hooks are about and explains the subject very well.

That's a good book. I purchased it back in the early 2000s . There is also this more comprehensive and in-depth Dan Applemans's book about programming the win32 api with visual basic.

it seems like learning hooks could be useful to extend the functionality of objects in VBA.
Essencially, Hooks as well as subclassing are both about intercepting/modifying/redirecting windows messages.

Here is an extract from the book prologue:
Windows is a message-based system. Every action you request creates one or more messages to carry out the action. These messages are passed between objects and carry with them information that gives the recipient more detail on how to interpret and act upon the message.With Subclassing and the Windows hooking mechanism ("hooks"), you can manipulate, modify, or even discard messages bound for other objects within the operating system, in the process changing the way the system behaves. What kinds of results can you achieve using the power of subclassing and hooking? Here are just a few of the possibilities:

  • Determine when a window is being activated or deactivated and respond to this change.
  • Display descriptions of menu items as the mouse moves across them.
  • Disallow a user to move or resize a window.
  • Determine where the mouse cursor is and respond accordingly.
  • Determine when the display resolution has been changed.
  • Monitor the system for a low system resource condition.
  • Modify or disallow keystrokes sent to a window or a control.
  • Create an automated testing application.
  • Determine when an application is idle.
Along with this power comes responsibility; Windows is very unforgiving if subclassing and hooking are used incorrectly. Subclassing & Hooking with Visual Basic demonstrates the various techniques for intercepting messages bound for one or more windows or controls: the intercepted message can be left in its original state or modified; afterwards, the message can be sent to its original destination or discarded.For both VB 6 and VB.NET developers, Subclassing & Hooking with Visual Basic opens up a wealth of possibilities that ordinarily would be completely unavailable, or at least not easy to implement.

I'm curious, are there any other resources that you would recommend?
Nowadays, Internet programming forums are, in my opinion, the best palce to look for help and learning.

How did you learn hooks and what use cases have you found for them in VBA other than this project?
I have learnt (and still learning) from reading books such as the one you mentioned above and from visiting programming forums, asking questions and reading answers. Lots of trial and error and endless application crashes :)

I and others have used hooks and subclassing in many vba projects to accomplish certain tasks that are otherwise not possible to accomplish using the excel object model. Mainly for trapping events that office applications don't provide such as detecting wheel mouse scrolling, trapping keystrokes, monitoring mouse moves, working with custom menus and many many more.

If you do a search in this forum or in google with the following keywords:
GWL_WNDPROC, WH_CBT, HCBT_ACTIVATE, HCBT_SYSCOMMAND, WH_MSGFILTER, WH_GETMESSAGE, WH_CALLWNDPROC, WH_MOUSE, WH_KEYBOARD, WH_SHELL, SetWindowLong, CallWindowProc, DefWindowProc, SetWindowSubclass, SetWindowsHookEx, SetWinEventHook, AddressOf etc ... , you will find plenty of examples where hooking and/or subclassing were used in VB/VBA.

Regards.
 
Last edited:
Upvote 0

Forum statistics

Threads
1,216,499
Messages
6,131,012
Members
449,613
Latest member
MedDash99

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top