userform loop for hiding and unhiding through multiple sequences - excel

So i have this string of code... It is in a userform and is all vba based (IE not pulling data from a spreadsheet.)
Private Sub CHECK1_Click()
If CHECK1.value = False Then
COMBO1.visible = False
Else
COMBO1.visible = True
End If
End Sub
It works for perfectly for exactly one checkbox and combobox pair, I need it to work on all 61 on of them, individually... Being new to this I looked at case select possability but it looks like i would have to spell in out.
the userform is called "ORDER1"
All of the check boxes are named "CHECK1" THROUGH "CHECK61"
They all correspond to the combobox' aptly named "COMBO1" THROUGH "COMBO61"
(CHECK1=COMBO1 throguh the entire form.)
How can I make this work without putting 61 'click' events into the code?
oh and I'm on excel 2010

In the comments there's already a "control array" with WithEvents as a possible solution, below I'll show another solution without the WithEvents:
Copy this code to Notepad and save it as CatchEvents.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "CatchEvents"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
#If VBA7 And Win64 Then
Private Declare PtrSafe Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, _
ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, _
Optional ByVal ppcpOut As LongPtr) As Long
#Else
Private Declare Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, _
ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As Long) As Long
#End If
'All Other Control-Events also possible
'No need to use WithEvents
'No need to put every Type of control in seperate collection or array, each event will fire no matter which control,
'so in the eventcode controls can be separated from others
'you can give your controls additional properties
'Arguments as Cancel, KeyCode, KeyAscii , Button , x and Y still can be used
Private EventGuide As GUID
Private Ck As Long
Private ctl As Object
Private CustomProp As String
Public Sub MyListClick()
Attribute MyListClick.VB_UserMemId = -610
If TypeName(ctl) = "CheckBox" Then
ctl.Parent.Controls(Replace(ctl.Name, "CHECK", "COMBO")).Visible = ctl.Value
End If
End Sub
Public Sub ConnectAllEvents(ByVal Connect As Boolean)
With EventGuide
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
ConnectToConnectionPoint Me, EventGuide, Connect, ctl, Ck, 0&
End Sub
Public Property Let Item(Ctrl As Object)
Set ctl = Ctrl
Call ConnectAllEvents(True)
End Property
Public Sub Clear()
If (Ck <> 0) Then Call ConnectAllEvents(False)
Set ctl = Nothing
End Sub
In the VBA-editor right click somewhere on your Project and choose Import file, a Class named CatchEvents will now be in your Class Modules.
Finally paste code below behind your Userform:
Private AllControls() As New CatchEvents
Private Sub UserForm_Initialize()
Dim j As Long
ReDim AllControls(Controls.Count - 1)
For j = 0 To Controls.Count - 1
AllControls(j).Item = Controls(j)
Next
End Sub
Private Sub UserForm_Terminate()
Dim j As Long
For j = LBound(AllControls) To UBound(AllControls)
AllControls(j).Clear
Next j
Erase AllControls
End Sub

Related

Best way to activate an unsaved workbook

I have various code to create reports. The reports are added to a new workbook that does not get saved, the theory being that the user can choose whether to save the workbook or just close it after looking at the results. My code below will activate the unsaved workbook.
Sub ActivateWorkbook(wbResults As Workbook)
Dim objWindow As Window
With Application
.VBE.MainWindow.WindowState = vbext_ws_Minimize
For Each objWindow In .Windows
With objWindow
If .Caption <> wbResults.Name Then .WindowState = xlMinimized
End With
Next objWindow
With .Windows(wbResults.Name)
.WindowState = xlMaximized
.Activate
End With
End With
End Sub
This works okay with a single monitor. But if there is already more than one workbook and they are different monitors, it minimises windows in both (all) monitors and looks less than ideal. I am thinking that if I am able to identify which monitor has the active workbook, I could only minimize windows for that monitor (including the VBE, if required).
In reply to chris neilsen, I will include some basic code to illustrate what I'm calling the above procedure with. Please keep in mind that each procedure is varied in purpose and most of the code in each doesn't really pertain to this particular problem.
Sub ExampleCode()
Dim wbXXX As Workbook
Set wbXXX = Workbooks.Add
With wbXXX
'Main code here
End With
Call ActivateWorkbook(wbXXX)
Set wbXXX = Nothing
End Sub
Thanks to anybody trying to help. It is appreciated.
Okay, this seems to be working for me. It's not pretty. Note that "Microsoft Visual Basic for Applications Extensibility 5.3" is required to minimise the VBE, which is where the code is being run from, not the main Excel application. In any case, Activate has not worked for me reliably in the past. If it works for you, no need for any of this I guess. If anybody is game to test it, please let me know how you go. I have only tested on a dual monitor setup so far.
Objective: Show the new workbook in the same monitor as the active workbook when Activate does not work.
Private Declare PtrSafe Function FindWindow _
Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) _
As LongPtr
Private Declare PtrSafe Function MonitorFromWindow _
Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal dwFlags As Long) _
As LongPtr
Private Declare PtrSafe Function EnumDisplayMonitors _
Lib "user32.dll" _
(ByVal hdc As Long, _
ByRef lprcClip As Any, _
ByVal lpfnEnum As Long, _
ByVal dwData As Long) _
As Long
Private Declare PtrSafe Function GetSystemMetrics _
Lib "user32" _
(ByVal Index As Long) _
As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const MONITOR_DEFAULTTONEAREST = &H2
Private Const SM_CMONITORS As Long = 80
Private hWndMonitor As LongPtr
Private hActiveWorkbook As LongPtr
Private hVBE As LongPtr
Private lngMode As Long
Function MonitorCount() As Long
MonitorCount = GetSystemMetrics(SM_CMONITORS)
End Function
Function MonitorsAreTheSame() As Boolean
MonitorsAreTheSame = True
'Count of monitors
If MonitorCount > 1 Then
'Check the ActiveWorkbook
lngMode = 0
hWndMonitor = FindWindow("XLMAIN", Application.Caption)
EnumDisplayMonitors ByVal 0&, ByVal 0&, AddressOf MonitorEnumProc, ByVal 0&
'Check the VBE
lngMode = 1
hWndMonitor = FindWindow("wndclass_desked_gsk", Application.VBE.MainWindow.Caption)
EnumDisplayMonitors ByVal 0&, ByVal 0&, AddressOf MonitorEnumProc, ByVal 0&
MonitorsAreTheSame = CBool(hActiveWorkbook = hVBE)
End If
End Function
Private Function MonitorEnumProc(ByVal hMonitor As Long, ByVal hdcMonitor As Long, lprcMonitor As RECT, ByVal dwData As Long) As Long
If MonitorFromWindow(hWndMonitor, MONITOR_DEFAULTTONEAREST) = hMonitor Then
Select Case lngMode
Case 0
hActiveWorkbook = CStr(hMonitor)
Case 1
hVBE = CStr(hMonitor)
End Select
End If
MonitorEnumProc = MonitorCount
End Function
Sub Test()
Dim wbkTest As Workbook
Set wbkTest = Workbooks.Add
Call ActivateWorkbook(wbkTest)
Set wbkTest = Nothing
End Sub
Sub ActivateWorkbook(wbkResults As Workbook)
Dim objWindow As Window
With Application
If MonitorsAreTheSame = True Then
.VBE.MainWindow.WindowState = vbext_ws_Minimize
For Each objWindow In .Windows
With objWindow
If .Left = Application.VBE.MainWindow.Left Then
If .Caption <> wbkResults.Name Then .WindowState = xlMinimized
End If
End With
Next objWindow
Else
For Each objWindow In .Windows
With objWindow
If .Left <> Application.VBE.MainWindow.Left Then
If .Caption <> wbkResults.Name Then .WindowState = xlMinimized
End If
End With
Next objWindow
End If
.Windows(wbkResults.Name).WindowState = xlMaximized
AppActivate (.Caption)
End With
End Sub
this should be sufficient - no second sub for activation needed. These should show the new workbook in the foreground, no other windows changed.
Sub ExampleCode()
Dim wbXXX As Workbook
Set wbXXX = Workbooks.Add
With wbXXX
'Main code here
End With
wbXXX.Activate
Set wbXXX = Nothing
End Sub

Issue With Event For A Textbox Class

I have created a textbox class for a form.
When the textbox classes are on a form, the events work fine. However, when I place the textbox classes on a multipage, the events no longer work
(Separately, I understand that OnEnter, OnExit, BeforeUpdate and AfterUpdate events are not present in VBA (as in VB), however I have some code that I references external libraries that allows these 'events' to work).
I have extracts of the code below. Perhaps some kind soul might see what the problem is.
clsBusinessCaseTextBoxEvents:
Public WithEvents objTextBox As MSForms.TextBox
Private objParent As clsBusinessCaseEventControl
'------------------------------------------
'Initialize
'------------------------------------------
Public Sub Initialize(Parent As clsBusinessCaseEventControl)
Set Me.Parent = Parent
With Parent.UserForm.Controls
'Set objTextBox = .Add("Forms.TextBox.1")
End With
End Sub
'------------------------------------------
'Parent Property
'------------------------------------------
Public Property Set Parent(sglValue As clsBusinessCaseEventControl)
Set objParent = sglValue
End Property
Public Property Get Parent() As clsBusinessCaseEventControl
Set Parent = objParent
End Property
clsBusinessCaseEventControl
Private colCollection As Collection
Private objUserForm As UserForm
Public Event Change(objTextBox As clsBusinessCaseTextBoxEvents)
Public Event AfterUpdate(objTextBox As clsBusinessCaseTextBoxEvents)
Public Event Enter(objTextBox As clsBusinessCaseTextBoxEvents)
Public Property Set UserForm(frmUserForm As UserForm)
Set objUserForm = frmUserForm
End Property
Public Property Get UserForm() As UserForm
Set UserForm = objUserForm
End Property
Public Function AddTextBox() As clsBusinessCaseTextBoxEvents
Dim objTextBox As clsBusinessCaseTextBoxEvents
Set objTextBox = New clsBusinessCaseTextBoxEvents
'
objTextBox.Initialize Me
End Function
Private Sub Class_Initialize()
Set colCollection = New Collection
End Sub
and as a sample in this class
Public Sub Enter(objTextBox As clsBusinessCaseTextBoxEvents)
RaiseEvent Enter(objTextBox)
End Sub
And then in a normal module to add a textbox class
Dim objTextBoxControl As control
Set objTextBoxControl = frmBusinessCase.mtpBusinessCase.Page0.Controls.Add("Forms.TextBox.1", strTextBoxName, True)
As noted, when I enter the class textbox - when it is on a form - the 'OnEnter' event fires normally. But not when the class textbox is placed on a multipage on the form.
Can anyone help? Thx, JonS
Hi Rory, is this what you mean?
'==================================================================================================================
'############ Section BEGIN for: OnEnter, OnExit, BeforeUpdate and AfterUpdate ####################################
'------------------------------------------------------------------------------------------------------------------
'
'Unlike VB, VBA does not bring across the 'OnEnter, 'OnExit', 'BeforeUpdate' and 'AfterUpdate' events as methods
'into it's textbox class.
'
'Instead, to obtain this functionality, it is necessary to make a Windows API call to 'ConnectToConnectionPoint'
'
'The code in these partitioned blocks deals with these functions using this Windows API call
'------------------------------------------------------------------------------------------------------------------
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
#If VBA7 Then
Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, lpiid As GUID) As Long
Private Declare PtrSafe Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As LongPtr) As Long
#Else
Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, lpiid As GUID) As Long
Private Declare PtrSafe Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As Long) As Long
#End If
'==================================================================================================================
'############ Section END for: OnEnter, OnExit, BeforeUpdate and AfterUpdate ####################################
'==================================================================================================================
'==================================================================================================================
'############ Section BEGIN for: OnEnter, OnExit, BeforeUpdate and AfterUpdate ####################################
'==================================================================================================================
Public Property Let SetControlEvents(ByVal TextBox As Object, ByVal SetEvents As Boolean)
Const S_OK = &H0
Static lCookie As Long
Dim tIID As GUID
Set objTextBox = TextBox
If IIDFromString(StrPtr("{00020400-0000-0000-C000-000000000046}"), tIID) = S_OK Then
Call ConnectToConnectionPoint(Me, tIID, SetEvents, TextBox, lCookie)
If lCookie Then
'Debug.Print "Connection set for: " & TextBox.Name
'MsgBox "Connection set for: " & TextBox.Name
Else
'Debug.Print "Connection failed for: " & TextBox.Name
End If
End If
End Property
Public Sub OnEnter()
'Attribute OnEnter.VB_UserMemId = &H80018202
'Debug.Print "[ENTER EVENT] " & oTextBox.Name & vbTab & "Value: " & vbTab & oTextBox.Value
MsgBox "On Enter"
Call TurnActiveFieldToYellow(objTextBox)
Call FormBusinessCaseDollarFieldsBlue(objTextBox)
End Sub
The whole issue appeared when placing class textboxes on a 'multipage' on a form, rather than the form itself (which does not cause this problem)
I am not strong on classes. However, the suggestion of gathering all of the textbox objects into a collection (after they have been created) and then hooking them up to the class, like in this link, got the events working again. You could probably improve on my code below.
To solve, and after the class textboxes have been created using the 'add controls' method.
Dim objTextBoxControl As Control
Set objTextBoxControl = frmBusinessCase.mtpBusinessCase.Page0.Controls.Add("Forms.TextBox.1", strTextBoxName, True)
I used this in an ordinary module and call the sub 'InitialiseEvents' once the textboxes have been created
Dim colCollection As Collection
Sub InitializeEvents()
Dim ctl As Object
Dim clsEvents As clsBusinessCaseTextBoxEvents
If colCollection Is Nothing Then
Set colCollection = New Collection
End If
'Loop through all the controls
For Each ctl In frmBusinessCase.Controls
If TypeName(ctl) = "TextBox" Then
'Create a new instance of the event handler class
Set clsEvents = New clsBusinessCaseTextBoxEvents
'Tell it to handle the events for the text box
Set clsEvents.Control = ctl
'Add the event handler instance to our collection,
'so it stays alive during the life of the workbook
colCollection.Add clsEvents
End If
Next
End Sub
Sub TerminateEvents()
'Here the collection of classes is destroyed so memory will be freed up:
Set colCollection = Nothing
End Sub
and then added this to, or have present in, the class module 'clsBusinessCaseTextBoxEvents':
Public WithEvents objTextBox As MSForms.TextBox
Private objParent As clsBusinessCaseEventControl
Public Property Set Control(objTextBoxNew As MSForms.TextBox)
Set objTextBox = objTextBoxNew
End Property
Private Sub Class_Terminate()
Set objTextBox = Nothing
End Sub

How to trap Left Click in Excel?

I want to know if the selection of a cell is caused by a cursor move or by a mouse action.
There are a lot of articles explaining how to trap mouse click in Excel, even some explaining that left click can be trapped.
This code is found many times on the web:
' The declaration tells VBA where to find and how to call the API
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
' The function returns whether a key (or mouse button) is pressed or not
Public Function KeyPressed(ByVal Key As Long) As Boolean
KeyPressed = CBool((GetAsyncKeyState(Key) And &H8000) = &H8000)
End Function
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If (KeyPressed(&H1) = True) Then
MsgBox "Left click"
End If
If (KeyPressed(&H2) = True) Then
MsgBox "Right click"
End If
End Sub
This code traps the right click event, but not the left! Probably because it is placed in the Worksheet_SelectionChange event which is only called when a SelectionChanged has occurred and therefore when the left button has already been released!
How to detect a left click on a cell of a sheet to know if the selection of a cell is caused by a keyboard input (arrows or enter) or by a mouse left/right click action?
I found this great article and adapt it for mouse button check : https://www.mrexcel.com/board/threads/keypress-event-for-worksheet-cells.181654/
Add this module:
Option Explicit
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
Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Const HC_ACTION = 0
Const WH_MOUSE_LL = 14 ' Type of windows message to be hooked
Const WM_RBUTTONDOWN = &H204 ' Mouse message for right button down
Const WM_LBUTTONDOWN = &H201 ' Mouse message for left button down
Type KBDLLHOOKSTRUCT
vkCode As Long
scanCode As Long
flags As Long
time As Long
dwExtraInfo As Long
End Type
Dim hkLowLevelID As Long ' Hook id of the LowLevelMouseProc function
Dim LeftMouseDown As Boolean ' Flag to trap left mouse down events
Dim RightMouseDown As Boolean ' Flag to trap left mouse down events
Dim EllapsedTimer As Date
Function LowLevelMouseProc _
(ByVal nCode As Long, ByVal wParam As Long, lParam As KBDLLHOOKSTRUCT) As Long
On Error GoTo ResumeHere
' CAUTION !!!
' We can't do any action which envolves UI interaction because Excel is already beeing to update UI
' Hook mouse events only if XL is the active window
If GetActiveWindow = FindWindow("XLMAIN", Application.Caption) Then
If (nCode = HC_ACTION) Then
' Check if the left button is pressed
If (wParam = WM_LBUTTONDOWN) Then
LeftMouseDown = True
EllapsedTimer = Now() + TimeValue("00:00:01")
Application.OnTime EllapsedTimer, "ResetFlags"
ElseIf (wParam = WM_RBUTTONDOWN) Then
RightMouseDown = True
EllapsedTimer = Now() + TimeValue("00:00:01")
Application.OnTime EllapsedTimer, "ResetFlags"
End If
End If
End If
ResumeHere:
' Pass function to next hook if there is one
LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End Function
Function isLeftMouseDown()
isLeftMouseDown = LeftMouseDown
End Function
Function isRightMouseDown()
isRightMouseDown = RightMouseDown
End Function
' Reset the flags if the click has been thrown too long ago
Sub ResetFlags()
RightMouseDown = False
LeftMouseDown = False
End Sub
' Call this proc when opening Workbook
Sub StartHook()
If (hkLowLevelID = 0) Then
' Initiate the hooking process
hkLowLevelID = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.Hinstance, 0)
End If
End Sub
' Call this proc when closing Workbook
Sub StopHook()
If hkLowLevelID <> 0 Then
UnhookWindowsHookEx hkLowLevelID
hkLowLevelID = 0
End If
End Sub
It defines 2 procs StartHook and StopHook that you use in "ThisWoorkbook":
Private Sub Workbook_Open()
Call StartHook
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call StopHook
End Sub
And 2 functions that you can use in the macro for the Sheets like this:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Check if the mouse Left button was pressed
If (isLeftMouseDown()) Then
... do some stuff on left click - for example ...
If (ActiveCell.Column = 1) Then
MsgBox "You LeftClick in column A"
End If
...
End If
End Sub
Caution :
The flag can be read for 1 second after the click event, they are then reseted. That is to prevent some side effect when leaving excel and coming back to it.
Addendum to the code answer:
As of VBA 7 and above, the 'Declare' statements at the beginning need to also include 'PtrSafe'. Microsft added this check to ensure that the 'Declare' statement is safe to run in 64-bit versions of Office. See the article here:
https://learn.microsoft.com/en-us/office/vba/language/concepts/getting-started/64-bit-visual-basic-for-applications-overview

Detecting Lost Focus in Excel Application, Workbook or Worksheet

Switching to another application via the system ALT-Tab hotkey, while working in MS Excel on MS-Windows causes Excel to lose the keyboard focus. How to detect this?
The Deactivate or WindowDeactivate events for the objects: Application or Workbook or Worksheet objects do not fire when MS Excel loses focus this way (of course, because losing the focus is not synonymous with Deactivating the window)
Try this code, please. I found it somewhere to the internet, three years ago and only adapted to serve my needs. For instance, it could not be stopped because of a wrong declaration of UnhookWinEvent API. Take care to not monitor the focus lost or got by using a MsgBox. In this way, pressing 'OK' the focus will be received again and you will be in an infinite loop. The focus status will be returned in the active sheet, range "A1" (received focus), respectively, "A2" (lost focus):
Copy the next code on top of a module (in the declarations area):
Option Explicit
Private Const EVENT_SYSTEM_FOREGROUND = &H3&
Private Const WINEVENT_OUTOFCONTEXT = 0
Private Declare PtrSafe Function SetWinEventHook Lib "user32.dll" (ByVal eventMin As Long, _
ByVal eventMax As Long, ByVal hmodWinEventProc As LongLong, ByVal pfnWinEventProc As LongLong, _
ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Private Declare PtrSafe Function UnhookWinEvent Lib "user32.dll" (ByVal hWinEventHook As Long) As Long
Private handlColl As Collection
Copy the next code inside the module:
Public Sub StartMonitoring() 'it can be called from a Workbook/Worksheet event
StartFocusMonitoring
End Sub
Public Function StartFocusMonitoring() As Long
If handlColl Is Nothing Then Set handlColl = New Collection
StartFocusMonitoring = SetWinEventHook(EVENT_SYSTEM_FOREGROUND, EVENT_SYSTEM_FOREGROUND, 0&, _
AddressOf WinEventFunc, 0, 0, WINEVENT_OUTOFCONTEXT)
handlColl.aDD StartFocusMonitoring
End Function
Public Sub StopEventHook(lHook As Long)
Dim LRet As Long
If lHook = 0 Then Exit Sub`
LRet = UnhookWinEvent(lHook)
End Sub
Public Sub StopMonitoring() 'it must be called manualy or by an event when need to stop monitoring...
'it did not work until I changed the StopEventHook declaration, using ByVal instead of ByRef
Dim vHook As Variant, lHook As Long
For Each vHook In handlColl
lHook = vHook
StopEventHook lHook
Next vHook
End Sub
Public Function WinEventFunc(ByVal HookHandle As Long, ByVal LEvent As Long, _
ByVal hWnd As Long, ByVal idObject As Long, ByVal idChild As Long, _
ByVal idEventThread As Long, ByVal dwmsEventTime As Long) As Long
'In case of an error the application will crush. So, bypassing the error is good to be done...`
On Error Resume Next
Dim thePID As Long`
If LEvent = EVENT_SYSTEM_FOREGROUND Then
GetWindowThreadProcessId hWnd, thePID
If thePID = GetCurrentProcessId Then
'Do not use here a MsgBox, because after pressing OK Excel application
'will receive focus and you will stay in an infinite loop...
Application.OnTime Now, "Event_GotFocus"
Else
Application.OnTime Now, "Event_LostFocus"
End If
End If
On Error GoTo 0
End Function
Public Sub Event_GotFocus()
Range("a1").value = "Received Focus"
Range("a2").value = ""
End Sub
Public Sub Event_LostFocus()
Range("a2").value = "Lost focus"
Range("a1").value = ""
End Sub
You must start monitoring from StartMonitoring Sub which can be called directly or through an event (Workbook_Open, for instance).
The monitoring can be stopped calling StopMonitoring Sub...

Barcode Scanner in excel

Right now I have a spreadsheet in excel with some vba in it to use as an inventory database for our small business. The problem is that we are growing and I need to get more sophisticated.
The scanner is used with a Userform with a textbox control monitoring the number of characters that come into the textbox. When the specified number of characters is triggered the system does its job. What I need to accomplish is a way to monitor the input coming from the scanner itself without using a textbox control so that I can set up multiple scanners without them interfering with one another.
Any direction on this is greatly appreciated.
Here is the code:
Private Sub TextBox1_Change()
On Error GoTo endgame
Dim barCode As String
Dim charNumb As Long
barCode = TextBox1.Text
charNumb = Len(barCode)
'This triggers the system to perform actions based on the barcode number
'received. All of my barcodes for this version are formatted to have only 5
'characters. Works great with a single user and scanner.
If charNumb = 5 Then
Cells.Find(barCode).Activate
ActiveCell.Offset(0, 1).Activate
ActiveCell = ActiveCell + 1
ActiveCell.Offset(0, 17).Activate
ActiveCell = ActiveCell + 1
If ActiveCell = ActiveCell.Offset(0, -1) Then
ActiveCell.Offset(0, -1).Clear
ActiveCell.Clear
GoTo TIMESTAMPER
Else
GoTo TIMESTAMPER
End If
TIMESTAMPER:
TextBox1.Text = ""
'Timestamp
ActiveCell.Offset(0, -5).Activate
With ActiveCell
.Formula = Now
.NumberFormat = "m/d/yyyy h:mm:ss AM/PM"
End With
ActiveWorkbook.Save
ActiveCell.EntireRow.Select
TextBox1.SetFocus
End If
GoTo AllEndsWell
endgame:
Call errorsound
AllEndsWell:
End Sub
I have previously attempted to add barcode reader support to Excel and while the following has not been fully tested, I recall it was working; however there are some requirements to make it work
Within the code to follow, a barcode read is performed when a system message has been 'peaked' at and starts with a specific character. Most barcode readers can be programmed to output text in a certain way; the code requires an invisible precursor to be added to strings which is detected via msgMessage.wParam (Code example Case 17) and an enter character to follow the string to show when the barcode read is complete and reset the listener
For your barcode readers you may need to alter which character is prefixed and it's associated detection character (Ascii value. i.e. 17)
My current code:
The following code should be placed in a Class Module 'KeyPressApi'
Option Explicit
Private Type BARCODEBUFFER
strBuf As String
bCode As Boolean
End Type
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type MSG
hwnd As Long
Message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Private Declare Function WaitMessage Lib "user32" () As Long
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" _
(ByRef lpMsg As MSG, ByVal hwnd As Long, _
ByVal wMsgFilterMin As Long, _
ByVal wMsgFilterMax As Long, _
ByVal wRemoveMsg As Long) As Long
Private Declare Function TranslateMessage Lib "user32" _
(ByRef lpMsg As MSG) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Const WM_KEYDOWN As Long = &H100
Private Const PM_REMOVE As Long = &H1
Private Const WM_CHAR As Long = &H102
Private bExitLoop As Boolean
Private bufBuffer As BARCODEBUFFER
Public Event BarcodeRead(Barcode As String, ByRef Cancel As Boolean)
Public Sub StartKeyPressInit()
Dim msgMessage As MSG
Dim bCancel As Boolean
Dim iMessage As Integer
Dim iKeyCode As Integer
Dim lXLhwnd As Long
On Error GoTo errHandler
Application.EnableCancelKey = xlErrorHandler
bExitLoop = False 'Initialize boolean flag.
lXLhwnd = FindWindow("XLMAIN", Application.Caption) 'Get the app hwnd.
Do
WaitMessage 'check for a key press and remove it from the msg queue.
If PeekMessage(msgMessage, lXLhwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
iKeyCode = msgMessage.wParam 'store the virtual key code for later use.
iMessage = msgMessage.Message
TranslateMessage msgMessage 'translate the virtual key code into a char msg.
PeekMessage msgMessage, lXLhwnd, WM_CHAR, WM_CHAR, PM_REMOVE
bCancel = False
Select Case iKeyCode 'Enter and backspace not handled correctly by below case statement
Case 8 ' Backspace
If bufBuffer.bCode = True Then
If Len(bufBuffer.strBuf) > 0 Then
bufBuffer.strBuf = Left(bufBuffer.strBuf, Len(bufBuffer.strBuf) - 1)
bCancel = True
End If
End If
Case 13 ' End of barcode string so reset to off mode
If bufBuffer.bCode = True Then
bufBuffer.bCode = False
RaiseEvent BarcodeRead(ReadBuffer(), 0)
bCancel = True
End If
Case Else
End Select
Select Case msgMessage.wParam
Case 17 ' Start of Barcode; Initialize buffer array
If bufBuffer.bCode = False Then
bufBuffer.bCode = True
bufBuffer.strBuf = ""
bCancel = True
End If
Case Else ' All other data
If bufBuffer.bCode = True Then
If iKeyCode <> 0 Then
bufBuffer.strBuf = bufBuffer.strBuf & Chr(msgMessage.wParam)
bCancel = True
End If
End If
End Select
'if the key pressed is allowed post it to the application.
If Not bCancel Then PostMessage lXLhwnd, iMessage, iKeyCode, 0
End If
errHandler: 'Allow the processing of other msgs.
DoEvents
Loop Until bExitLoop
End Sub
Public Sub StopKeyPressWatch()
bExitLoop = True 'Set this boolean flag to exit the above loop.
End Sub
Public Function ReadBuffer() As String
ReadBuffer = bufBuffer.strBuf
Dim i As Integer
For i = 1 To 31
ReadBuffer = Replace(ReadBuffer, Chr(i), "")
Next
End Function
Then within the sheet that you want to override the listener
Option Explicit
Dim WithEvents CKeyWatcher As KeyPressApi
Private Sub Worksheet_Activate()
If CKeyWatcher Is Nothing Then Set CKeyWatcher = New KeyPressApi
If Not CKeyWatcher Is Nothing Then CKeyWatcher.StartKeyPressInit
End Sub
Private Sub Worksheet_Deactivate()
If Not CKeyWatcher Is Nothing Then CKeyWatcher.StopKeyPressWatch
End Sub
Private Sub CKeyWatcher_BarcodeRead(strBuffer As String, Cancel As Boolean)
MsgBox strBuffer
End Sub

Resources