Private Sub CHK_MouseUp( _
Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
Const OnePixel = 15 ' at 96 DPI
If -OnePixel <= X And X < CHK.Width _
And -OnePixel <= Y And Y <= CHK.Height _
Or LBL.Left - CHK.Left <= X _
And X <= LBL.Left + LBL.Width - CHK.Left _
And LBL.Top - CHK.Top <= Y _
And Y <= LBL.Top + LBL.Height - CHK.Top _
Then
If FieldYN = "Y" Then
FieldYN = "N"
Else
FieldYN = "Y"
End If
End If
End Sub
That wasn't too hard, and it provided an opportunity to visit some of the metrics used in controls and mouse events.
If KeyAscii = vbKeySpace Then ...
But if the goal is to mimic the standard behaviour as closely as possible, something a little more subtle is needed. As such, the “key press” event will not allow cancelling the event by striking another key.
Dim mfSpaceBar As Boolean
Private Sub CHK_KeyDown(KeyCode As Integer, Shift As Integer)
mfSpaceBar = (KeyCode = vbKeySpace)
End Sub
Private Sub CHK_KeyUp(KeyCode As Integer, Shift As Integer)
If mfSpaceBar And KeyCode = vbKeySpace Then
' update FieldYN here
End If
End Sub
Again, nothing too complicated, and it works both in form view and in datasheet view. Who needs a mouse anyway? Right? Oh, well…
Private Type POINTAPI ' used by GetCursorPos
X As Long
Y As Long
End Type
' WinAPI declarations
Private Declare Function GetCursorPos Lib "user32" _
(ByRef pt As POINTAPI) As Long
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long
' … and two constants for GetDeviceCaps:
Private Const LOGPIXELSX As Long = 88&
Private Const LOGPIXELSY As Long = 90&
' Access-compatible mouse coordinates in twips
Private Type PointAcc
X As Single
Y As Single
End Type
' module variables: twips per pixel and current offset
Dim Pix2Twip As PointAcc
Dim Offset As PointAcc
Private Function GetMousePos() As PointAcc
If Pix2Twip.X = 0! Then
' obtain metrics from Windows
Dim lngDC As Long
Dim lngDpiX As Long
Dim lngDpiY As Long
' create a "drawing context" using the form's window
lngDC = GetDC(Me.hwnd)
If lngDC <> 0 Then
lngDpiX = GetDeviceCaps(lngDC, LOGPIXELSX)
lngDpiY = GetDeviceCaps(lngDC, LOGPIXELSY)
ReleaseDC Me.hwnd, lngDC
Else
' failure? use default values...
lngDpiX = 96
lngDpiY = 96
End If
Pix2Twip.X = 1440 / lngDpiX
Pix2Twip.Y = 1440 / lngDpiY
End If
' get absolute mouse position; convert to twips
Dim pt As POINTAPI
GetCursorPos pt
GetMousePos.X = pt.X * Pix2Twip.X
GetMousePos.Y = pt.Y * Pix2Twip.Y
End Function
The rest is easy: calculating the offset on “mouse down” and validating the current cell on “mouse up”: if the metrics agree, the mouse is still over the same cell in the datasheet grid.
Private Sub CHK_MouseDown( _
Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
' record cell's top-left coordinates
With GetMousePos
Offset.X = .X - X
Offset.Y = .Y - Y
End With
End Sub
Private Sub CHK_MouseUp( _
Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
' white-cross intervention
If Me.SelWidth > 0 Then Exit Sub
' validate coordinates for current cell
With GetMousePos
If X > Pix2Twip.X And Y > Pix2Twip.Y _
And X + Offset.X = .X And Y + Offset.Y = .Y Then
' update FieldYN here
End If
Offset.X = 0: Offset.Y = 0
End With
End Sub
The “mouse up” function already includes fine-tuning for two special circumstances.
If Me.CurrentView = 1 Then
' handle form view -- see Form2
ElseIf Me.CurrentView = 2 Then
' handle datasheet view -- see Form3
End If
'———————————————————————————————————————————————————————————————————————————————
' Checkbox Events -- class module
' Published on Experts Exchange, www.experts-exchange.com
' Article: How to Edit a Calculated Yes/No Field?
' URL: http://www.experts-exchange.com/A_3247.html
' Author: Markus G Fischer, Geneva, 2010-04
'———————————————————————————————————————————————————————————————————————————————
'
' Purpose:
' ¯¯¯¯¯¯¯¯
' When a checkbox is bound to an expression, it becomes read-only. This module
' can listen to both keyboard and mouse events and detect when the "click"
' event _should_ happen, and raise a cusom event at that time.
'
' Usage:
' ¯¯¯¯¯¯
' In the form module's declaration section:
' Dim WithEvents eliMyCheckBox As claEventsCheckboy ' name of this module
'
' In the form's "load" event:
' Set eliMyCheckBox = New claEventsCheckboy
' eliMyCheckBox.Watch chkMyCheckBox ' name of the calculated checkbox
'
' In the form module:
' Private Sub eliMyCheckBox_Update()
' ' perform the update on the base field(s) here
' End Sub
'
' Important:
' The following event properties need to be set to [Event Procedure], and
' cannot call a macro or a user-defined function (the form module can however
' have additional event handlers for any of them): "on mouse down", "on mouse
' up", "on dbl click", "on key down", and "on key up".
'
' Notes:
' ¯¯¯¯¯¯
' Before raising the Update event, the current event is cancelled (by a call
' to DoCmd), so that the soft error message "this control cannot be edited"
' does not appear in the status bar.
'
'
Option Compare Database
Option Explicit
' Delcarations
Public Event Update() ' the event sent to the form
Private WithEvents chk As CheckBox ' the checkbox to monitor
Private lbl As Label ' its associated label
Private frm As Form ' the form
' WinAPI declarations
' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
' Type used by GetCursorPos
Private Type POINTAPI
X As Long
Y As Long
End Type
' Library function needed in this module
Private Declare Function GetCursorPos Lib "user32" _
(ByRef pt As POINTAPI) As Long
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long
' Useful constants for GetDeviceCaps
Private Const LOGPIXELSX As Long = 88&
Private Const LOGPIXELSY As Long = 90&
' Further class declarations
' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
' Again a point structure, but in twips
Private Type PointAcc
X As Single
Y As Single
End Type
' used for "twips per pixel" and the current offset
Dim Pix2Twip As PointAcc
Dim Offset As PointAcc
' keyboard: monitor the space bar
Dim mfSpaceBar As Boolean
Public Sub Watch(pchkToEdit As CheckBox)
'
' Only public method of the class, used to initialise monitoring.
'
' Usage: <object>.Watch <chek box>
'
Dim Daddy As Object
Set chk = pchkToEdit
' find the associated label
If chk.Controls.Count Then Set lbl = chk.Controls(0)
' find the form (note: the parent could be a tab control)
Set Daddy = chk.Parent
Do Until TypeName(Daddy) Like "Form_*"
Set Daddy = Daddy.Parent
Loop
Set frm = Daddy
' Useful while designing: event sanity check
Debug.Assert chk.OnKeyDown = "[Event Procedure]"
Debug.Assert chk.OnKeyUp = "[Event Procedure]"
Debug.Assert chk.OnMouseDown = "[Event Procedure]"
Debug.Assert chk.OnMouseUp = "[Event Procedure]"
Debug.Assert chk.OnDblClick = "[Event Procedure]"
End Sub
Private Function GetMousePos() As PointAcc
'
' Calls the WinAPI function returning the mouse (cursor) position, and
' converts the values from pixel to twips.
'
Dim pt As POINTAPI
GetCursorPos pt
GetMousePos.X = pt.X * Pix2Twip.X
GetMousePos.Y = pt.Y * Pix2Twip.Y
End Function
Private Sub chk_DblClick(Cancel As Integer)
' disable double-click for checkboxes
Cancel = True ' works in form view
Offset.X = 0: Offset.Y = 0 ' added for datasheet view
End Sub
Private Sub chk_KeyDown(KeyCode As Integer, Shift As Integer)
' monitor only the spacebar
mfSpaceBar = (KeyCode = vbKeySpace)
End Sub
Private Sub chk_KeyUp(KeyCode As Integer, Shift As Integer)
' raise the event after space bar "down" and "up" events
If mfSpaceBar And KeyCode = vbKeySpace Then
KeyCode = 0 ' prevent event propagation
RaiseEvent Update
End If
End Sub
Private Sub chk_MouseDown( _
Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
'
' stores the current offset (top left position of the current grid cell)
'
If frm.CurrentView = 2 Then
' only needed in datasheet view
With GetMousePos
Offset.X = .X - X
Offset.Y = .Y - Y
End With
End If
End Sub
Private Sub chk_MouseUp( _
Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
'
' Determines whether the event "counts" and should generate a "click" event.
'
Dim fIsClick As Boolean
If frm.CurrentView = 1 Then
' Form View:
' is the mouse still over the checkbox?
fIsClick = -Pix2Twip.X <= X And X < chk.Width _
And -Pix2Twip.Y <= Y And Y <= chk.Height
' or over the label?
If Not lbl Is Nothing And Not fIsClick Then
fIsClick = lbl.Left - chk.Left <= X _
And X <= lbl.Left + lbl.Width - chk.Left _
And lbl.Top - chk.Top <= Y _
And Y <= lbl.Top + lbl.Height - chk.Top
End If
If fIsClick Then
DoCmd.CancelEvent
RaiseEvent Update
End If
ElseIf frm.CurrentView = 2 Then
' Datasheet View:
' no edit occurs when cells are selected
If frm.SelWidth > 0 Then Exit Sub
' compare control's coordinate with screen's coordinates
With GetMousePos
If X > Pix2Twip.X And Y > Pix2Twip.Y _
And X + Offset.X = .X And Y + Offset.Y = .Y Then
DoCmd.CancelEvent
RaiseEvent Update
End If
End With
End If
End Sub
Private Sub Class_Initialize()
'
' Gets the monitor's DPI settings, in order to calculate "twips per pixel"
' values in both X and Y directions.
'
Dim lngDC As Long
Dim lngDpiX As Long
Dim lngDpiY As Long
' get a "drawing context" compatible with the application window
lngDC = GetDC(Application.hWndAccessApp)
If lngDC <> 0 Then
' request both DPI settings
lngDpiX = GetDeviceCaps(lngDC, LOGPIXELSX)
lngDpiY = GetDeviceCaps(lngDC, LOGPIXELSY)
' release used memory
ReleaseDC Application.hWndAccessApp, lngDC
Else
' failure? use default values (damage control)
lngDpiX = 96
lngDpiY = 96
End If
' store the conversion factors
Pix2Twip.X = 1440 / lngDpiX
Pix2Twip.Y = 1440 / lngDpiY
End Sub
Private Sub Class_Terminate()
'
' Relase objects. This is actually necessary for the Form object to avoid the
' "hand-holding" bug: this class instance holds the form; the form holds this
' class instance. This can prevent both from being released from memory when
' the form is closed, and even when the database is closed. This ultimately
' prevents Access from closing alltogether.
'
Set chk = Nothing
Set lbl = Nothing
Set frm = Nothing
End Sub
(open in a new tab)
' declaration of a typed object variable
Dim WithEvents Listener As claEventsCheckbox
Private Sub Form_Close()
' release the object from memory
Set Listener = Nothing
End Sub
Private Sub Form_Load()
' create a new instance and initialise it
Set Listener = New claEventsCheckbox
Listener.Watch MyCheckbox
End Sub
Private Sub Listener_Update()
' handle the update event here...
End Sub
Note: five event properties of MyCheckbox need to be set to “[Event Procedure]”, namely “on key down”, “on key up”, “on mouse down”, “on mouse up”, and “on double click”. If one of them is missing, the code will stop at the corresponding Debug.Assert (lines 105–109) of the initialisation method Watch.
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (0)