Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,807
- Office Version
- 2016
- Platform
- 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 :
2- Code in the UserForm module
3- Main code in a Standard module :
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.
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 Sub2- 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 Sub3- 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 FunctionThis 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:
