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

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,807
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

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Hi Jaafar,

I think I have found an interesting bug when the RefEdit Textbox is called from a Modless Form. In the ShowForm code below you will see that the code is checking a Frm.Tag but the Object Being passed wouldn't have the .Tag as this is set only for the form in the CRefEdit because all of the references are ByVal.

If I have interpreted this incorrectly it would be great to know.

Code:
Public Sub ShowForm(ByVal Frm As Object, ByVal Show As Boolean)

    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 IsFormModal(Frm) 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.Select
    Else
        Call UnhookWindowsHookEx(hKBhook)
        hKBhook = 0
    End If


 End Sub
 
Upvote 0
In the ShowForm code below you will see that the code is checking a Frm.Tag but the Object Being passed wouldn't have the .Tag as this is set only for the form in the CRefEdit because all of the references are ByVal.

Despite the object being passed ByVal, the argument still points to the same object so the Tag value will still be there.

When passing Objects, ByVal will create a new variable as expected but this new variable will still hold the same memory address of the object being passed.

Code:
Option Explicit

Sub foo_ByRef(ByRef obj As Object)
    Debug.Print "(Passed ByRef ->)  VarPtr : " & VarPtr(obj) & vbTab & "ObjPtr : " & ObjPtr(obj)
End Sub

Sub foo_ByVal(ByVal obj As Object)
    Debug.Print "(Passed ByVal ->)  VarPtr : " & VarPtr(obj) & vbTab & "ObjPtr : " & ObjPtr(obj)
End Sub

Sub test()

    Dim X As Object
    
    Set X = Application
    Debug.Print "(Before function Call ->)  VarPtr : " & VarPtr(X) & vbTab & "ObjPtr : " & ObjPtr(X)
    Call foo_ByRef(X)
    Call foo_ByVal(X)

End Sub

Output :
Code:
(Before function Call ->)  VarPtr : [COLOR=#008000]2590705437584[/COLOR]   ObjPtr : [COLOR=#ff0000][B]2590600453328[/B][/COLOR]
(Passed ByRef ->)  VarPtr : [COLOR=#008000]2590705437584[/COLOR]   ObjPtr :  [COLOR=#ff0000][B]2590600453328[/B][/COLOR] 
(Passed ByVal ->)  VarPtr : [COLOR=#0000ff]2590705437488[/COLOR]   ObjPtr :  [COLOR=#ff0000][B]2590600453328[/B][/COLOR]



I think objects should be passed ByVal to avoid unnecessary issues as follows:
Code:
Option Explicit

Sub foo_ByRef(ByRef obj As Object)
    Set obj = ThisWorkbook
End Sub

Sub test2()

    Dim X As Object
    
    Set X = Application
    Debug.Print TypeName(X)
    Call foo_ByRef(X)
    Debug.Print TypeName(X)

End Sub

in my opinion, ByRef should be used for boolean flags like the Cancel argument in COM event handlers or if the situation arises where we want a function to return more than one value.
 
Last edited:
Upvote 0
Hi Jaafar,

Thank you for that bit of explanation. I didn't realize this and it is awesome to learn more. On to the bug that sent my down the path, why does this change seem to fix Excel not being able to be clicked into after closing the RefEdit Window when Modeless:
Was:
Code:
    If Frm.Tag Then EnableWindow Application.hwnd, 0
Is:
Code:
    If IsFormModal(Frm) Then EnableWindow Application.hwnd, 0

It seems like this should give the same True/False Cases.

Thank you,
 
Upvote 0
Hi,

When Modeless, I don't experience the issue you are describing. I can click into excel just fine.
In fact, the line : 'If Frm.Tag Then EnableWindow Application.hwnd, 0' can be omitted altogether because the Tag Property returns 0.

When Modal, the above line is there to make sure that the user cannot click into excel after closing the RefEdit which is what one should expect when using a Modal userform.

Regards.
 
Upvote 0
Hi,

I'm glad for this Alternative to RefEdit. Thank you!!!

My users should can do things like:

VBA Code:
A1&B1
VBA Code:
A1&" FreeText ("&B1&")"
VBA Code:
A1+B1
VBA Code:
A1-B1
VBA Code:
"*"&A1&"*Milk*"

The original xlDialogGoalSeek can do this.

What can I do? I know that users can destroy correct Ranges with this, but it's okay...

Hope you can help...

Thank You
 
Upvote 0
Hi,

I'm glad for this Alternative to RefEdit. Thank you!!!

My users should can do things like:

VBA Code:
A1&B1
VBA Code:
A1&" FreeText ("&B1&")"
VBA Code:
A1+B1
VBA Code:
A1-B1
VBA Code:
"*"&A1&"*Milk*"

The original xlDialogGoalSeek can do this.

What can I do? I know that users can destroy correct Ranges with this, but it's okay...

Hope you can help...

Thank You
Sorry, but I am not sure I understand what you mean.
 
Upvote 0
My users should use "RefEditAlternative" to pick up different Cells to generate a Result like above.

Such as: activate RefEditAlternative, pick up Cell A1, type & and pick up Cell B1 to get the result "A1&B1" in RefEditAlternative.

If you use xlDialogGoalSeek in original (without any modifications), you can activate "RefEdit" and do things like described.
 
Upvote 0
@Species8472

Here is an improved version which offers the choice to optionally edit the RefEdit text (allows Keyboard Input) , provides better quality of selection update, better error handling, handles the ESC and RETURN keys and works with Modal and Modless userforms.

Workbook Example:
AlternativeRefEdit._V2.xls







1- CRefEdit Class:
VBA Code:
Option Explicit

Private WithEvents oTextBox As MSForms.Textbox
Private oUF As Object
Private bEnableKeyBoardInput As Boolean


Public Sub TextBoxToRefEdit(ByVal Textbox As Object, Optional EnableKeyBoardInput As Boolean)
    Set oUF = GetParentForm(Textbox)
    oUF.Tag = IsFormModal(oUF)
    bEnableKeyBoardInput = EnableKeyBoardInput
    Set oTextBox = Textbox
    Textbox.DropButtonStyle = fmDropButtonStyleReduce
    Textbox.ShowDropButtonWhen = fmShowDropButtonWhenAlways
End Sub

Private Sub oTextBox_DropButtonClick()
    Call StoreTextboxWidth(oTextBox)
    Call ShowForm(oUF, False)
    Call ShowRefEdit(bEnableKeyBoardInput)
    Call ShowForm(oUF, True)
End Sub

Private Sub oTextBox_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If Not bEnableKeyBoardInput Then KeyCode = 0
End Sub

Private Function GetParentForm(ByVal Ctrl As Object) As Object
    Dim oTemp As Object
    On Error Resume Next
    Set oTemp = Ctrl.Parent
    Do While VBA.UserForms.Add(oTemp.Name) Is Nothing
        Set oTemp = oTemp.Parent
    Loop
    Set GetParentForm = oTemp
End Function


2- API bas Module
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 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)
            If InStr(1, oTextBox.text, "!") > 0 Then _
                Call SetWindowText(RefEditHwnd, oTextBox.text)
                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)
        oTextBox.text = VBA.Left(sBuffer3, lRet3)
        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)
                oTextBox.text = VBA.Left(sBuffer1, lRet1)
            End If
        Case WM_LBUTTONDOWN, WM_LBUTTONUP
            Call SetActiveWindow(Application.hwnd)
            Call PostMessage(hwnd, WM_CLOSE, 0, 0)
            oTextBox.text = VBA.Left(sBuffer1, lRet1)
        Case Is = WM_CLOSE
            Call SetWindowLong(hwnd, GWL_WNDPROC, lPrvWndProc)
            Call SetTimer(Application.hwnd, 0, 0, AddressOf SelectRange)
    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(oTextBox.text).Select
'    Debug.Print "Selection: "; Range(oTextBox.text).Address(, , , True)
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



3- Class Usage Example in UserForm Module:
VBA Code:
Option Explicit
 
Private RefEditsCollection As Collection

Private Sub UserForm_Activate()
 
    Dim AltRefEdit1 As CRefEdit
    Dim AltRefEdit2 As CRefEdit

    Set AltRefEdit1 = New CRefEdit
    Set AltRefEdit2 = New CRefEdit
  
    Set RefEditsCollection = New Collection
    RefEditsCollection.Add AltRefEdit1
    RefEditsCollection.Add AltRefEdit2

    Call AltRefEdit1.TextBoxToRefEdit(Textbox:=TextBox1, EnableKeyBoardInput:=False)
    Call AltRefEdit2.TextBoxToRefEdit(TextBox2, EnableKeyBoardInput:=True)

End Sub

Private Sub CommandButton1_Click()
    Call FeedBack(CommandButton1)
End Sub

Private Sub CommandButton2_Click()
    Call FeedBack(CommandButton2)
End Sub

Private Sub FeedBack(ByVal Btn As CommandButton)

    Dim oRng As Range
    Dim oTextBox As MSForms.Textbox
  
    On Error Resume Next
  
    Set oRng = Range(IIf(Btn Is CommandButton1, TextBox1, TextBox2))
    Set oTextBox = IIf(Btn Is CommandButton1, TextBox1, TextBox2)
  
    If Not oRng Is Nothing Then
        MsgBox "Selected Range With '" & oTextBox.Name & "':" _
                & vbNewLine & vbNewLine & oRng.Address(, , , True), vbInformation
    Else
        MsgBox "No Range Has Been Selected Or" & vbNewLine & _
                "The Range Address Is Invalid.", vbCritical, "ERROR !!"
    End If

End Sub
 
Upvote 0

Forum statistics

Threads
1,224,845
Messages
6,181,298
Members
453,030
Latest member
PG626

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