GraphExample_Crystal_140817

1        Option Compare Database 
2        Option Explicit 

3         '
4         '============================================================
5         '  cbf: f_Graph
6         '============================================================ LICENSE NOTICE -- must not be modified
7         ' This software is licensed to you under CC BY-NC-SA 3.0
8         '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
9         ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
10        '
11        ' You are free to:
12        '    Share — copy and redistribute the material in any medium or format
13        '    Adapt — remix, transform, and build upon the material
14        ' The licensor cannot revoke these freedoms as long as you follow these terms:
15        '    Attribution — You must give appropriate credit, provide a link to the license,
16        '                   and indicate if changes were made.
17        '                   You may do so in any reasonable manner,
18        '                   but not in any way that suggests the licensor endorses you or your use.
19        '    NonCommercial — You may not use the material for commercial purposes.
20        '    ShareAlike — If you remix, transform, or build upon the material,
21        '                 you must distribute your contributions under the same license as the original.
22        '
23        ' many procedures and module names contain author or controbitor names that must be left intact
24        ' if you make changes, add your name, date, and descriptive information to the comments
25        '
26        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140811
27        ' END LICENSE NOTICE
28        '============================================================
29        ' ... 140812
30        'Microsoft Graph 14.0 Object Library
31        '
32        ' Download this example from:  MS_Access_Professionals, a Yahoo technical discussion group
33        ' http://groups.yahoo.com/neo/groups/MS_Access_Professionals/files/Crystal/
34        ' or
35        ' http://www.AccessMVP.com/strive4peace/Access_Graphs.htm
36        '
37       Private Sub b_CloseChartSetup_Click() 
38        '140809
39          DoCmd.Close acForm, Me.Name, acSaveYes 
40       End Sub 

41      
42      
43       Private Sub Form_Open(Cancel As Integer) 
44        '121031 Crystal, 140809...12
45      
46          On Error GoTo Proc_Err 
47      
48          Dim sTitle As String _ 
49             , sTitleX As String _ 
50             , dblY1 As Double _ 
51             , dblY2 As Double _ 
52             , sDateFormat As String _ 
53             , sValueFormat As String _ 
54             , sFormname As String 
55      
56           'if Graph menu form is not open, skip setting anything so the last version is rendered
57          sFormname = "f_Graph_Menu" 
58          If SysCmd(acSysCmdGetObjectState, acForm, sFormname) <> 0 Then   '0 means State is Closed 
59             If Forms(sFormname).CurrentView = 0 Then   '0 is Design View 
60                GoTo Proc_Exit 
61             End If 
62          Else 
63              'menu form not open
64             GoTo Proc_Exit 
65          End If 
66      
67          With Forms(sFormname) 
68             Me.Label_Header.Caption = Nz(.txtHeader, "") 
69             Me.Label_Footer.Caption = Nz(.txtFooter, "") 
70      
71             sTitle = Nz(.txtTitle, "") 
72             sValueFormat = Nz(.txtValueFormat, "") 
73             dblY1 = Nz(.txtScale_Y1, 0) 
74             dblY2 = Nz(.txtScale_Y2, Nz(.txtScale_Y1, 1) - 1.1) 
75      
76             sTitleX = Nz(.txtTitleX, "") 
77             sDateFormat = Nz(.txtDateFormat, "") 
78      
79          End With 
80      
81          With Me.TheGraph 
82             If Len(sTitle) > 0 Then 
83                .HasTitle = True 
84                .ChartTitle.Text = sTitle 
85             Else 
86                .HasTitle = False 
87             End If 
88          End With 
89      
90          With Me.TheGraph.Axes(1)   'xlCategory=1 
91             .HasTitle = True 
92             .AxisTitle.Caption = sTitleX 
93             .TickLabels.NumberFormat = sDateFormat 
94          End With   'X-Axis 
95      
96          With Me.TheGraph.Axes(2)   'xlValue=2 
97             If dblY1 = -1 Then   'NOTE: this is also stated in StatusBarText 
98                .MinimumScaleIsAuto = True 
99             Else 
100               .MinimumScale = dblY1 
101            End If 
102            If dblY2 > dblY1 Then 
103               .MaximumScale = dblY2 
104            Else 
105               .MaximumScaleIsAuto = True 
106            End If 
107            .TickLabels.NumberFormat = sValueFormat 
108         End With   'Y-Axis 
109     
110       '   MsgBox "opening graph"
111     
112      Proc_Exit: 
113         On Error Resume Next 
114         Exit Sub 
115     
116      Proc_Err: 
117         MsgBox Err.Description, , _ 
118              "ERROR " & Err.Number _ 
119              & "   Form_Open (perhaps qGraph has no data): " & Me.Name 
120     
121         Resume Proc_Exit 
122         Resume 
123     
124      End Sub 

1        Option Compare Database 
2        Option Explicit 
3        Option Base 1   'set 1 as lower bound for arrays 
4         '============================================================
5         '  cbf: f_Graph_MENU
6         '============================================================ LICENSE NOTICE -- must not be modified
7         ' This software is licensed to you under CC BY-NC-SA 3.0
8         '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
9         ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
10        '
11        ' You are free to:
12        '    Share — copy and redistribute the material in any medium or format
13        '    Adapt — remix, transform, and build upon the material
14        ' The licensor cannot revoke these freedoms as long as you follow these terms:
15        '    Attribution — You must give appropriate credit, provide a link to the license,
16        '                   and indicate if changes were made.
17        '                   You may do so in any reasonable manner,
18        '                   but not in any way that suggests the licensor endorses you or your use.
19        '    NonCommercial — You may not use the material for commercial purposes.
20        '    ShareAlike — If you remix, transform, or build upon the material,
21        '                 you must distribute your contributions under the same license as the original.
22        '
23        ' many procedures and module names contain author or controbitor names that must be left intact
24        ' if you make changes, add your name, date, and descriptive information to the comments
25        '
26        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140811
27        ' END LICENSE NOTICE
28        '============================================================
29        ' modified 1-10-09, 12-13-09, 140808-12
30        '
31        ' calls:
32        '     loc_BoldMe
33        '     loc_MakeQuery
34        '
35        'CONTROLS
36        '  Date1 - start date (optional)
37        '  Date2 - end date (optional)
38        '  fraFunction - Sum or Avg or Each
39        '  fraDays - Weekdays, Weekends, All
40        '  txtDateFormat -- set by fraScale, can be orverridden
41        '  txtTitle - set by fraFunction & fraDays & fraScale, can be orverridden
42        '  txtScale_Y1 -- 0 if not set
43        '  txtScale_Y2 -- optional
44        '  txtHeader
45        '
46        ' Download this example from:  MS_Access_Professionals, a Yahoo technical discussion group
47        ' http://groups.yahoo.com/neo/groups/MS_Access_Professionals/files/Crystal/
48        ' or
49        ' http://www.AccessMVP.com/strive4peace/Access_Graphs.htm
50        '
51        '

52      
53       Private Sub Form_Load() 
54        '140810
55          Call ResetCriteria 
56       End Sub 

57      
58       Private Sub Date1_AfterUpdate() 
59        '140811
60          Call Calc_Footer 
61       End Sub 

62      
63       Private Sub Date1_DblClick(Cancel As Integer) 
64        '140810
65          DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog 
66          Call Calc_Footer 
67       End Sub 

68      
69       Private Sub Date2_AfterUpdate() 
70        '140811
71          Call Calc_Footer 
72       End Sub 

73      
74       Private Sub Date2_DblClick(Cancel As Integer) 
75        '140810
76          If IsNull(Me.Date2) And Not IsNull(Me.Date1) Then 
77             DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog, Me.Date1 
78          Else 
79             DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog 
80          End If 
81          Call Calc_Footer 
82      
83       End Sub 

84      
85       Private Sub MyOtherID1_AfterUpdate() 
86        '140812
87          Call Calc_Footer 
88       End Sub 

89      
90       Private Sub MyOtherID2_AfterUpdate() 
91        '140812
92          Call Calc_Footer 
93       End Sub 

94      
95       Private Sub MyTopicID_AfterUpdate() 
96        '140808,11 strive4peace
97          Dim sWhere As String 
98      
99          Call Calc_Header 
100     
101         With Me.MyTopicID 
102            If IsNull(.Value) Then 
103               sWhere = "" 
104            Else 
105               sWhere = "MyTopicID = " & .Value 
106            End If 
107         End With 
108     
109         Call SetControl_RowSource(Me.MyOtherID1, sWhere) 
110         Call SetControl_RowSource(Me.MyOtherID2, sWhere) 
111      End Sub 

112     
113      Private Sub fraDays_AfterUpdate() 
114       '140810
115         Call loc_BoldMe(Me, "fraDays", 3) 
116         Call Calc_Title 
117         Call Calc_Footer 
118      End Sub 

119     
120      Private Sub fraFunction_AfterUpdate() 
121       '140810
122         Call loc_BoldMe(Me, "fraFunction", 3) 
123         Call Calc_Title 
124      End Sub 

125     
126      Private Sub fraScale_AfterUpdate() 
127       '140810
128         Call loc_BoldMe(Me, "fraScale", 3) 
129         Call Calc_Title 
130         Call Calc_Scale 
131      End Sub 

132     
133      Private Function Calc_Scale() 
134       'updated by fraScale
135         Dim sChartTitleX As String _ 
136            , sDateFormat As String 
137     
138         sDateFormat = "mmm-d"   'default 
139         sChartTitleX = "Day" 
140     
141         With Me.fraScale 
142            Select Case .Value 
143            Case 2   'weekly 
144               sChartTitleX = "Week" 
145            Case 3   'monthly 
146               sChartTitleX = "Month" 
147               sDateFormat = "mmm-yy" 
148            Case Else '1 'daily 
149            End Select 
150         End With 
151         Me.txtTitleX = sChartTitleX 
152         Me.txtDateFormat = sDateFormat 
153      End Function 

154     
155     
156      Private Function Calc_Title() 
157       '140810
158          'updated by fraFunction, fraDays, fraScale
159         Dim sTitle As String 
160         sTitle = GetTitle() 
161         Me.txtTitle = sTitle 
162      End Function 

163     
164      Private Function Calc_Header() 
165       '140811
166       'updated by Topic
167         Dim vHeader As Variant 
168         vHeader = Null 
169         With Me.MyTopicID 
170            If IsNull(.Value) Then 
171               Me.txtHeader = Null 
172            Else 
173               Me.txtHeader = .Column(1) 
174            End If 
175         End With 
176      End Function 

177     
178      Private Function Calc_Footer() 
179       '140811
180       'updated by fraDays, OtherID1, OtherID2, Date1, Date2
181         On Error Resume Next 
182         Dim vFooter As Variant 
183         vFooter = Null 
184     
185         With Me.MyOtherID1 
186            If Not IsNull(.Value) Then 
187               vFooter = (vFooter + ", ") & " OtherID1: " & .Value 
188            End If 
189         End With 
190     
191         With Me.MyOtherID2 
192            If Not IsNull(.Value) Then 
193               vFooter = (vFooter + ", ") & " OtherID2: " & .Value 
194            End If 
195         End With 
196     
197         Select Case Me.fraDays 
198         Case 1   'weekday 
199            vFooter = (vFooter + ", ") & " Weekdays" 
200         Case 2   'weekend 
201            vFooter = (vFooter + ", ") & " Weekends" 
202         End Select 
203     
204          'see if dates were specified
205         Select Case True 
206     
207          'start date
208         Case Not IsNull(Me.Date1) And IsNull(Me.Date2) 
209            vFooter = (vFooter + ", ") & " Date >= " & Format(Me.Date1, "short date") 
210     
211          'end date
212         Case IsNull(Me.Date1) And Not IsNull(Me.Date2) 
213            vFooter = (vFooter + ", ") & " Date <= " & Format(Me.Date2, "short date") 
214     
215          'date range
216         Case Not IsNull(Me.Date1) And Not IsNull(Me.Date2) 
217            vFooter = (vFooter + ", ") & " Between " _ 
218               & Format(Me.Date1, "short date") & " And " & Format(Me.Date2, "short date") 
219     
220          'no dates specified
221         Case Else 
222            vFooter = (vFooter + ", ") & " Date from " _ 
223               & Format(Nz(DMin("ChtDate", "qGraph"), 0), "short date") _ 
224               & " To " & Format(Nz(DMax("ChtDate", "qGraph"), 0), "short date") 
225     
226         End Select 
227     
228         Me.txtFooter = vFooter 
229     
230      End Function 

231     
232      Private Function GetTitle() As String 
233         Dim sTitle As String 
234         With Me.fraFunction 
235            Select Case .Value 
236            Case 1 
237               sTitle = "Sum Data" 
238            Case 2 
239               sTitle = "Average Data" 
240            Case Else 
241               sTitle = "Data" 
242            End Select 
243         End With 
244         With Me.fraScale 
245            Select Case .Value 
246            Case 1   'daily 
247               sTitle = sTitle & " by Day" 
248            Case 2   'weekly 
249               sTitle = sTitle & " by Week" 
250            Case 3   'monthly 
251               sTitle = sTitle & " by Month" 
252            End Select 
253         End With 
254         Select Case Me.fraDays 
255         Case 1   'weekday 
256            sTitle = sTitle & ", WeekDays" 
257         Case 2   'weekend 
258            sTitle = sTitle & ", Weekends" 
259         End Select 
260         GetTitle = sTitle 
261      End Function 

262     
263      Private Sub cmd_Chart_Click() 
264       '... 140811, 12
265         On Error GoTo Proc_Err 
266     
267          'these may not be nessesary
268          'since this is not a bound form, Dirty does not apply
269         Me.Refresh 
270         Me.Repaint 
271         DoEvents 
272     
273         Dim sSQL As String _ 
274            , vWhere As Variant _ 
275            , sDateEquation As String _ 
276            , vFooter As Variant 
277     
278         vWhere = Null 
279     
280          '-------------------------------------- Date Equation
281         With Me.fraScale 
282            Select Case .Value 
283            Case 1   'daily 
284               sDateEquation = "DateValue(D.MyDateTime)" 
285            Case 2   'weekly 
286               sDateEquation = "IIf(Weekday(D.MyDateTime,2)=1 " _ 
287                  & ",DateValue(D.MyDateTime)" _ 
288                  & ",DateValue(D.MyDateTime)-Weekday(D.MyDateTime,2)+1)" 
289            Case 3   'monthly 
290               sDateEquation = "DateSerial(Year(D.MyDateTime),Month(D.MyDateTime),1)" 
291            Case Else 
292               .SetFocus 
293               MsgBox "You must pick a time frame For the chart", , "Need Time Frame" 
294               GoTo Proc_Exit 
295            End Select 
296         End With 
297     
298          '-------------------------------------- Criteria: Chart Topic
299         With Me.MyTopicID 
300            If IsNull(.Value) Then 
301               If MsgBox("Do you want To choose a Topic For the chart" _ 
302                     , vbYesNo, "Choose Topic") = vbYes Then 
303                  .SetFocus 
304                  GoTo Proc_Exit 
305               End If 
306            Else 
307               vWhere = (vWhere + " And ") & " (D.MyTopicID = " & .Value & ")" 
308            End If 
309         End With 
310     
311          '-------------------------------------- criteria: other
312         With Me.MyOtherID1 
313            If Not IsNull(.Value) Then 
314               vWhere = (vWhere + " And ") & " (D.MyOtherID1 = " & .Value & ")" 
315               vFooter = (vFooter + ", ") & " OtherID1: " & .Value 
316            End If 
317         End With 
318     
319         With Me.MyOtherID2 
320            If Not IsNull(.Value) Then 
321               vWhere = (vWhere + " And ") & "(D.MyOtherID2 = " & .Value & ")" 
322               vFooter = (vFooter + ", ") & " OtherID2: " & .Value 
323            End If 
324         End With 
325     
326         Select Case Me.fraDays 
327         Case 1   'weekday 
328            vWhere = (vWhere + " And ") & " (Weekday(D.MyDateTime,2) <=5)"   '2=vbMonday 
329         Case 2   'weekend 
330            vWhere = (vWhere + " And ") & " (Weekday(D.MyDateTime,2) >5)"    '2=vbMonday 
331         End Select 
332     
333          'see if dates were specified
334         Select Case True 
335     
336          'start date
337         Case Not IsNull(Me.Date1) And IsNull(Me.Date2) 
338            vWhere = (vWhere + " And ") & "(" & sDateEquation & " >= #" & Me.Date1 & "#)" 
339            vFooter = (vFooter + ", ") & " Date >= " & Format(Me.Date1, "short date") 
340     
341          'end date
342         Case IsNull(Me.Date1) And Not IsNull(Me.Date2) 
343            vWhere = (vWhere + " And ") & "(" & sDateEquation & " <= #" & Me.Date2 & "#)" 
344            vFooter = (vFooter + ", ") & " Date <= " & Format(Me.Date2, "short date") 
345     
346          'date range
347         Case Not IsNull(Me.Date1) And Not IsNull(Me.Date2) 
348     
349            vWhere = (vWhere + " And ") & "(" & sDateEquation & " Between #" & Me.Date1 _ 
350               & "# And #" & Me.Date2 & "#)" 
351     
352            vFooter = (vFooter + ", ") & " Between " _ 
353               & Format(Me.Date1, "short date") & " And " & Format(Me.Date2, "short date") 
354     
355          'no dates specified
356         Case Else 
357            On Error Resume Next 
358            vFooter = (vFooter + ", ") & " Date from " _ 
359               & Format(Nz(DMin("ChtDate", "qGraph"), 0), "short date") _ 
360               & " To " & Format(Nz(DMax("ChtDate", "qGraph"), 0), "short date") 
361            On Error GoTo Proc_Err 
362     
363         End Select 
364     
365          '-------------------------------------- SQL
366         sSQL = "SELECT " & sDateEquation & " As ChtDate, " 
367         With Me.fraFunction 
368            Select Case .Value 
369            Case 2 
370               sSQL = sSQL & " Avg" 
371            Case 1 
372               sSQL = sSQL & " Sum" 
373            Case Else 
374                'do nothing
375            End Select 
376         End With   'Me.fraFunction 
377     
378         sSQL = sSQL & "(D.MyValue) As ChtValue " _ 
379            & " FROM t_GraphTopics As T " _ 
380            & " INNER JOIN t_GraphData As D On T.MyTopicID = D.MyTopicID" 
381     
382         If Not IsNull(vWhere) Then 
383            sSQL = sSQL & " WHERE " & vWhere 
384         End If 
385     
386         With Me.fraFunction 
387            If .Value = 1 Or .Value = 2 Then 
388               sSQL = sSQL & " GROUP BY " & sDateEquation 
389            End If 
390         End With 
391     
392         sSQL = sSQL & ";" 
393       'Stop
394     
395          '-------------------------------------- Make Query
396         loc_MakeQuery sSQL, "qGraph" 
397     
398         DoCmd.OpenForm "f_Graph" 
399     
400      Proc_Exit: 
401         Exit Sub 
402     
403      Proc_Err: 
404         MsgBox Err.Description, , _ 
405              "ERROR " & Err.Number _ 
406              & "   cmd_Chart_Click : " & Me.Name 
407     
408         Resume Proc_Exit 
409         Resume 
410      End Sub 

411     
412      Private Sub cmd_ResetData_Click() 
413       '11-24, 140810
414         Call ResetCriteria 
415      End Sub 

416     
417      Private Function ResetCriteria() 
418     
419         On Error GoTo Proc_Err 
420         Me.Date1 = Null 
421         Me.Date2 = Null 
422         Me.MyTopicID = Null 
423         Me.MyOtherID1 = Null 
424         Me.MyOtherID2 = Null 
425     
426         Me.fraFunction = 1 
427         loc_BoldMe Me, "fraFunction", 2, 1 
428     
429         Me.fraDays = 3 
430         loc_BoldMe Me, "fraDays", 3, 1 
431     
432         Me.fraScale = 1 
433         loc_BoldMe Me, "fraScale", 3, 2 
434     
435         Me.txtTitle = GetTitle() 
436         Me.txtValueFormat = "#,##0" 
437     
438         Me.txtFooter = Null     'Call Calc_Footer 
439         Call Calc_Header 
440         Call Calc_Scale 
441         Call Calc_Title 
442     
443      Proc_Exit: 
444         On Error Resume Next 
445         Exit Function 
446     
447      Proc_Err: 
448         MsgBox Err.Description, , _ 
449              "ERROR " & Err.Number _ 
450              & "   ResetCriteria : " & Me.Name 
451     
452         Resume Proc_Exit 
453         Resume 
454      End Function 

455     
456        '===================================== local copies of general procedures
457     
458       '~~~~~~~~~~~~~~~~~~~~~~~~~~ loc_MakeQuery
459     
460      Private Sub loc_MakeQuery( _ 
461         ByVal pSQL As String, _ 
462         ByVal qName As String) 
463     
464          'modified 6-3-08
465          'crystal
466          'strive4peace2009 at yahoo dot com
467     
468         On Error GoTo Proc_Err 
469     
470      Debug.Print pSQL 
471     
472          'if query already exists, update the SQL
473          'if not, create the query
474     
475          If Nz(DLookup("[Name]", "MSysObjects", _ 
476              "[Name]='" & qName _ 
477              & "' And [Type]=5"), "") = "" Then 
478              CurrentDb.CreateQueryDef qName, pSQL 
479          Else 
480              'if query is open, close it
481             On Error Resume Next 
482             DoCmd.Close acQuery, qName, acSaveNo 
483             On Error GoTo Proc_Err 
484             CurrentDb.QueryDefs(qName).SQL = pSQL 
485          End If 
486     
487         CurrentDb.QueryDefs.Refresh 
488         DoEvents 
489     
490      Proc_Exit: 
491         On Error Resume Next 
492         Exit Sub 
493     
494      Proc_Err: 
495         MsgBox Err.Description, , _ 
496           "ERROR " & Err.Number & "  loc_MakeQuery" 
497     
498         Resume Proc_Exit 
499         Resume 
500     
501      End Sub 

502     
503       '~~~~~~~~~~~~~~~~~~~~~~~~~~ loc_BoldMe
504      Private Function loc_BoldMe(Optional pF As Form _ 
505         , Optional pControlname As String = "" _ 
506         , Optional pNumOptions As Integer = 0 _ 
507         , Optional pValue As Variant _ 
508         ) As Byte 
509       '9-9-08,12-4-09, 140810
510     
511          'Crystal
512          'strive4peace2009 at yahoo dot com
513     
514          'Bold the label is the option is chosen or value is true
515          'remove Bold is the value is not true or the option is not chosen
516     
517          ' --------------------------------------------------------
518          'PARAMETERS
519          '  pF = form reference
520          '       if in code behind a form, this is
521          '                   Me
522          '
523          '  pControlName is name of control to test
524          '               if not specified, ActiveControl will be used
525          '
526          '  pNumOptions is the number of options in the frame (group)
527          '              must be specified for option frame
528          '
529          '  pValue is the comparison value for deciding Bold
530          '         if parameter is passed
531          '         then the opn frame will not be tested
532          '
533          '               unbound Labels MUST be named like this:
534          '               Label_Controlname
535          '
536          '               NOTE: the "label" control
537          '                         does not have to be a label ControlType
538          '                     It can be, for instance, a textbox
539          ' --------------------------------------------------------
540          ' NOTES
541          '
542          ' for checkboxes and toggle buttons
543          '
544          '               if checkbox Name = MyCheckbox
545          '                  then label Name = Label_MyCheckbox
546          '
547          ' for options in a frame
548          '
549          '    if Frame Name = MyOptionFrame
550          '
551          '    then Frame Option Buttons are Named:
552          '          MyOptionFrame1, MyOptionFrame2, etc
553          '
554          '    Labels for Frame Option Buttons are Named:
555          '          Label_MyOptionFrame1, Label_MyOptionFrame2, etc
556          '
557          '    Numbers in the name correspond to the Option Value
558          '
559          '    Option Values can be any number
560          '
561     
562          ' --------------------------------------------------------
563          'USEAGE
564          '   loc_BoldMe Me
565          '       Bold the label of the
566          '         active checkbox or toggle control
567          '       if the control value = True
568          '
569          '   loc_BoldMe Me, "Mycheckbox_controlname"
570          '       Bold the label of the
571          '         specified checkbox or toggle control
572          '       if the control value = True
573          '
574          '   loc_BoldMe Me, "Mycheckbox_controlname",,True
575          '       Bold the label of the
576          '         specified checkbox or toggle control
577          '
578          '   loc_BoldMe Me, "MyFrame_controlname", 4
579          '       Bold the label of the option
580          '            in the specified frame control
581          '            if the Option Value = the Frame Value
582          '       where there are 4 options to pick from
583          '
584          '   loc_BoldMe Me, "MyFrame_controlname", 4, 999
585          '       Bold the label of the option
586          '            in the specified frame control
587          '            if the Option Value = 999
588          '       where there are 4 options to pick from
589          '
590     
591     
592         On Error GoTo Proc_Err 
593     
594         If pF Is Nothing Then Set pF = Screen.ActiveForm 
595     
596         Dim mBoo As Boolean _ 
597            , mControlName As String _ 
598            , mControlnameOption As String _ 
599            , sLabelname As String 
600     
601         If Len(pControlname) > 0 Then 
602            mControlName = pControlname 
603         Else 
604            mControlName = pF.ActiveControl.Name 
605         End If 
606     
607         If IsMissing(pValue) Then 
608            pValue = pF(mControlName).Value 
609         End If 
610     
611     
612     
613          ' use WITH to minimize the number of times
614          ' this code has to access the object
615     
616          'checkbox or toggle button
617         With pF(mControlName) 
618     
619            Select Case .ControlType 
620            Case acCheckBox, acToggleButton 
621     
622               If IsMissing(pValue) Then 
623                  mBoo = Nz(.Value, False) 
624               Else 
625                   'note: Null cannot be passed
626                  mBoo = pValue 
627               End If 
628     
629               If .Controls.Count > 0 Then 
630                   sLabelname = .Controls(0).Name 
631               Else 
632                  sLabelname = "Label_" & mControlName 
633               End If 
634     
635               With pF(sLabelname) 
636                   ' see if Bold is already right
637                  If .FontBold <> mBoo Then 
638                      ' Bold needs to change
639                     .FontBold = mBoo 
640                  End If 
641               End With 
642     
643               GoTo Proc_Exit 
644     
645             'option box - MUST SPECIFY pNumOptions
646            Case acOptionGroup 
647     
648               Dim i As Integer 
649     
650               For i = 1 To pNumOptions 
651                  mControlnameOption = mControlName & Format(i, "0") 
652                  With pF(mControlnameOption) 
653     
654       '               If .Controls.Count > 0 Then
655       '                   sLabelname = .Controls(0).Name
656       '               Else
657       '                  sLabelname = "Label_" & mControlName
658       '               End If
659                     On Error Resume Next 
660                     sLabelname = .Controls(0).Name 
661                     If Err.Number > 0 Then 
662                        sLabelname = "Label_" & mControlName 
663                     End If 
664                     On Error GoTo Proc_Err 
665     
666                     If IsNull(pValue) Then 
667                         ' if the comparison is blank
668                         ' no option will be bolded
669                        mBoo = False 
670                     Else 
671                         ' if the option value = the comparison value
672                         ' then mBoo = TRUE
673                        mBoo = IIf( _ 
674                        pF(mControlnameOption).OptionValue = pValue, True, False) 
675                     End If 
676     
677                     With pF(sLabelname) 
678                        If .FontBold <> mBoo Then 
679                           .FontBold = mBoo 
680                        End If 
681                     End With 
682                  End With 
683     
684               Next i 
685     
686               GoTo Proc_Exit 
687     
688            End Select 
689     
690         End With 
691     
692      Proc_Exit: 
693         On Error Resume Next 
694         pF.Repaint 
695         Exit Function 
696     
697      Proc_Err: 
698         MsgBox Err.Description _ 
699            , , "ERROR " & Err.Number & "  loc_BoldMe " & mControlName 
700     
701         Resume Proc_Exit 
702     
703          'if you want to single-step code to find error, CTRL-Break at MsgBox
704          'then set this to be the next statement
705         Resume 
706     
707      End Function 

708     
709     
710      Private Function SetControl_RowSource( _ 
711         pCtl As Control _ 
712         , Optional ByVal psWhere As String = "" _ 
713         , Optional booClearValue As Boolean = False _ 
714         , Optional booClearIfNotInList As Boolean = False _ 
715         , Optional psOrderBy As String = "" _ 
716         ) 
717       '131017 strive4peace, 131023, 1029, 1218, 140421
718          'ASSUMPTIONs:
719          '  .Tag contains SQL for the control
720          '     if there is a WHERE clause, it will be appended.
721          '     if not, it will be added
722          '  SQL has an ORDER BY clause
723          '
724          ' CALLS
725          '  loc_GetSQL_WHERE
726          '  loc_GetSQL_ORDERBY
727          '  booClearIfNotInList
728     
729         On Error GoTo Proc_Err 
730     
731         Dim sSQL As String 
732     
733         sSQL = pCtl.Tag 
734         If psOrderBy <> "" Then 
735            sSQL = loc_GetSQL_ORDERBY(sSQL, psOrderBy) 
736         End If 
737         sSQL = loc_GetSQL_WHERE(sSQL, psWhere) 
738     
739         With pCtl 
740     
741            If .RowSource <> sSQL Then 
742       'Debug.Print pCtl.Name, psWhere
743       'Debug.Print sSQL
744     
745               .RowSource = sSQL 
746       '         On Error Resume Next
747               .Requery 
748       '         On Error Resume Next
749               If booClearValue Then 
750                  .Value = Null 
751               ElseIf booClearIfNotInList Then 
752                  If Not IsNull(.Value) Then 
753                     If CStr(Nz(.Value)) <> Nz(.Column(0)) Then 
754                        .Value = Null 
755                     End If 
756                  End If 
757               End If 
758            End If 
759         End With   'pCtl 
760     
761      Proc_Exit: 
762         On Error Resume Next 
763         Exit Function 
764     
765      Proc_Err: 
766         MsgBox Err.Description, , _ 
767              "ERROR " & Err.Number _ 
768              & "   SQL_AddWhere" 
769     
770         Resume Proc_Exit 
771         Resume 
772      End Function 

773     
774      Private Function loc_GetSQL_ORDERBY( _ 
775            ByVal pSQL As String _ 
776            , ByVal psOrderBy As String _ 
777            , Optional ByVal pbooAdd As Boolean = False _ 
778            ) As String 
779       'strive4peace, 140421
780       'add/replace OrderBy clause of SQL string, if specified
781     
782       'strive4peace, 140121
783         On Error GoTo Proc_Err 
784         Dim iPos As Integer 
785     
786         If Not Len(psOrderBy) > 0 Then 
787             'no change
788            loc_GetSQL_ORDERBY = pSQL     'same as what was sent 
789            Exit Function 
790         End If 
791     
792         pSQL = Trim(pSQL) 
793     
794          'look for ORDER BY
795         iPos = InStr(pSQL, "ORDER BY ") 
796     
797          'look for ORDER BY
798         If iPos > 0 Then 
799            If pbooAdd Then 
800               If Len(psOrderBy) > 0 Then 
801                   'add to beginning of ORDER BY clause
802                  pSQL = Replace(pSQL, "ORDER BY " _ 
803                                    , " ORDER BY " & psOrderBy & ", ") 
804               End If 
805            Else 
806               If Len(psOrderBy) > 0 Then 
807                   'replace ORDER BY clause
808                  pSQL = Left(pSQL, iPos + 8) & psOrderBy & ";" 
809               Else 
810                   'remove ORDER BY clause
811                  pSQL = Left(pSQL, iPos - 1) & ";" 
812               End If 
813     
814            End If 
815     
816         Else   'no ORDER BY clause in the SQL 
817            If Len(psOrderBy) > 0 Then 
818                'add to end
819               iPos = Len(pSQL) 
820               If Right(pSQL, 1) = ";" Then 
821                  iPos = iPos - 1 
822               End If 
823               pSQL = Left(pSQL, iPos) _ 
824                            & " ORDER BY " & psOrderBy & ";" 
825            Else 
826                'no change
827            End If 
828         End If 
829     
830         loc_GetSQL_ORDERBY = pSQL 
831      Proc_Exit: 
832            On Error Resume Next 
833            Exit Function 
834     
835      Proc_Err: 
836          '   MsgBox Err.Description, , _
837              "ERROR " & Err.Number _
838              & "   loc_GetSQL_ORDERBY"
839         loc_GetSQL_ORDERBY = pSQL 
840         Resume Proc_Exit 
841         Resume 
842      End Function 

843     
844     
845      Private Function loc_GetSQL_WHERE( _ 
846            ByVal pSQL As String _ 
847            , ByVal psWhere As String _ 
848            , Optional pbooAdd As Boolean = False _ 
849            ) As String 
850       'strive4peace
851       'add or replace criteria to/in the WHERE clause of an SQL string, if specified
852       'future: remove Where if not specified
853     
854       'strive4peace ... 131204, 140120, 140623
855       'add criteria to the WHERE clause of an SQL string. Create if Where is not there.
856       'will FAIL if fieldname ends with 'where', 'group by', ' having', 'order by'
857         On Error GoTo Proc_Err 
858         Dim iPos As Integer _ 
859             , iPos2 As Integer 
860     
861       '   If Not Len(psWhere) > 0 Then
862       '      'no change
863       '      loc_GetSQL_WHERE = pSQL   'same as what was sent
864       '      Exit Function
865       '   End If
866     
867         pSQL = Trim(pSQL) 
868     
869          'look for WHERE
870         iPos = InStr(pSQL, "WHERE ") 
871     
872         If iPos > 0 Then 
873            If pbooAdd Then 
874                'add to beginning of WHERE clause
875               If Len(psWhere) > 0 Then 
876                  pSQL = Replace(pSQL, "WHERE " _ 
877                                    , " WHERE (" & psWhere & ")" & " And ") 
878               End If 
879            Else 
880                'replace WHERE clause
881               iPos2 = InStr(iPos + 1, pSQL, "GROUP BY ") 
882               If Not iPos2 > 0 Then 
883                  iPos2 = InStr(iPos + 1, pSQL, "HAVING ") 
884                  If Not iPos2 > 0 Then 
885                     iPos2 = InStr(iPos + 1, pSQL, "ORDER BY ") 
886                  End If 
887               End If 
888               If Not iPos2 > 0 Then 
889                  iPos2 = Len(pSQL) 
890                  If Right(pSQL, 1) = ";" Then 
891                     iPos2 = iPos2 - 1 
892                  End If 
893               End If 
894               If Len(psWhere) > 0 Then   '140623 - 5 
895                  pSQL = Left(pSQL, iPos + 5) _ 
896                              & psWhere & " " & Mid(pSQL, iPos2) 
897               Else 
898                   'remove WHERE clause
899                  pSQL = Left(pSQL, iPos - 1) _ 
900                              & Mid(pSQL, iPos2) 
901               End If 
902            End If 
903         Else 
904            If Len(psWhere) > 0 Then 
905                'create WHERE clause
906                'look for GROUP BY
907               If (InStr(pSQL, "GROUP BY ")) > 0 Then 
908                   'put before 'GROUP BY'
909                  pSQL = Replace(pSQL, "GROUP BY " _ 
910                                       , " WHERE " & psWhere & " GROUP BY ") 
911                   'look for HAVING
912               ElseIf (InStr(pSQL, "HAVING")) > 0 Then 
913                   'put before 'Having'
914                  pSQL = Replace(pSQL, "HAVING " _ 
915                                       , " WHERE " & psWhere & " HAVING ") 
916               Else 
917                   'look for ORDER BY
918                  If (InStr(pSQL, "ORDER BY ")) > 0 Then 
919                     pSQL = Replace(pSQL, "ORDER BY " _ 
920                                          , " WHERE " & psWhere & " ORDER BY ") 
921                  Else 
922                      'add to end
923                     iPos = Len(pSQL) 
924                     If Right(pSQL, 1) = ";" Then 
925                        iPos = iPos - 1 
926                     End If 
927                     pSQL = Left(pSQL, iPos) _ 
928                            & " WHERE " & psWhere & ";" 
929                  End If 
930               End If 
931            End If 
932         End If 
933         loc_GetSQL_WHERE = pSQL 
934      Proc_Exit: 
935            On Error Resume Next 
936            Exit Function 
937     
938      Proc_Err: 
939          '   MsgBox Err.Description, , _
940              "ERROR " & Err.Number _
941              & "   loc_GetSQL_WHERE"
942         loc_GetSQL_WHERE = pSQL 
943         Resume Proc_Exit 
944         Resume 
945      End Function 

946     
947     
948     
949      Private Sub Label_send_email_Click() 
950       '140809
951         On Error Resume Next 
952         Application.FollowHyperlink _ 
953            "mailto: strive4peace2008@yahoo.com?subject=Graph Example comment" 
954      End Sub 

955     
956      Private Sub MyOtherID1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
957       '140808
958         Me.ActiveControl.Dropdown 
959      End Sub 

960     
961      Private Sub MyOtherID2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
962       '140808
963         Me.ActiveControl.Dropdown 
964      End Sub 
965     
966     

1        Option Compare Database 
2        Option Explicit 
3         '
4         'Crystal strive4peace June 2012
5         '
6         ' POPUP a calendar to choose dates
7         ' updates the ActiveControl with DATE
8         ' ... and, optionally, TIME
9         '=======================================================
10        '
11        ' code behind form: f_PopupCalendar
12        '
13        '============================================================ LICENSE NOTICE -- must not be modified
14        ' This software is licensed to you under CC BY-NC-SA 3.0
15        '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
16        ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
17        '
18        ' You are free to:
19        '    Share — copy and redistribute the material in any medium or format
20        '    Adapt — remix, transform, and build upon the material
21        ' The licensor cannot revoke these freedoms as long as you follow these terms:
22        '    Attribution — You must give appropriate credit, provide a link to the license,
23        '                   and indicate if changes were made.
24        '                   You may do so in any reasonable manner,
25        '                   but not in any way that suggests the licensor endorses you or your use.
26        '    NonCommercial — You may not use the material for commercial purposes.
27        '    ShareAlike — If you remix, transform, or build upon the material,
28        '                 you must distribute your contributions under the same license as the original.
29        '
30        ' many procedures and module names contain author or controbitor names that must be left intact
31        ' if you make changes, add your name, date, and descriptive information to the comments
32        '
33        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629
34        ' ~ Crystal
35        '              * have an awesome day :)
36        '                                                   www.AccessMVP.com/strive4peace
37        ' END LICENSE NOTICE
38        '============================================================
39        '
40        ' me.txtCalendarDate holds the calendar date
41        ' me.txtHr, me.txtMin, Me.txtAP --> time
42        '
43        ' the sub Update_ExternalForms is for YOU to customize
44        '                              in case you want to synchronize the calendar with other forms
45        '                              ...if not, this was designed as a popup
46        '
47        '  if you want to prompt for time, put "Time" in the control tag
48        '  otherwise, only if there is a time component will time will be turned on
49        '     if you want time to intialize to current time, put "Now" in the tag
50      
51        '
52        ' Download popup calendar from:  Rogers Access Library
53        ' http://www.RogersAccessLibrary.com/forum/popup-calendar-for-access-2007-and-above_topic597.html
54        '
55      
56        '
57       Dim mActiveControl As Control   ' Open 
58       Dim mPickDate As Date   ' Open 
59       Dim gBooTime As Boolean   ' Load 

60      
61        '-------------------------------------------------------------------- external forms -- CUSTOMIZE
62        '---------------------------------------- Update_ExternalForms
63       Public Sub Update_ExternalForms(pDate As Variant) 
64        '120626
65        'FormName -- .txtDate = pDate, .ProcedureName CDate(pDate)
66      
67        ' CALLED BY
68           ' DayClick, buttons to change calendar day,
69           ' and from code behind other forms (FormName)
70           ' runs ProcedureName in code behind FormName
71      
72        '    On Error GoTo Proc_Err
73      
74        '    If CurrentProject.AllForms("FormName").IsLoaded Then
75        '        With Forms!FormName
76        '            .txtDate = pDate
77        '            DoEvents
78        '            .ProcedureName CDate(pDate) 'run code behind the form and pass the date
79        '        End With
80        '    End If
81      
82       Proc_Exit: 
83        '   On Error Resume Next
84          Exit Sub 
85      
86       Proc_Err: 
87          MsgBox Err.Description, , _ 
88              "ERROR " & Err.Number _ 
89               & "   Update_ExternalForms : " & Me.Name 
90      
91          Resume Proc_Exit 
92          Resume 
93       End Sub 

94      
95       Private Sub cmd_Cancel_Click() 
96        '120626
97          On Error Resume Next 
98          DoCmd.Close acForm, Me.Name, acSaveNo 
99       End Sub 

100     
101      Private Sub cmd_Close_Click() 
102       '120626, 27, 131105
103         On Error Resume Next 
104     
105         Dim nDate As Date 
106     
107         nDate = DateValue(Me.txtCalendarDate) 
108     
109          'add time to date if time controls are showing
110         If Me.chkUseTime Then 
111       '      If CInt(Nz(Me.txtHr, "0")) > 0 Or CInt(Nz(Me.txtMin, "0")) > 0 Then
112               nDate = nDate _ 
113                  + TimeSerial(Nz(Me.txtHr, 0) _ 
114                     + IIf(InStr(Me.txtAP, "p") > 0 And Nz(Me.txtHr) < 12, 12, 0) _ 
115                  , Nz(Me.txtMin, 0), 0) 
116       '      End If
117         End If 
118     
119       '   If Not Len(Nz(Me.OpenArgs, "")) > 0 Then
120             'will throw an error if mActiveControl is not defined
121             '   ie: maybe there was no active form when the date picker was launched
122             '       or there was an unhandled error and the object variable was lost
123            mActiveControl = nDate 
124            If mActiveControl <> nDate Then 
125                'form was opened independently
126                'tell user how to get this feature into another database
127               ShowDatePickerMessage 
128            End If 
129       '   Else
130       '      'set database property or Tempvar or write value to someplace else
131       '
132       '   End If
133     
134         DoCmd.Close acForm, Me.Name, acSaveNo 
135     
136      End Sub 

137     
138      Private Function UseTheTime(pBoo As Boolean) 
139       '120626, 27
140         On Error Resume Next 
141         Me.chkUseTime = pBoo 
142         Me.Label_chkUseTime.FontBold = pBoo 
143     
144         If Me.txtAP.Visible <> pBoo Then 
145            cal_ShowHideControlsTag pBoo, "Time" 
146         End If 
147     
148      End Function 

149     
150      Private Sub cmd_CurrentTime_Click() 
151       '120626
152         On Error Resume Next 
153     
154         UseTheTime True 
155         Me.txtHr.Value = Hour(Now()) Mod 12 
156         Me.txtMin.Value = Minute(Now()) 
157         Me.txtAP = IIf(DatePart("h", Now()) >= 12, "pm", "am") 
158         Me.txtHr.SetFocus 
159      End Sub 

160     
161      Private Sub cmdMonth_Click() 
162       '120627
163         On Error Resume Next 
164         MsgBox cal_GetBirthstone(Month(Me.txtCalendarDate)), , "Birthstone For " & Me.cmdMonth.Caption 
165     
166      End Sub 

167     
168      Private Sub cmdYr_Click() 
169       '120627
170         On Error Resume Next 
171          'year in roman numbers
172          'get Chinese zodiac animal?
173         Dim nYear As Integer 
174         nYear = CInt(Me.cmdYr.Caption) 
175         MsgBox cal_GetRoman(nYear), , nYear & " In Roman Numbers" 
176      End Sub 

177     
178       '-------------------------------------------------------------------- FORM
179      Private Sub Form_Open(Cancel As Integer) 
180       '...120626, 27, 131103, 05
181       '130903 use StatusBarText -- truncate caption when 4 spaces reached
182     
183         Dim sStr As String _ 
184            , iPos As Integer _ 
185            , nTime As Date 
186     
187         On Error Resume Next 
188         mPickDate = -99 
189     
190         sStr = Trim(Screen.ActiveForm.Caption & "") 
191         If Err.Number > 0 Then GoTo Proc_Exit 
192         If Len(sStr) = 0 Then 
193             'if the frm doesn't have a caption, use the name
194            sStr = Screen.ActiveForm.Name 
195         End If 
196         Me.myFormCaption = sStr 
197     
198         Set mActiveControl = Screen.ActiveControl 
199     
200          'see if Time is specified in the control Tag
201         gBooTime = IIf(InStr(mActiveControl.Tag, "Time") > 0, True, False) 
202     
203         Select Case True 
204     
205         Case Len(Nz(Me.OpenArgs, "")) > 0 
206            sStr = Me.OpenArgs 
207            If IsDate(sStr) And CLng(CDbl(sStr) * 1000) <> 0 Then 
208               If IsDate(sStr) Then 
209                  mPickDate = CDate(sStr) 
210               End If 
211            End If 
212     
213         Case IsDate(mActiveControl) 
214            If Not mActiveControl = 0 Then 
215               mPickDate = mActiveControl.Value 
216            End If 
217         End Select 
218     
219         With mActiveControl 
220            sStr = .Controls(0).Caption 
221            If Err.Number > 0 Then 
222               If Len(.StatusBarText & " ") > 1 Then 
223                  sStr = .StatusBarText 
224                  iPos = InStr(sStr, "    ") 
225                      'if the status bar text has an information message preceeded by 4 spaces, it is stripped
226                      'ie: Order Date     DOUBLE-CLICK to POPUP CALENDAR
227                  If iPos > 0 Then sStr = Left(sStr, iPos) 
228               Else 
229                  sStr = .Name 
230               End If 
231            Else 
232                'using label caption
233                'strip colon: at end
234               If Right(sStr, 1) = ":" Then sStr = Left(sStr, Len(sStr) - 1) 
235            End If 
236         End With 
237     
238         Me.myControlCaption = Trim(sStr) 
239     
240          'if pick date is not set yet
241         If mPickDate < 0 Then 
242             'set to current date
243            mPickDate = Date 
244            If gBooTime Then 
245               If InStr(mActiveControl.Tag, "Now") > 0 Then 
246                   'set to current date and time
247                  mPickDate = Now() 
248               End If 
249            Else 
250            End If 
251         End If 
252     
253         If Not gBooTime And mPickDate <> DateValue(mPickDate) Then gBooTime = True 
254     
255         cal_ShowHideControlsTag gBooTime, "Time" 
256     
257      Proc_Exit: 
258         Exit Sub 
259     
260      End Sub 

261     
262      Private Sub Form_Load() 
263       '120514, commented 120622, 23, 131105
264          'sets the calendar to TODAY
265          'unless a date is in the active control
266          ' or a date is passed in the OpenArgs
267     
268       ' CALLS
269          ' cal_cal_GetRow4Calendar
270          ' cal_cal_GetCol4Calendar
271          ' Set_Calendar
272          ' cal_ShowHideControlsTag
273     
274          On Error GoTo Proc_Err 
275     
276          Dim nRow As Integer _ 
277            , nCol As Integer _ 
278               , iPos As Integer _ 
279               , nDate As Date _ 
280               , sStr As String 
281     
282         nDate = mPickDate   'set in Open event 
283     
284          'openArgs
285     
286         nRow = cal_GetRow4Calendar(nDate) 
287         nCol = cal_GetCol4Calendar(nDate) 
288     
289          'keep track so colors can be set back to normal
290     
291         Me.txtRowPick = nRow 
292         Me.txtColPick = nCol 
293         Me.txtRowCur = nRow 
294         Me.txtColCur = nCol 
295         Me.txtCalendarDate = nDate 
296     
297         Me.chkUseTime = gBooTime 
298     
299         If gBooTime Then 
300            Me.txtMin = Minute(nDate) 
301            If Hour(nDate) > 12 Then 
302               Me.txtHr = Hour(nDate) - 12 
303               Me.txtAP = "pm" 
304            Else 
305               Me.txtHr = Hour(nDate) 
306               Me.txtAP = "am" 
307            End If 
308         End If 
309     
310         Set_Calendar nDate 
311         Me.txtDate.SetFocus 
312     
313      Proc_Exit: 
314         On Error Resume Next 
315         Exit Sub 
316     
317      Proc_Err: 
318         MsgBox Err.Description, , _ 
319             "ERROR " & Err.Number _ 
320              & "   Form_Load : " & Me.Name 
321     
322         Resume Proc_Exit 
323         Resume 
324      End Sub 

325     
326       '-------------------------------------------------------------------- CHANGE CALENDAR DAY
327      Public Sub DayClick() 
328       '... 120622
329     
330       ' CALLS
331          ' Set_Calendar
332          ' Update_ExternalForms
333     
334          On Error GoTo Proc_Err 
335          If Me.ActiveControl.Caption = "" Then 
336               'user clicked on a day with no number - do nothing
337              Exit Sub 
338          End If 
339     
340          Dim nRow As Integer _ 
341              , nCol As Integer 
342     
343          Dim nDate As Date _ 
344              , nOldDate As Date _ 
345              , nDay As Integer 
346     
347          nDay = Me.ActiveControl.Caption 
348     
349          nOldDate = Me.txtCalendarDate 
350     
351          nDate = DateSerial(Year(nOldDate), Month(nOldDate), nDay) 
352     
353          Set_Calendar nDate 
354          Update_ExternalForms nDate 
355     
356      Proc_Exit: 
357         On Error Resume Next 
358         Exit Sub 
359     
360      Proc_Err: 
361         MsgBox Err.Description, , _ 
362             "ERROR " & Err.Number _ 
363              & "   DayClick : " & Me.Name 
364     
365         Resume Proc_Exit 
366         Resume 
367      End Sub 

368     
369      Private Sub cmd_Reset_Click() 
370       '120627
371       'reset date back to original pick
372         On Error Resume Next 
373     
374         Dim nDate As Date 
375         nDate = mPickDate 
376     
377         Me.txtCalendarDate = nDate 
378     
379         UseTheTime gBooTime 
380     
381         cal_ShowHideControlsTag gBooTime, "Time" 
382     
383         If gBooTime Then 
384            Me.txtMin = Minute(nDate) 
385            If Hour(nDate) > 12 Then 
386               Me.txtHr = Hour(nDate) - 12 
387               Me.txtAP = "am" 
388            Else 
389               Me.txtHr = Hour(nDate) 
390               Me.txtAP = "pm" 
391            End If 
392         End If 
393     
394         Add_SetCalendar nDate, 0, 1, 0 
395         Update_ExternalForms nDate 
396     
397     
398      End Sub 

399     
400      Private Sub cmd_AddDays_Click() 
401       '120627
402         Dim nDays As Long 
403     
404         If IsNull(Me.txtDays) Then 
405            Me.txtDays.SetFocus 
406            MsgBox "Specify number of days To add Or subtract", , "Can't add days, no number specified" 
407            Exit Sub 
408         End If 
409         nDays = Me.txtDays 
410         If nDays = 0 Then 
411            Me.txtDays.SetFocus 
412            MsgBox "Specify number of days To add Or subtract", , "Can't add days, no number specified" 
413            Exit Sub 
414         End If 
415     
416         Dim nDate As Date 
417         nDate = Me.txtCalendarDate 
418     
419         nDate = DateSerial(Year(nDate), Month(nDate), Day(nDate) + nDays) 
420     
421         Set_Calendar nDate 
422         Update_ExternalForms nDate 
423     
424     
425      End Sub 

426     
427     
428      Private Sub cmd_Now_Click() 
429       '120626, 27
430         On Error Resume Next 
431     
432         Dim nDate As Date 
433         nDate = Date 
434     
435         Me.txtCalendarDate = nDate 
436     
437         Set_Calendar nDate 
438         Update_ExternalForms nDate 
439     
440         UseTheTime True 
441         cmd_CurrentTime_Click 
442     
443      End Sub 

444     
445      Private Sub cmdMonthAdd_Click() 
446       '120512, 120622
447       ' CALLS
448          ' Add_SetCalendar
449          ' Update_ExternalForms
450     
451          On Error GoTo Proc_Err 
452          Dim nDate As Date 
453          nDate = Me.txtCalendarDate 
454          Add_SetCalendar nDate, 0, 1, 0 
455          Update_ExternalForms nDate 
456     
457      Proc_Exit: 
458         On Error Resume Next 
459         Exit Sub 
460      Proc_Err: 
461         Resume Proc_Exit 
462      End Sub 

463     
464      Private Sub cmdMonthSub_Click() 
465       '120512 Crystal, 120622
466           'move calendar back one month
467       '
468       ' CALLS
469          ' Add_SetCalendar
470          ' Update_ExternalForms
471         On Error Resume Next 
472     
473         Dim nDate As Date 
474         nDate = Me.txtCalendarDate 
475         Add_SetCalendar nDate, 0, -1, 0 
476         Update_ExternalForms nDate 
477     
478      End Sub 

479     
480     
481     
482      Private Sub cmdYrAdd_Click() 
483       '120512, 120622
484       ' CALLS
485          ' Add_SetCalendar
486          ' Update_ExternalForms
487     
488          Dim nDate As Date 
489          nDate = Me.txtCalendarDate 
490          Add_SetCalendar nDate, 1, 0, 0 
491          Update_ExternalForms nDate 
492     
493      Proc_Exit: 
494         On Error Resume Next 
495         Exit Sub 
496      Proc_Err: 
497         Resume Proc_Exit 
498      End Sub 

499     
500      Private Sub cmdYrSub_Click() 
501       '120512, 120622
502       ' CALLS
503          ' Add_SetCalendar
504          ' Update_ExternalForms
505     
506          Dim nDate As Date 
507          nDate = Me.txtCalendarDate 
508          Add_SetCalendar nDate, -1, 0, 0 
509          Update_ExternalForms nDate 
510     
511      Proc_Exit: 
512         On Error Resume Next 
513         Exit Sub 
514      Proc_Err: 
515         Resume Proc_Exit 
516      End Sub 

517     
518     
519      Private Sub cmd_M6add_Click() 
520       '120625
521       ' CALLS
522          ' Add_SetCalendar
523          ' Update_ExternalForms
524     
525          On Error GoTo Proc_Err 
526          Dim nDate As Date 
527          nDate = Me.txtCalendarDate 
528          Add_SetCalendar nDate, 0, 6, 0 
529          Update_ExternalForms nDate 
530     
531      Proc_Exit: 
532         On Error Resume Next 
533         Exit Sub 
534      Proc_Err: 
535         Resume Proc_Exit 
536      End Sub 

537     
538      Private Sub cmd_M6sub_Click() 
539       '120625
540       ' CALLS
541          ' Add_SetCalendar
542          ' Update_ExternalForms
543     
544          On Error GoTo Proc_Err 
545          Dim nDate As Date 
546          nDate = Me.txtCalendarDate 
547          Add_SetCalendar nDate, 0, -6, 0 
548          Update_ExternalForms nDate 
549     
550      Proc_Exit: 
551         On Error Resume Next 
552         Exit Sub 
553      Proc_Err: 
554         Resume Proc_Exit 
555      End Sub 

556     
557      Private Sub cmd_Today_Click() 
558       '120512, 120622
559       ' CALLS
560          ' Set_Calendar
561          ' Update_ExternalForms
562     
563          On Error GoTo Proc_Err 
564          Set_Calendar Date 
565          Update_ExternalForms Date 
566     
567      Proc_Exit: 
568         On Error Resume Next 
569         Exit Sub 
570      Proc_Err: 
571         Resume Proc_Exit 
572      End Sub 

573     
574      Private Sub cmd_W1add_Click() 
575       '120625
576       ' CALLS
577          ' Add_SetCalendar
578          ' Update_ExternalForms
579     
580          On Error GoTo Proc_Err 
581          Dim nDate As Date 
582          nDate = Me.txtCalendarDate 
583          Add_SetCalendar nDate, 0, 0, 7 
584          Update_ExternalForms nDate 
585     
586      Proc_Exit: 
587         On Error Resume Next 
588         Exit Sub 
589      Proc_Err: 
590         Resume Proc_Exit 
591      End Sub 

592     
593      Private Sub cmd_W1sub_Click() 
594       '120625
595       ' CALLS
596          ' Add_SetCalendar
597          ' Update_ExternalForms
598     
599          On Error GoTo Proc_Err 
600          Dim nDate As Date 
601          nDate = Me.txtCalendarDate 
602          Add_SetCalendar nDate, 0, 0, -7 
603          Update_ExternalForms nDate 
604     
605      Proc_Exit: 
606         On Error Resume Next 
607         Exit Sub 
608      Proc_Err: 
609         Resume Proc_Exit 
610      End Sub 

611     
612      Private Sub cmd_Q1add_Click() 
613       '120701
614          On Error GoTo Proc_Err 
615          Dim nDate As Date 
616          nDate = Me.txtCalendarDate 
617          Add_SetCalendar nDate, 0, 3, 0 
618          Update_ExternalForms nDate 
619      Proc_Exit: 
620         On Error Resume Next 
621         Exit Sub 
622      Proc_Err: 
623         Resume Proc_Exit 
624      End Sub 

625     
626      Private Sub cmd_Q1sub_Click() 
627       '120701
628          On Error GoTo Proc_Err 
629          Dim nDate As Date 
630          nDate = Me.txtCalendarDate 
631          Add_SetCalendar nDate, 0, -3, 0 
632          Update_ExternalForms nDate 
633      Proc_Exit: 
634         On Error Resume Next 
635         Exit Sub 
636      Proc_Err: 
637         Resume Proc_Exit 
638      End Sub 

639     
640      Private Sub cmd_Y10add_Click() 
641       '120701
642          On Error GoTo Proc_Err 
643          Dim nDate As Date 
644          nDate = Me.txtCalendarDate 
645          Add_SetCalendar nDate, 10, 0, 0 
646          Update_ExternalForms nDate 
647      Proc_Exit: 
648         On Error Resume Next 
649         Exit Sub 
650      Proc_Err: 
651         Resume Proc_Exit 
652      End Sub 

653     
654      Private Sub cmd_Y10sub_Click() 
655       '120701
656          On Error GoTo Proc_Err 
657          Dim nDate As Date 
658          nDate = Me.txtCalendarDate 
659          Add_SetCalendar nDate, -10, 0, 0 
660          Update_ExternalForms nDate 
661      Proc_Exit: 
662         On Error Resume Next 
663         Exit Sub 
664      Proc_Err: 
665         Resume Proc_Exit 
666      End Sub 

667     
668      Private Sub txtCalendarDate_AfterUpdate() 
669       '120701
670          Dim nDate As Date 
671          nDate = Me.txtCalendarDate 
672          Set_Calendar nDate 
673          Update_ExternalForms nDate 
674     
675      Proc_Exit: 
676         On Error Resume Next 
677         Exit Sub 
678      Proc_Err: 
679         Resume Proc_Exit 
680      End Sub 

681     
682      Private Sub cmdDayAdd_Click() 
683       '120623
684       ' CALLS
685          ' Add_SetCalendar
686          ' Update_ExternalForms
687     
688          Dim nDate As Date 
689          nDate = Me.txtCalendarDate 
690          Add_SetCalendar nDate, 0, 0, 1 
691          Update_ExternalForms nDate 
692     
693      Proc_Exit: 
694         On Error Resume Next 
695         Exit Sub 
696      Proc_Err: 
697         Resume Proc_Exit 
698      End Sub 

699     
700      Private Sub cmdDaySub_Click() 
701       '120623
702       ' CALLS
703          ' Add_SetCalendar
704          ' Update_ExternalForms
705     
706          Dim nDate As Date 
707          nDate = Me.txtCalendarDate 
708          Add_SetCalendar nDate, 0, 0, -1 
709          Update_ExternalForms nDate 
710     
711      Proc_Exit: 
712         On Error Resume Next 
713         Exit Sub 
714      Proc_Err: 
715         Resume Proc_Exit 
716      End Sub 
717       '---------------------------------------------------------------------

718     
719      Private Sub cmd11_Click() 
720          DayClick 
721      End Sub 

722     
723      Private Sub cmd12_Click() 
724          DayClick 
725      End Sub 

726     
727      Private Sub cmd13_Click() 
728          DayClick 
729      End Sub 

730     
731      Private Sub cmd14_Click() 
732          DayClick 
733      End Sub 

734     
735      Private Sub cmd15_Click() 
736          DayClick 
737      End Sub 

738     
739      Private Sub cmd16_Click() 
740          DayClick 
741      End Sub 

742     
743      Private Sub cmd17_Click() 
744          DayClick 
745      End Sub 

746     
747      Private Sub cmd21_Click() 
748          DayClick 
749      End Sub 

750     
751      Private Sub cmd22_Click() 
752          DayClick 
753      End Sub 

754     
755      Private Sub cmd23_Click() 
756          DayClick 
757      End Sub 

758     
759      Private Sub cmd24_Click() 
760          DayClick 
761      End Sub 

762     
763      Private Sub cmd25_Click() 
764          DayClick 
765      End Sub 

766     
767      Private Sub cmd26_Click() 
768          DayClick 
769      End Sub 

770     
771      Private Sub cmd27_Click() 
772          DayClick 
773      End Sub 

774     
775      Private Sub cmd31_Click() 
776          DayClick 
777      End Sub 

778     
779      Private Sub cmd32_Click() 
780          DayClick 
781      End Sub 

782     
783      Private Sub cmd33_Click() 
784          DayClick 
785      End Sub 

786     
787      Private Sub cmd34_Click() 
788          DayClick 
789      End Sub 

790     
791      Private Sub cmd35_Click() 
792          DayClick 
793      End Sub 

794     
795      Private Sub cmd36_Click() 
796          DayClick 
797      End Sub 

798     
799      Private Sub cmd37_Click() 
800          DayClick 
801      End Sub 

802     
803      Private Sub cmd41_Click() 
804          DayClick 
805      End Sub