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

[Jaafar Tribak]

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 :

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

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 :

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.

 

[Riley Johnson]

Thank you @Jaafar Tribak, excited to explore and dig into some of these resources!

 

[Riley Johnson]

@Jaafar Tribak Thank you so much for making the Alternative RefEdit.

I've been working on a version of Goal Seek with additional options for sensitivity and the ability to run it on for multiple values. Your contribution was pivotal to this, and I'm excited to share the beta version with my team this week.

I'm not a professional coder, and this was the first project I've ever done in VBA, but I'm excited to keep learning. If you're interested, check this out: GoalSeekPlus.xlsm

I'm open to any feedback you have. Thnx!

Note: The file link will expire after 30 Days.

 

[Jaafar Tribak]

@Riley Johnson

I am glad the code was useful for your project. I haven't taken a proper look at your workbook yet, as it contains quite a large code and several modules.

and this was the first project I've ever done in VBA

That's quite impressive, being your first ever vba project. Well done.

And thanks for sharing your work

 

[Riley Johnson]

I am glad the code was useful for your project. I haven't taken a proper look at your workbook yet, as it contains quite a large code and several modules.

That's quite impressive, being your first ever vba project. Well done.

And thanks for sharing your work

Thanks @Jaafar Tribak

One thing that was tough was getting the textbox_change() events to work properly. I saw there was a string of messages a while ago in the blog that had a solution to fix that problem. I just hadn't had the time to go do it yet. So, as it stands, the code is a bit redundant with _exit() subs that call the main code in the _change() event subs. This was made to showcase the functionality but eventually delete the _exit() subs.

Open to any thoughts regarding a solution.

 

[Jaafar Tribak]

Hi Riley Johnson

Open to any thoughts regarding a solution.

I am not sure I understand. Which _change() events are you referring to?

 

[Riley Johnson]

Which _change() events are you referring to?

Hi @Jaafar Tribak,

Apologies for not being clear. I was referring to the _change() Event subs in frmGoalSeekPlus_v4. There should be a section titled "Control Change Subs." These are all of the _change() event subs that are specific to the Textbox controls, which are part of the cRefEdit class.

At my work, we use a single macro workbook stored on our server. We use the macros in the macro workbook via keyboard shortcuts which I assign with the Application.OnKey method. Thus, they can run GoalSeekPlus on whatever workbook they are working on. In some cases, when a user selects a range reference via the Drop Button and the range being referenced is not in the same workbook as all of the GoalSeekPlus modules, the _change() events don't always trigger. However, when the macros are stored in the workbook whose cells and ranges are being referenced for GoalSeekPlus, the _change() events seem to trigger every time.

Thus, to ensure that all user inputs are validated, I've included _exit() event subs for each of the Textbox controls that are instances of the cRefEdit class.

I've included some code snippets below from frmGoalSeekPlus_v4.

Overview of How the Modules are Related:

• mGoalSeekPlus_Run calls an modeless instance of frmGoalSeekPlus_v4.
• frmGoalSeekPlus_v4 contains all of the event code used to collect and validate the user's input. Its "Execute" command button calls function GoalSeekPlus in mGoalSeekPlus_SourceCode with all of the input supplied by the user.
• mGoalSeekPlus_SourceCode contains the function GoalSeekPlus, which loops through every scenario and runs Goal Seek. Function GoalSeekPlus also stores the outputs in an array and pastes the output array to the sheet.
• mRangeValidation is a module used by frmGoalSeekPlus_v4. It contains functions that validate whether or not a string or set of strings possesses certain properties of a reference to a sheet range.

frmGoalSeekPlus_v4 _change() Subs

[/B]
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                       CONTROL CHANGE SUBS
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub tbSetCell_change()
    statusSetCell = bSingleNumericFormulaCell(lblSetCell, tbSetCell)
End Sub

Sub tbToValues_change()
    statusToValues = bNumberOrNumericRange(lblToValue, tbToValues)
End Sub

Sub tbByChanging_change()
    statusByChanging = bSingleNumericCell(lblByChanging, tbByChanging)
End Sub

Sub tbA_change()
    statusA = bIsValuesRef(lblA, tbA, lblInputA, tbInputA)
    'If the values change and the input cell exists, retest all the values in the input cell
    If statusInputA Then tbInputA_change
End Sub

Sub tbInputA_change()
    statusInputA = bInputValuesTest(lblInputA, tbInputA, lblA, tbA, statusA)
End Sub

Sub tbB_change()
    statusB = bIsValuesRef(lblB, tbB, lblInputB, tbInputB)
    'If the values change and the input cell exists, retest all the values in the input cell
    If statusInputB Then tbInputB_change
End Sub

Sub tbInputB_change()
    statusInputB = bInputValuesTest(lblInputB, tbInputB, lblB, tbB, statusB)
End Sub

Sub tbSelectOutputs_change()

    statusSelectOutputs = False

    If Not (statusSetCell And statusToValues And statusByChanging) Then
        showError lblSelectOutput, tbSelectOutputs, "Need to give Set Cell, To Value[s], By Changing first."

    ElseIf bSingleCell(lblSelectOutput, tbSelectOutputs) Then
        
        statusSelectOutputs = True
        
        If Not bOutputRangeEmpty(tbSelectOutputs.Value) Then
            statusWritesOverData = True
            showError lblSelectOutput, tbSelectOutputs, "Warning: Output will write over data."
            
        Else
            statusWritesOverData = False
            endError lblSelectOutput, tbSelectOutputs
        
        End If

    End If
    
End Sub
[B]

frmGoalSeekPlus_v4 _exit() Subs

[/B][/B]
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                       CONTROL EXIT SUBS
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub tbSetCell_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    Call tbSetCell_change
End Sub

Sub tbToValues_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    Call tbToValues_change
End Sub

Sub tbByChanging_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    Call tbByChanging_change
End Sub

Sub tbA_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    Call tbA_change
End Sub

Sub tbInputA_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    Call tbInputA_change
End Sub

Sub tbB_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    Call tbB_change
End Sub

Sub tbInputB_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    Call tbInputB_change
End Sub

Sub tbSelectOutputs_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    Call tbSelectOutputs_change
End Sub
[B][B]

 

[Jaafar Tribak]

@Riley Johnson
Ok- I understand. I see that this TextBox event bug was reported earlier in this thread but I couldn't replicate the issue myself. The code works fine for me as it stands. I tested it in xl2013 and xl2016.
Nevertheless, I have edited the class as well the userform codes so that now, the textboxes change events are sinked inside the Class module. I hope this code version will now work for you.
File Demo:
GoalSeekPlus_ExampleFile_Edited.xlsm