[AccessD] Calendar demo

John Colby jwcolby at ColbyConsulting.com
Mon Jan 30 08:23:51 CST 2006


Access comes with a built-in calendar control.  Kinda lame but it works.  

I needed a quick and dirty calendar the other day and decided to marry this
calendar control with my filter function to get this thing working in a
hurry.  I have discussed my "filter" function many times in this group.
Basically it is a function with a collection which holds values, keyed on
the name passed in to the function.  What isn't apparent is that with a
little work you can also pass in pointers to controls themselves.  

What this allows is for a calling form to place a reference to a control on
the calling form into the Fltr collection, then open the calendar form.  The
calendar form then does it's thing, and when it is time to return a value,
it goes and gets the pointer to the control on the calling form, places the
value in that control, and closes.

Works a treat.

The demo is up on my site, complete with the calendar form, the FltrCtl
function, and a calling form which demos getting a data.

Go to www.ColbyConsulting.com
Register if you haven't already
Log in.
Click Example Code / Utilities / C2DbCalendarDemo

The code:

'===========================================================================
=========
'The code for the filter function, modified to handle pointers to objects
'===========================================================================
=========
'
'The following code expands upon the basic filter function above to allow
storing and
'returning objects of any kind - controls, forms, classes etc.
'
'The code takes advantage of the fact that a variant can store a pointer to
an object.
'In order to determine if the thing stored is an object or a normal
variable, a SET statement
'is performed first and the err object is checked.  If the thing stored is
not an error then the
'Err object will not be zero, in which case we treat the thing stored as a
simple variable.
'
Public Function FltrCtl(lstrName As String, Optional lvarValue As Variant)
As Variant
On Error GoTo Err_fltrCtl
Static mcolFilter As Collection
Static blnInitialized As Boolean

    If Not blnInitialized Then
        'if the collection not initialized yet, do so now
        Set mcolFilter = New Collection
        blnInitialized = True
    End If
    '
    'We have a valid collection, next check for a value passed in
    '
    If IsMissing(lvarValue) Then
        '
        'No value was passed in so check in the collection
        'using the variable name (key)
        '
        'We are going to pass back the value.  Determine if it is an object
        'by using the set statement and checking for an error
        '
        On Error Resume Next
        Set FltrCtl = mcolFilter(lstrName)
        If Err <> 0 Then 'if the Err obj is <> zero then it was not an
object
            Err.Clear
            FltrCtl = mcolFilter(lstrName)
            If Err <> 0 Then                  '
                'There was no value in the collection under that name (key)
                'so just return a null
                '
                FltrCtl = Null
            End If
        End If
    Else
        '
        'A value was passed in so
        '
        On Error Resume Next
        '
        'Remove any value already in the collection under that name (key)
        '(if any)
        '
        mcolFilter.Remove lstrName
        Err.Clear
        '
        'And then add it back in to the collection
        '
        mcolFilter.Add lvarValue, lstrName
        '
        'We are going to pass back the value.  Determine if it is an object
        'by using the set statement and checking for an error
        '
        Set FltrCtl = lvarValue
        If Err <> 0 Then        'if the Err obj is <> zero then it was not
an object
            FltrCtl = lvarValue    'so just return the value as a variable
        End If
    End If
Exit_fltrCtl:
Exit Function
Err_fltrCtl:
        MsgBox Err.Description, , "Error in Function
basfltrCtlFunctions.fltrCtl"
        Resume Exit_fltrCtl
    Resume 0    '.FOR TROUBLESHOOTING
End Function

'===========================================================================
=========
'The code for the form needing to use the calendar
'===========================================================================
=========
Private Sub cmdCalDteFrom_Click()
    'Set a pointer to the text box which needs a date
    FltrCtl "CalDte", txtDateFrom
    OpenCal
End Sub
'
'The standard "open a form" code which opens the calendar form
'
Private Sub OpenCal()

    Dim stDocName As String
    Dim stLinkCriteria As String

    stDocName = "frmCalendar"
    DoCmd.OpenForm stDocName, , , stLinkCriteria, , acDialog
    
End Sub



John W. Colby
www.ColbyConsulting.com 





More information about the AccessD mailing list