GraphExample_Crystal_140817

Documentation Generated by Code Documenter
Aug-21-14 04:16 PM
F:\Tools_2012\Crystal_Chart_Graph\GraphExample_Crystal_140812_9p.accdb
File last modified: 8/15/2014 11:53:06 AM
File size: 2,261 Kbytes

Application Title: Graph Example by Crystal
Startup Form: f_Graph_MENU
3 Modules
122 Procedures
5,224 Lines

1,471 Statements
449 Comments
490 Blank Lines
82% Executable

7 Objects modified between 7/31/2009 2:04:43 PM and 8/12/2014 9:03:22 PM
3 Tables, 1 Query, 3 Forms, 0 Reports, 0 Macros, 0 Modules

Index

References

Forms

  1. Form_f_Graph
  2. Form_f_Graph_MENU
  3. Form_f_PopupCalendar
Goto END of Forms       Goto Top       Goto Index

Form_f_Graph (124)

PROCEDURES       Goto Top       Goto Form_f_Graph       Goto Forms       Goto Index
  1. b_CloseChartSetup_Click
  2. Form_Open
1        Option Compare Database 
2        Option Explicit 

b_CloseChartSetup_Click

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 
      Goto Top       Goto Form_f_Graph       Goto Index

Form_Open

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 
      Goto Top       Goto Form_f_Graph       Goto Index

Form_f_Graph_MENU (966)

PROCEDURES       Goto Top       Goto Form_f_Graph_MENU       Goto Forms       Goto Index
  1. Calc_Footer
  2. Calc_Header
  3. Calc_Scale
  4. Calc_Title
  5. cmd_Chart_Click
  6. cmd_ResetData_Click
  7. Date1_AfterUpdate
  8. Date1_DblClick
  9. Date2_AfterUpdate
  10. Date2_DblClick
  11. Form_Load
  12. fraDays_AfterUpdate
  13. fraFunction_AfterUpdate
  14. fraScale_AfterUpdate
  15. GetTitle
  16. Label_send_email_Click
  17. loc_BoldMe
  18. loc_GetSQL_ORDERBY
  19. loc_GetSQL_WHERE
  20. loc_MakeQuery
  21. MyOtherID1_AfterUpdate
  22. MyOtherID1_MouseUp
  23. MyOtherID2_AfterUpdate
  24. MyOtherID2_MouseUp
  25. MyTopicID_AfterUpdate
  26. ResetCriteria
  27. SetControl_RowSource
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        '

Form_Load

52      
53       Private Sub Form_Load() 
54        '140810
55          Call ResetCriteria 
56       End Sub 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

Date1_AfterUpdate

57      
58       Private Sub Date1_AfterUpdate() 
59        '140811
60          Call Calc_Footer 
61       End Sub 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

Date1_DblClick

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

Date2_AfterUpdate

68      
69       Private Sub Date2_AfterUpdate() 
70        '140811
71          Call Calc_Footer 
72       End Sub 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

Date2_DblClick

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 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

MyOtherID1_AfterUpdate

84      
85       Private Sub MyOtherID1_AfterUpdate() 
86        '140812
87          Call Calc_Footer 
88       End Sub 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

MyOtherID2_AfterUpdate

89      
90       Private Sub MyOtherID2_AfterUpdate() 
91        '140812
92          Call Calc_Footer 
93       End Sub 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

MyTopicID_AfterUpdate

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 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

fraDays_AfterUpdate

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 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

fraFunction_AfterUpdate

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

fraScale_AfterUpdate

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 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

Calc_Scale

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 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

Calc_Title

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 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

Calc_Header

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 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

Calc_Footer

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 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

GetTitle

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 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

cmd_Chart_Click

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 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

cmd_ResetData_Click

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

ResetCriteria

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 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

loc_MakeQuery

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 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

loc_BoldMe

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 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

SetControl_RowSource

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 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

loc_GetSQL_ORDERBY

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 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

loc_GetSQL_WHERE

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 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

Label_send_email_Click

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 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

MyOtherID1_MouseUp

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 
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

MyOtherID2_MouseUp

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     
      Goto Top       Goto Form_f_Graph_MENU       Goto Index

Form_f_PopupCalendar (1578)

PROCEDURES       Goto Top       Goto Form_f_PopupCalendar       Goto Forms       Goto Index
  1. Add_SetCalendar
  2. AmPm
  3. cal_GetBirthstone
  4. cal_GetCardinalNumber
  5. cal_GetCol4Calendar
  6. cal_GetDowN4Calendar
  7. cal_GetRoman
  8. cal_GetRow4Calendar
  9. cal_IsSubform
  10. cal_ShowHideControlsTag
  11. cmd_AddDays_Click
  12. cmd_Cancel_Click
  13. cmd_Close_Click
  14. cmd_CurrentTime_Click
  15. cmd_M6add_Click
  16. cmd_M6sub_Click
  17. cmd_Now_Click
  18. cmd_Q1add_Click
  19. cmd_Q1sub_Click
  20. cmd_Reset_Click
  21. cmd_Today_Click
  22. cmd_W1add_Click
  23. cmd_W1sub_Click
  24. cmd_Y10add_Click
  25. cmd_Y10sub_Click
  26. cmd11_Click
  27. cmd12_Click
  28. cmd13_Click
  29. cmd14_Click
  30. cmd15_Click
  31. cmd16_Click
  32. cmd17_Click
  33. cmd21_Click
  34. cmd22_Click
  35. cmd23_Click
  36. cmd24_Click
  37. cmd25_Click
  38. cmd26_Click
  39. cmd27_Click
  40. cmd31_Click
  41. cmd32_Click
  42. cmd33_Click
  43. cmd34_Click
  44. cmd35_Click
  45. cmd36_Click
  46. cmd37_Click
  47. cmd41_Click
  48. cmd42_Click
  49. cmd43_Click
  50. cmd44_Click
  51. cmd45_Click
  52. cmd46_Click
  53. cmd47_Click
  54. cmd51_Click
  55. cmd52_Click
  56. cmd53_Click
  57. cmd54_Click
  58. cmd55_Click
  59. cmd56_Click
  60. cmd57_Click
  61. cmd61_Click
  62. cmd62_Click
  63. cmd63_Click
  64. cmd64_Click
  65. cmd65_Click
  66. cmd66_Click
  67. cmd67_Click
  68. cmdDayAdd_Click
  69. cmdDaySub_Click
  70. cmdMonth_Click
  71. cmdMonthAdd_Click
  72. cmdMonthSub_Click
  73. cmdYr_Click
  74. cmdYrAdd_Click
  75. cmdYrSub_Click
  76. DayClick
  77. Form_Load
  78. Form_Open
  79. hDn_Click
  80. HrUpDn
  81. hUp_Click
  82. Label_strive4peace_Click
  83. Mark_TodayAndDate
  84. MinUpDn
  85. Set_Calendar
  86. Set_DefaultFormat
  87. ShowDatePickerMessage
  88. txtCalendarDate_AfterUpdate
  89. txtCalendarDate_BeforeUpdate
  90. txtDate_AfterUpdate
  91. txtDays_DblClick
  92. Update_ExternalForms
  93. UseTheTime
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 

Update_ExternalForms

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_Cancel_Click

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

cmd_Close_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

UseTheTime

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_CurrentTime_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmdMonth_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmdYr_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

Form_Open

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

Form_Load

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

DayClick

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_Reset_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_AddDays_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_Now_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmdMonthAdd_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmdMonthSub_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmdYrAdd_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmdYrSub_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_M6add_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_M6sub_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_Today_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_W1add_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_W1sub_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_Q1add_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_Q1sub_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_Y10add_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_Y10sub_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

txtCalendarDate_AfterUpdate

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmdDayAdd_Click

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 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmdDaySub_Click

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       '---------------------------------------------------------------------
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd11_Click

718     
719      Private Sub cmd11_Click() 
720          DayClick 
721      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd12_Click

722     
723      Private Sub cmd12_Click() 
724          DayClick 
725      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd13_Click

726     
727      Private Sub cmd13_Click() 
728          DayClick 
729      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd14_Click

730     
731      Private Sub cmd14_Click() 
732          DayClick 
733      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd15_Click

734     
735      Private Sub cmd15_Click() 
736          DayClick 
737      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd16_Click

738     
739      Private Sub cmd16_Click() 
740          DayClick 
741      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd17_Click

742     
743      Private Sub cmd17_Click() 
744          DayClick 
745      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd21_Click

746     
747      Private Sub cmd21_Click() 
748          DayClick 
749      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd22_Click

750     
751      Private Sub cmd22_Click() 
752          DayClick 
753      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd23_Click

754     
755      Private Sub cmd23_Click() 
756          DayClick 
757      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd24_Click

758     
759      Private Sub cmd24_Click() 
760          DayClick 
761      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd25_Click

762     
763      Private Sub cmd25_Click() 
764          DayClick 
765      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd26_Click

766     
767      Private Sub cmd26_Click() 
768          DayClick 
769      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd27_Click

770     
771      Private Sub cmd27_Click() 
772          DayClick 
773      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd31_Click

774     
775      Private Sub cmd31_Click() 
776          DayClick 
777      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd32_Click

778     
779      Private Sub cmd32_Click() 
780          DayClick 
781      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd33_Click

782     
783      Private Sub cmd33_Click() 
784          DayClick 
785      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd34_Click

786     
787      Private Sub cmd34_Click() 
788          DayClick 
789      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd35_Click

790     
791      Private Sub cmd35_Click() 
792          DayClick 
793      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd36_Click

794     
795      Private Sub cmd36_Click() 
796          DayClick 
797      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd37_Click

798     
799      Private Sub cmd37_Click() 
800          DayClick 
801      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd41_Click

802     
803      Private Sub cmd41_Click() 
804          DayClick 
805      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd42_Click

806     
807      Private Sub cmd42_Click() 
808          DayClick 
809      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd43_Click

810     
811      Private Sub cmd43_Click() 
812          DayClick 
813      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd44_Click

814     
815      Private Sub cmd44_Click() 
816          DayClick 
817      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd45_Click

818     
819      Private Sub cmd45_Click() 
820          DayClick 
821      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd46_Click

822     
823      Private Sub cmd46_Click() 
824          DayClick 
825      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd47_Click

826     
827      Private Sub cmd47_Click() 
828          DayClick 
829      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd51_Click

830     
831      Private Sub cmd51_Click() 
832          DayClick 
833      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd52_Click

834     
835      Private Sub cmd52_Click() 
836          DayClick 
837      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd53_Click

838     
839      Private Sub cmd53_Click() 
840          DayClick 
841      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd54_Click

842     
843      Private Sub cmd54_Click() 
844          DayClick 
845      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd55_Click

846     
847      Private Sub cmd55_Click() 
848          DayClick 
849      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd56_Click

850     
851      Private Sub cmd56_Click() 
852          DayClick 
853      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd57_Click

854     
855      Private Sub cmd57_Click() 
856          DayClick 
857      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd61_Click

858     
859      Private Sub cmd61_Click() 
860          DayClick 
861      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd62_Click

862     
863      Private Sub cmd62_Click() 
864          DayClick 
865      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd63_Click

866     
867      Private Sub cmd63_Click() 
868          DayClick 
869      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd64_Click

870     
871      Private Sub cmd64_Click() 
872          DayClick 
873      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd65_Click

874     
875      Private Sub cmd65_Click() 
876          DayClick 
877      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd66_Click

878     
879      Private Sub cmd66_Click() 
880          DayClick 
881      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd67_Click

882     
883      Private Sub cmd67_Click() 
884          DayClick 
885      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

hDn_Click

886     
887       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Adjust Date
888      Private Sub hDn_Click() 
889         UseTheTime True 
890       'Mark Davis
891         If Nz(Me.txtHr.Value, 1) = 1 Then 
892             Me.txtHr.Value = 12 
893           Else 
894             Me.txtHr.Value = Me.txtHr.Value - 1 
895         End If 
896      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

hUp_Click

897     
898      Private Sub hUp_Click() 
899         UseTheTime True 
900       'Mark Davis
901          If Nz(Me.txtHr.Value, 12) = 12 Then 
902              Me.txtHr.Value = 1 
903            Else 
904              Me.txtHr.Value = Me.txtHr.Value + 1 
905          End If 
906      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

HrUpDn

907     
908      Private Function HrUpDn(pStep As Integer) 
909         UseTheTime True 
910     
911         Dim nHr As Integer _ 
912            , nHrOld As Integer 
913     
914         nHrOld = Nz(Me.txtHr, 12) 
915     
916         nHr = (Nz(Me.txtHr.Value, 0) + pStep) Mod 12 
917         If nHr = 0 Then nHr = 12 
918     
919         Select Case True 
920         Case nHr = 12 And pStep > 0 
921            AmPm 
922         Case nHrOld = 12 And pStep > 0 
923         Case nHr < 1 
924            nHr = 12 + nHr 
925            If nHr <> 12 And pStep <> -1 Then AmPm 
926     
927         Case nHr >= 13 
928            nHr = nHr - 12 
929            If nHrOld <> 12 Then AmPm 
930     
931         Case nHr = 11 And pStep = -1 
932             AmPm 
933         Case nHrOld = 12 And pStep < 0 
934            AmPm 
935         Case nHrOld = 12, nHr = 12 
936         Case pStep < 0 
937            If nHr > nHrOld Then AmPm 
938         Case pStep > 0 
939            If nHr < nHrOld Then AmPm 
940         End Select 
941     
942      Proc_Exit: 
943         Me.txtHr.Value = nHr 
944     
945      End Function 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

MinUpDn

946     
947      Private Function MinUpDn(pStep As Integer) 
948         UseTheTime True 
949         Dim nMin As Integer 
950     
951          'move up or down on even increments of 30
952         nMin = ((Nz(Me.txtMin.Value, 0) + 1) \ 30) * 30 
953     
954         nMin = nMin + pStep 
955     
956         If nMin < 0 Then 
957            nMin = 60 + nMin 
958            HrUpDn -1 
959         End If 
960         If nMin >= 60 Then 
961            nMin = nMin - 60 
962            HrUpDn 1 
963         End If 
964     
965         Me.txtMin.Value = nMin 
966      End Function 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

AmPm

967     
968      Private Function AmPm() 
969       'Mark Davis
970          If Me.txtAP.Value = "am" Then 
971              Me.txtAP.Value = "pm" 
972          Else 
973              Me.txtAP.Value = "am" 
974          End If 
975      End Function 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

Add_SetCalendar

976     
977       '-------------------------------------------------------------------- Add_SetCalendar
978      Public Sub Add_SetCalendar( _ 
979            pDate As Date _ 
980          , Optional pYearAdd As Integer = 0 _ 
981          , Optional pMonthAdd As Integer = 0 _ 
982          , Optional pDayAdd As Integer = 0 _ 
983          ) 
984       '120623
985     
986         On Error GoTo Proc_Err 
987     
988          If pMonthAdd <> 0 Or pYearAdd <> 0 Or pDayAdd <> 0 Then 
989            pDate = DateSerial(Year(pDate) + pYearAdd, Month(pDate) + pMonthAdd, Day(pDate) + pDayAdd) 
990          End If 
991     
992          Set_Calendar pDate 
993     
994      Proc_Exit: 
995          On Error Resume Next 
996         Exit Sub 
997     
998      Proc_Err: 
999         MsgBox Err.Description, , _ 
1,000           "ERROR " & Err.Number _ 
1,001            & "   Add_SetCalendar" 
1,002   
1,003       Resume Proc_Exit 
1,004       Resume 
1,005    End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

Set_Calendar

1,006   
1,007     '-------------------------------------- CUSTOMIZE
1,008     '-------------------------------------------------------------------- Set_Calendar
1,009    Public Sub Set_Calendar( _ 
1,010          pDate As Date _ 
1,011        ) 
1,012     '---------- CUSTOMIZE Defaults for -- Set_Calendar
1,013   
1,014     'Crystal 120512, 13
1,015     '120623 remove need for Dates table
1,016   
1,017         'set calendar to month for pDate
1,018         'and mark days
1,019   
1,020     'PARAMETERS
1,021        'pDate - optional. if specified and > 1900, calendar will be set to the date
1,022   
1,023     ' CALLS
1,024     '  cal_GetRow4Calendar
1,025     '  cal_GetCol4Calendar
1,026     '  Set_DefaultFormat
1,027     '  Mark_TodayAndDate
1,028   
1,029     ' CALLED BY
1,030        ' Form Load and buttons to change calendar day
1,031        ' FormName: txtDate_AfterUpdate, FindTheDay, DayAddSub
1,032   
1,033       On Error GoTo Proc_Err 
1,034   
1,035         '----- dimension variables
1,036        Dim ctl As Control _ 
1,037          , db As DAO.Database _ 
1,038          , rs As DAO.Recordset 
1,039   
1,040        Dim nMonth As Integer _ 
1,041            , nYear As Integer _ 
1,042            , nFirstCol As Integer _ 
1,043            , nLastRow As Integer _ 
1,044            , nLastCol As Integer _ 
1,045            , iRow As Integer _ 
1,046            , iCol As Integer _ 
1,047            , nRowPick As Integer _ 
1,048            , nColPick As Integer _ 
1,049            , nRowCur As Integer _ 
1,050            , nColCur As Integer _ 
1,051            , sSQL As String _ 
1,052            , sStr As String _ 
1,053            , iDay As Integer 
1,054   
1,055         '----- set variables
1,056   
1,057       nMonth = Month(pDate) 
1,058       nYear = Year(pDate) 
1,059   
1,060       If Year(Date) = nYear And Month(Date) = nMonth Then 
1,061           'calendar is showing the current month
1,062          nRowCur = cal_GetRow4Calendar(Date) 
1,063          nColCur = cal_GetCol4Calendar(Date) 
1,064       Else 
1,065           'calendar is not showing the current month
1,066          nRowCur = 0 
1,067          nColCur = 0 
1,068       End If 
1,069   
1,070       nRowPick = cal_GetRow4Calendar(pDate) 
1,071       nColPick = cal_GetCol4Calendar(pDate) 
1,072   
1,073       nLastCol = Weekday(DateSerial(nYear, nMonth + 1, 0)) 
1,074       nLastRow = cal_GetRow4Calendar(DateSerial(nYear, nMonth + 1, 0)) 
1,075       nFirstCol = Weekday(DateSerial(nYear, nMonth, 1)) 
1,076   
1,077        'keep track of picked day so colors can be set back to normal
1,078        'when the date is changed
1,079   
1,080       If Me.txtRowPick <> nRowPick Then 
1,081          Set_DefaultFormat Me("cmd" & Me.txtRowPick & Me.txtColPick), , False 
1,082          Me.txtRowPick = nRowPick 
1,083          Me.txtColPick = nColPick 
1,084       End If 
1,085   
1,086       If Me.txtRowCur <> nRowCur Then 
1,087           'reset previous current date if is was showing
1,088          If Me.txtRowCur <> 0 And Me.txtColCur <> 0 Then 
1,089             Set_DefaultFormat Me("cmd" & Me.txtRowCur & Me.txtColCur), , False 
1,090          End If 
1,091          Me.txtRowCur = nRowCur 
1,092          Me.txtColCur = nColCur 
1,093       End If 
1,094   
1,095       Me.txtCalendarDate = pDate 
1,096       Me.txtCalendarDate.Tag = "cmd" & nRowPick & nColPick 
1,097   
1,098        If nLastRow = 0 Or nLastCol = 0 Then 
1,099            MsgBox "Error getting last row Or column For calendar", , "Aborting" 
1,100            Exit Sub 
1,101        End If 
1,102   
1,103         'caption for cmdMonth
1,104        Me.cmdMonth.Caption = Format(pDate, "mmmm") 
1,105        Me.cmdYr.Caption = nYear 
1,106   
1,107         'hide unused squares in the first row
1,108        For iCol = 1 To (nFirstCol - 1) 
1,109          Set ctl = Me("cmd1" & iCol) 
1,110          With ctl 
1,111             .Visible = False 
1,112          End With 
1,113        Next iCol 
1,114   
1,115        '-----------------------------------------------------------------------
1,116        ' reset visible cells to default format
1,117   
1,118       iDay = 1 
1,119   
1,120       iRow = 1 
1,121       iCol = 1 
1,122   
1,123       For iRow = 1 To 6 
1,124          For iCol = 1 To 7 
1,125   
1,126             Set ctl = Me("cmd" & iRow & iCol) 
1,127   
1,128             Select Case iRow 
1,129             Case 1 
1,130                If iCol < nFirstCol Then 
1,131                   ctl.Visible = False 
1,132                   GoTo NextDay 
1,133                Else 
1,134                   Set_DefaultFormat ctl, iDay, iCol, False 
1,135                   iDay = iDay + 1 
1,136                End If 
1,137   
1,138             Case nLastRow 
1,139                If iCol <= nLastCol Then 
1,140                   Set_DefaultFormat ctl, iDay, iCol, False 
1,141                   iDay = iDay + 1 
1,142                Else 
1,143                   ctl.Visible = False 
1,144                   GoTo NextDay 
1,145                End If 
1,146   
1,147             Case Is < nLastRow 
1,148                   Set_DefaultFormat ctl, iDay, iCol, False 
1,149                   iDay = iDay + 1 
1,150   
1,151             Case Is > nLastRow 
1,152                ctl.Visible = False 
1,153                GoTo NextDay 
1,154   
1,155             End Select 
1,156    NextDay: 
1,157          Next iCol 
1,158       Next iRow 
1,159   
1,160       Call Mark_TodayAndDate(pDate) 
1,161   
1,162    Proc_Exit: 
1,163        On Error Resume Next 
1,164        Set ctl = Nothing 
1,165       Exit Sub 
1,166   
1,167    Proc_Err: 
1,168       MsgBox Err.Description, , _ 
1,169           "ERROR " & Err.Number _ 
1,170            & "   Set_Calendar" 
1,171   
1,172       Resume Proc_Exit 
1,173       Resume 
1,174    End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

Set_DefaultFormat

1,175   
1,176    Private Sub Set_DefaultFormat(pCtl As Control _ 
1,177       , Optional iDay As Integer = 0 _ 
1,178       , Optional iCol As Integer = 0 _ 
1,179       , Optional BoldWkend As Boolean = True) 
1,180     'Private Sub Set_DefaultFormat(pCtl As Control, Optional iDay As Integer = 0)
1,181     '120623, 120627, 120701
1,182       Dim booBold As Boolean 
1,183   
1,184       With pCtl 
1,185          .Visible = True 
1,186          .FontSize = 10 
1,187          .ForeColor = 0   'black 
1,188          booBold = True 
1,189          If iDay > 0 Then 
1,190             .Caption = iDay & Chr(160) & Chr(160) & Chr(160) & Chr(160) & vbCrLf & Chr(160) 
1,191             If Not BoldWkend _ 
1,192                   And (iCol = 1 Or iCol = 7) Then 
1,193                booBold = False 
1,194             End If 
1,195          End If 
1,196          .BorderColor = Me.Detail.BackColor 
1,197          .BorderWidth = 2 
1,198          .FontBold = booBold 
1,199       End With 
1,200    End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

Mark_TodayAndDate

1,201   
1,202    Private Sub Mark_TodayAndDate(pDate As Date) 
1,203     '120623, 120627, 120701, 131018
1,204       Dim nRow As Integer _ 
1,205          , nCol As Integer _ 
1,206          , sCtlName As String 
1,207   
1,208        'set format back for last current date
1,209   
1,210        ' clear current date
1,211       If Not Format(pDate, "yyyymm") = Format(Date, "yyyymm") Then 
1,212           'calendar is not showing current month
1,213          If Nz(Me.txtRowCur, 0) <> 0 And Nz(Me.txtColCur, 0) <> 0 Then 
1,214             sCtlName = "cmd" & Me.txtRowCur & Me.txtColCur 
1,215             Set_DefaultFormat Me(sCtlName) 
1,216          End If 
1,217          GoTo MarkScheduleDate 
1,218       Else 
1,219          nRow = cal_GetRow4Calendar(Date) 
1,220          nCol = cal_GetCol4Calendar(Date) 
1,221          sCtlName = "cmd" & nRow & nCol 
1,222          With Me(sCtlName) 
1,223             .ForeColor = RGB(255, 0, 0)   'red 
1,224             .BorderWidth = 0   'hairline 
1,225             .BorderColor = RGB(255, 0, 0) 
1,226          End With 
1,227       End If 
1,228   
1,229     '   ' clear pick date date
1,230     '   If Not Format(pDate, "yyyymm") = Format(Me.txtCalendarDate, "yyyymm") Then
1,231     '      'pick date is different
1,232     '      If Nz(Me.txtRowPick, 0) <> 0 And Nz(Me.txtColPick, 0) <> 0 Then
1,233     '         sCtlName = "cmd" & Me.txtRowPick & Me.txtColPick
1,234     '         Set_DefaultFormat Me(sCtlName)
1,235     '      End If
1,236     '   End If
1,237   
1,238   
1,239       If pDate = Date Then 
1,240           'make control purple if Pick = Today
1,241          With Me(sCtlName) 
1,242             .ForeColor = RGB(150, 0, 250)   'purple 
1,243             .BorderWidth = 0   'hairline 
1,244             .BorderColor = RGB(150, 0, 250) 
1,245          End With 
1,246          GoTo Proc_Exit 
1,247       End If 
1,248   
1,249       Me.txtDate = pDate 
1,250   
1,251    MarkScheduleDate: 
1,252        'mark schedule date
1,253       nRow = cal_GetRow4Calendar(pDate) 
1,254       nCol = cal_GetCol4Calendar(pDate) 
1,255       sCtlName = "cmd" & nRow & nCol 
1,256   
1,257       With Me(sCtlName) 
1,258          .ForeColor = RGB(0, 0, 255)   'blue 
1,259             .BorderColor = RGB(0, 0, 255) 
1,260             .BorderWidth = 0   'hairline 
1,261     '      If IsSubform(Me) Then '120623
1,262     '         Me.Parent.Label_DayDesc.Caption = .ControlTipText
1,263     '      End If
1,264       End With 
1,265   
1,266       Me.txtDate = pDate 
1,267   
1,268    Proc_Exit: 
1,269       On Error Resume Next 
1,270       Exit Sub 
1,271    End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

ShowDatePickerMessage

1,272   
1,273    Private Sub ShowDatePickerMessage() 
1,274     '120701
1,275       MsgBox "To use this popup calendar In a form," _ 
1,276          & " assign the DOUBLE-CLICK Event " _ 
1,277          & " of Date control On a form to" & vbCrLf & vbCrLf _ 
1,278          & "   DoCmd.OpenForm ""f_PopupCalendar""" & vbCrLf & vbCrLf _ 
1,279          & vbCrLf & vbCrLf _ 
1,280          & "To use this In another database, " _ 
1,281          & "import form f_PopupCalendar" _ 
1,282          , , "Popup Calendar by Crystal" 
1,283   
1,284    End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cal_GetCardinalNumber

1,285   
1,286     '--------------------------------------------- general
1,287   
1,288    Function cal_GetCardinalNumber(Optional pNumber) As String 
1,289     '11-24-08
1,290        'written by fdcusa (John)
1,291        'modified by Crystal
1,292   
1,293        'returns the string from a number in this form:
1,294        '1st, 2nd, 3rd, 10th, 301st, 1000th
1,295   
1,296       If IsMissing(pNumber) Or IsNull(pNumber) Or (Not IsNumeric(pNumber)) Then Exit Function 
1,297   
1,298       Dim strEnding As String 
1,299   
1,300        'convert to string, get the last character
1,301        'then turn back into an integer for comparison
1,302   
1,303        Select Case CInt(Right(CStr(pNumber), 1)) 
1,304            Case 1: strEnding = "st" 
1,305            Case 2: strEnding = "nd" 
1,306            Case 3: strEnding = "rd" 
1,307            Case Else: strEnding = "th" 
1,308        End Select 
1,309   
1,310        cal_GetCardinalNumber = CStr(pNumber) & strEnding 
1,311   
1,312    End Function 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cal_GetCol4Calendar

1,313   
1,314    Public Function cal_GetCol4Calendar(pDate As Date) As Integer 
1,315       cal_GetCol4Calendar = 0 
1,316       cal_GetCol4Calendar = Weekday(pDate, vbSunday) 
1,317    End Function 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cal_GetRow4Calendar

1,318   
1,319    Public Function cal_GetRow4Calendar(pDate As Date) As Integer 
1,320     '120623 Crystal
1,321   
1,322       On Error GoTo Proc_Err 
1,323       cal_GetRow4Calendar = 0 
1,324   
1,325       Dim nCol_First As Integer _ 
1,326          , nDate_First As Date _ 
1,327          , nRow As Integer _ 
1,328          , nCol As Integer _ 
1,329          , nNumDaysRow1 As Integer 
1,330   
1,331       nDate_First = DateSerial(Year(pDate), Month(pDate), 1) 
1,332       nCol_First = Weekday(nDate_First, vbSunday) 
1,333       nNumDaysRow1 = 7 - nCol_First + 1 
1,334   
1,335       nCol = Weekday(pDate, vbSunday) 
1,336   
1,337       nRow = (Day(pDate)) \ 7 + 1 
1,338   
1,339       If Day(pDate) Mod 7 > nNumDaysRow1 Then nRow = nRow + 1 
1,340       If Day(pDate) Mod 7 = 0 And nCol >= nCol_First Then nRow = nRow - 1 
1,341   
1,342       cal_GetRow4Calendar = nRow 
1,343   
1,344    Proc_Exit: 
1,345       On Error Resume Next 
1,346       Exit Function 
1,347   
1,348    Proc_Err: 
1,349       MsgBox Err.Description, , _ 
1,350           "ERROR " & Err.Number _ 
1,351            & "   cal_GetRow4Calendar" 
1,352   
1,353       Resume Proc_Exit 
1,354       Resume 
1,355    End Function 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cal_GetDowN4Calendar

1,356   
1,357    Public Function cal_GetDowN4Calendar(pDate As Date) As Integer 
1,358     '120623 Crystal
1,359   
1,360       On Error GoTo Proc_Err 
1,361       cal_GetDowN4Calendar = 0 
1,362   
1,363       Dim nDowN As Integer 
1,364   
1,365       nDowN = (Day(pDate)) \ 7 + 1 
1,366       If Day(pDate) Mod 7 = 0 Then nDowN = nDowN - 1 
1,367   
1,368       cal_GetDowN4Calendar = nDowN 
1,369   
1,370    Proc_Exit: 
1,371       On Error Resume Next 
1,372       Exit Function 
1,373   
1,374    Proc_Err: 
1,375       MsgBox Err.Description, , _ 
1,376           "ERROR " & Err.Number _ 
1,377            & "   cal_GetDowN4Calendar" 
1,378   
1,379       Resume Proc_Exit 
1,380       Resume 
1,381    End Function 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cal_IsSubform

1,382   
1,383   
1,384     '~~~~~~~~~~~~~~~~~~~~~~~~~~ IsSubform
1,385    Private Function cal_IsSubform(pForm As Form) As Boolean 
1,386     '8-29-07
1,387        'return:
1,388        ' TRUE is specified form reference is being used as a subform
1,389        ' FALSE if it is not
1,390   
1,391        'example useage: in code before parent controls are used
1,392        'If IsSubform(Me) then ...
1,393   
1,394        On Error Resume Next 
1,395        cal_IsSubform = _ 
1,396           Not IsError(Len(pForm.Parent.Name) > 0) 
1,397   
1,398    End Function 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cal_ShowHideControlsTag

1,399   
1,400     '~~~~~~~~~~~~~~~~~~~~~~~~~~ cal_ShowHideControlsTag
1,401    Private Function cal_ShowHideControlsTag( _ 
1,402       pBoo As Boolean _ 
1,403       , pTag As String) 
1,404   
1,405   
1,406       On Error GoTo Proc_Err 
1,407   
1,408       Dim ctl As Control 
1,409   
1,410       On Error Resume Next 
1,411       For Each ctl In Me.Detail.Controls 
1,412          If InStr(ctl.Tag, pTag) > 0 Then 
1,413             ctl.Visible = pBoo 
1,414          End If 
1,415       Next ctl 
1,416   
1,417    Proc_Exit: 
1,418       If Not ctl Is Nothing Then Set ctl = Nothing 
1,419       Exit Function 
1,420   
1,421    Proc_Err: 
1,422       MsgBox Err.Description, , _ 
1,423           "ERROR " & Err.Number _ 
1,424            & "   ShowHideControlsTag" 
1,425   
1,426        'press F8 to step through code
1,427        'comment next line when debugged
1,428       Stop: Resume 
1,429   
1,430       Resume Proc_Exit 
1,431   
1,432    End Function 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cal_GetRoman

1,433   
1,434    Private Function cal_GetRoman(ByVal pNumber As Integer) As String 
1,435     '120627
1,436     'modified from Microsoft Support
1,437     ' OFF97: VBA Procedure to Convert Numbers to Roman Numerals
1,438     ' http://support.microsoft.com/kb/184657
1,439   
1,440       On Error GoTo Proc_Err 
1,441   
1,442       Const ROMAN = "IVXLCDM"   'I=1,V=5, X=10, L=100, C=1,000, D=500   M=1,000 
1,443   
1,444       Dim i As Integer, Digit As Integer, sStr As String 
1,445   
1,446       i = 1 
1,447       sStr = "" 
1,448       Do While pNumber > 0 
1,449          Digit = pNumber Mod 10 
1,450          pNumber = pNumber \ 10 
1,451          Select Case Digit 
1,452             Case 1 
1,453               sStr = Mid(ROMAN, i, 1) & sStr 
1,454             Case 2 
1,455               sStr = Mid(ROMAN, i, 1) & Mid(ROMAN, i, 1) & sStr 
1,456             Case 3 
1,457               sStr = Mid(ROMAN, i, 1) & Mid(ROMAN, i, 1) & _ 
1,458                      Mid(ROMAN, i, 1) & sStr 
1,459             Case 4 
1,460               sStr = Mid(ROMAN, i, 2) & sStr 
1,461             Case 5 
1,462               sStr = Mid(ROMAN, i + 1, 1) & sStr 
1,463             Case 6 
1,464               sStr = Mid(ROMAN, i + 1, 1) & Mid(ROMAN, i, 1) & sStr 
1,465             Case 7 
1,466               sStr = Mid(ROMAN, i + 1, 1) & Mid(ROMAN, i, 1) & _ 
1,467                      Mid(ROMAN, i, 1) & sStr 
1,468             Case 8 
1,469               sStr = Mid(ROMAN, i + 1, 1) & Mid(ROMAN, i, 1) & _ 
1,470                      Mid(ROMAN, i, 1) & Mid(ROMAN, i, 1) & sStr 
1,471             Case 9 
1,472               sStr = Mid(ROMAN, i, 1) & Mid(ROMAN, i + 2, 1) & sStr 
1,473          End Select 
1,474          i = i + 2 
1,475       Loop 
1,476       cal_GetRoman = sStr 
1,477   
1,478    Proc_Exit: 
1,479       Exit Function 
1,480    Proc_Err: 
1,481       Resume Proc_Exit 
1,482   
1,483    End Function 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cal_GetBirthstone

1,484   
1,485    Private Function cal_GetBirthstone(pMonth As Integer) As String 
1,486        'birthstone for month -- CUSTOMIZE FOR YOUR CULTURE
1,487   
1,488       Select Case pMonth 
1,489       Case 1: cal_GetBirthstone = "Garnet" 
1,490       Case 2: cal_GetBirthstone = "Amethyst" 
1,491       Case 3: cal_GetBirthstone = "Aquamarine, Bloodstone" 
1,492       Case 4: cal_GetBirthstone = "Diamond, Rock Crystal" 
1,493       Case 5: cal_GetBirthstone = "Emerald, Chrysoprase" 
1,494       Case 6: cal_GetBirthstone = "Pearl, Moonstone, Alexandrite" 
1,495       Case 7: cal_GetBirthstone = "Ruby, Cornelian" 
1,496       Case 8: cal_GetBirthstone = "Peridot, Sardonyx" 
1,497       Case 9: cal_GetBirthstone = "Sapphire, Lapis Lazuli" 
1,498       Case 10: cal_GetBirthstone = "Opal, Yourmaline" 
1,499       Case 11: cal_GetBirthstone = "Topaz, Citrine" 
1,500       Case 12: cal_GetBirthstone = "Turquoise, Zircon, Tanzanite" 
1,501       End Select 
1,502    End Function 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

Label_strive4peace_Click

1,503   
1,504    Private Sub Label_strive4peace_Click() 
1,505     '120627
1,506       On Error Resume Next 
1,507       Application.FollowHyperlink _ 
1,508         "mailto: strive4peace2012@yahoo.com?subject=Popup Calendar comment " 
1,509    End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

txtCalendarDate_BeforeUpdate

1,510   
1,511   
1,512   
1,513    Private Sub txtCalendarDate_BeforeUpdate(Cancel As Integer) 
1,514     '120701
1,515       On Error Resume Next 
1,516       If IsNull(Me.ActiveControl) Then 
1,517          Me.ActiveControl.Undo 
1,518          Cancel = True 
1,519          Exit Sub 
1,520       End If 
1,521       If Not IsDate(Me.ActiveControl) Then 
1,522          MsgBox Me.ActiveControl & " Is Not a valid date", , "Cannot change" 
1,523          Me.ActiveControl.Undo 
1,524          Cancel = True 
1,525          Exit Sub 
1,526       End If 
1,527    End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

txtDate_AfterUpdate

1,528   
1,529    Private Sub txtDate_AfterUpdate() 
1,530     '131018
1,531   
1,532     ' CALLS
1,533        ' Set_Calendar
1,534        ' Update_ExternalForms
1,535   
1,536        On Error GoTo Proc_Err 
1,537   
1,538       Dim nDate As Date 
1,539   
1,540       With Me.txtDate 
1,541          If IsNull(.Value) Then 
1,542             .Value = Date 
1,543             nDate = Date 
1,544          Else 
1,545             If Not IsDate(.Value) Then 
1,546                MsgBox "You have Not entered a valid date", , "Can't Set date" 
1,547                Exit Sub 
1,548             Else 
1,549                nDate = Me.txtDate 
1,550             End If 
1,551          End If 
1,552       End With 
1,553   
1,554       Call Set_Calendar(nDate) 
1,555       Call Update_ExternalForms(nDate) 
1,556   
1,557    Proc_Exit: 
1,558       On Error Resume Next 
1,559       Exit Sub 
1,560   
1,561    Proc_Err: 
1,562       MsgBox Err.Description, , _ 
1,563           "ERROR " & Err.Number _ 
1,564            & "   DayClick : " & Me.Name 
1,565   
1,566       Resume Proc_Exit 
1,567       Resume 
1,568    End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

txtDays_DblClick

1,569   
1,570    Private Sub txtDays_DblClick(Cancel As Integer) 
1,571     '120627
1,572       On Error Resume Next 
1,573       If IsNull(Me.ActiveControl) Then Exit Sub 
1,574       Me.txtDays = -Me.txtDays 
1,575    End Sub 
1,576   
1,577   
1,578   
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

INDEX

  1. Modules and Procedures by Module
  2. Procedure name, Module name

Modules and Procedures by Module

Form_f_Graph (124)

b_CloseChartSetup_Click (38)
Form_Open (84)

Goto Top       Goto Index

Form_f_Graph_MENU (966)

Calc_Footer (54)
Calc_Header (14)
Calc_Scale (22)
Calc_Title (9)
cmd_Chart_Click (149)
cmd_ResetData_Click (5)
Date1_AfterUpdate (5)
Date1_DblClick (6)
Date2_AfterUpdate (5)
Date2_DblClick (11)
Form_Load (5)
fraDays_AfterUpdate (7)
fraFunction_AfterUpdate (6)
fraScale_AfterUpdate (7)
GetTitle (31)
Label_send_email_Click (9)
loc_BoldMe (206)
loc_GetSQL_ORDERBY (70)
loc_GetSQL_WHERE (103)
loc_MakeQuery (47)
MyOtherID1_AfterUpdate (5)
MyOtherID1_MouseUp (5)
MyOtherID2_AfterUpdate (5)
MyOtherID2_MouseUp (7)
MyTopicID_AfterUpdate (18)
ResetCriteria (39)
SetControl_RowSource (65)

Goto Top       Goto Index

Form_f_PopupCalendar (1,578)

Add_SetCalendar (30)
AmPm (9)
cal_GetBirthstone (19)
cal_GetCardinalNumber (28)
cal_GetCol4Calendar (5)
cal_GetDowN4Calendar (26)
cal_GetRoman (51)
cal_GetRow4Calendar (38)
cal_IsSubform (17)
cal_ShowHideControlsTag (34)
cmd_AddDays_Click (27)
cmd_Cancel_Click (6)
cmd_Close_Click (37)
cmd_CurrentTime_Click (11)
cmd_M6add_Click (20)
cmd_M6sub_Click (19)
cmd_Now_Click (18)
cmd_Q1add_Click (14)
cmd_Q1sub_Click (14)
cmd_Reset_Click (31)
cmd_Today_Click (17)
cmd_W1add_Click (19)
cmd_W1sub_Click (19)
cmd_Y10add_Click (14)
cmd_Y10sub_Click (14)
cmd11_Click (4)
cmd12_Click (4)
cmd13_Click (4)
cmd14_Click (4)
cmd15_Click (4)
cmd16_Click (4)
cmd17_Click (4)
cmd21_Click (4)
cmd22_Click (4)
cmd23_Click (4)
cmd24_Click (4)
cmd25_Click (4)
cmd26_Click (4)
cmd27_Click (4)
cmd31_Click (4)
cmd32_Click (4)
cmd33_Click (4)
cmd34_Click (4)
cmd35_Click (4)
cmd36_Click (4)
cmd37_Click (4)
cmd41_Click (4)
cmd42_Click (4)
cmd43_Click (4)
cmd44_Click (4)
cmd45_Click (4)
cmd46_Click (4)
cmd47_Click (4)
cmd51_Click (4)
cmd52_Click (4)
cmd53_Click (4)
cmd54_Click (4)
cmd55_Click (4)
cmd56_Click (4)
cmd57_Click (4)
cmd61_Click (4)
cmd62_Click (4)
cmd63_Click (4)
cmd64_Click (4)
cmd65_Click (4)
cmd66_Click (4)
cmd67_Click (4)
cmdDayAdd_Click (18)
cmdDaySub_Click (19)
cmdMonth_Click (7)
cmdMonthAdd_Click (19)
cmdMonthSub_Click (16)
cmdYr_Click (10)
cmdYrAdd_Click (20)
cmdYrSub_Click (18)
DayClick (43)
Form_Load (64)
Form_Open (84)
hDn_Click (11)
HrUpDn (39)
hUp_Click (10)
Label_strive4peace_Click (7)
Mark_TodayAndDate (71)
MinUpDn (21)
Set_Calendar (169)
Set_DefaultFormat (26)
ShowDatePickerMessage (13)
txtCalendarDate_AfterUpdate (14)
txtCalendarDate_BeforeUpdate (18)
txtDate_AfterUpdate (41)
txtDays_DblClick (10)
Update_ExternalForms (34)
UseTheTime (12)

Procedure name, Module name

   A    B    C    D    F    G    H    L    M    R    S    T    U

Goto Top       Goto Index       Procedure name, Module name      
A
Add_SetCalendar (30) , Form_f_PopupCalendar (1,578)
AmPm (9) , Form_f_PopupCalendar (1,578)

Goto Top       Goto Index       Procedure name, Module name       A
B
b_CloseChartSetup_Click (38) , Form_f_Graph (124)

Goto Top       Goto Index       Procedure name, Module name       B
C
cal_GetBirthstone (19) , Form_f_PopupCalendar (1,578)
cal_GetCardinalNumber (28) , Form_f_PopupCalendar (1,578)
cal_GetCol4Calendar (5) , Form_f_PopupCalendar (1,578)
cal_GetDowN4Calendar (26) , Form_f_PopupCalendar (1,578)
cal_GetRoman (51) , Form_f_PopupCalendar (1,578)
cal_GetRow4Calendar (38) , Form_f_PopupCalendar (1,578)
cal_IsSubform (17) , Form_f_PopupCalendar (1,578)
cal_ShowHideControlsTag (34) , Form_f_PopupCalendar (1,578)
Calc_Footer (54) , Form_f_Graph_MENU (966)
Calc_Header (14) , Form_f_Graph_MENU (966)
Calc_Scale (22) , Form_f_Graph_MENU (966)
Calc_Title (9) , Form_f_Graph_MENU (966)
cmd_AddDays_Click (27) , Form_f_PopupCalendar (1,578)
cmd_Cancel_Click (6) , Form_f_PopupCalendar (1,578)
cmd_Chart_Click (149) , Form_f_Graph_MENU (966)
cmd_Close_Click (37) , Form_f_PopupCalendar (1,578)
cmd_CurrentTime_Click (11) , Form_f_PopupCalendar (1,578)
cmd_M6add_Click (20) , Form_f_PopupCalendar (1,578)
cmd_M6sub_Click (19) , Form_f_PopupCalendar (1,578)
cmd_Now_Click (18) , Form_f_PopupCalendar (1,578)
cmd_Q1add_Click (14) , Form_f_PopupCalendar (1,578)
cmd_Q1sub_Click (14) , Form_f_PopupCalendar (1,578)
cmd_Reset_Click (31) , Form_f_PopupCalendar (1,578)
cmd_ResetData_Click (5) , Form_f_Graph_MENU (966)
cmd_Today_Click (17) , Form_f_PopupCalendar (1,578)
cmd_W1add_Click (19) , Form_f_PopupCalendar (1,578)
cmd_W1sub_Click (19) , Form_f_PopupCalendar (1,578)
cmd_Y10add_Click (14) , Form_f_PopupCalendar (1,578)
cmd_Y10sub_Click (14) , Form_f_PopupCalendar (1,578)
cmd11_Click (4) , Form_f_PopupCalendar (1,578)
cmd12_Click (4) , Form_f_PopupCalendar (1,578)
cmd13_Click (4) , Form_f_PopupCalendar (1,578)
cmd14_Click (4) , Form_f_PopupCalendar (1,578)
cmd15_Click (4) , Form_f_PopupCalendar (1,578)
cmd16_Click (4) , Form_f_PopupCalendar (1,578)
cmd17_Click (4) , Form_f_PopupCalendar (1,578)
cmd21_Click (4) , Form_f_PopupCalendar (1,578)
cmd22_Click (4) , Form_f_PopupCalendar (1,578)
cmd23_Click (4) , Form_f_PopupCalendar (1,578)
cmd24_Click (4) , Form_f_PopupCalendar (1,578)
cmd25_Click (4) , Form_f_PopupCalendar (1,578)
cmd26_Click (4) , Form_f_PopupCalendar (1,578)
cmd27_Click (4) , Form_f_PopupCalendar (1,578)
cmd31_Click (4) , Form_f_PopupCalendar (1,578)
cmd32_Click (4) , Form_f_PopupCalendar (1,578)
cmd33_Click (4) , Form_f_PopupCalendar (1,578)
cmd34_Click (4) , Form_f_PopupCalendar (1,578)
cmd35_Click (4) , Form_f_PopupCalendar (1,578)
cmd36_Click (4) , Form_f_PopupCalendar (1,578)
cmd37_Click (4) , Form_f_PopupCalendar (1,578)
cmd41_Click (4) , Form_f_PopupCalendar (1,578)
cmd42_Click (4) , Form_f_PopupCalendar (1,578)
cmd43_Click (4) , Form_f_PopupCalendar (1,578)
cmd44_Click (4) , Form_f_PopupCalendar (1,578)
cmd45_Click (4) , Form_f_PopupCalendar (1,578)
cmd46_Click (4) , Form_f_PopupCalendar (1,578)
cmd47_Click (4) , Form_f_PopupCalendar (1,578)
cmd51_Click (4) , Form_f_PopupCalendar (1,578)
cmd52_Click (4) , Form_f_PopupCalendar (1,578)
cmd53_Click (4) , Form_f_PopupCalendar (1,578)
cmd54_Click (4) , Form_f_PopupCalendar (1,578)
cmd55_Click (4) , Form_f_PopupCalendar (1,578)
cmd56_Click (4) , Form_f_PopupCalendar (1,578)
cmd57_Click (4) , Form_f_PopupCalendar (1,578)
cmd61_Click (4) , Form_f_PopupCalendar (1,578)
cmd62_Click (4) , Form_f_PopupCalendar (1,578)
cmd63_Click (4) , Form_f_PopupCalendar (1,578)
cmd64_Click (4) , Form_f_PopupCalendar (1,578)
cmd65_Click (4) , Form_f_PopupCalendar (1,578)
cmd66_Click (4) , Form_f_PopupCalendar (1,578)
cmd67_Click (4) , Form_f_PopupCalendar (1,578)
cmdDayAdd_Click (18) , Form_f_PopupCalendar (1,578)
cmdDaySub_Click (19) , Form_f_PopupCalendar (1,578)
cmdMonth_Click (7) , Form_f_PopupCalendar (1,578)
cmdMonthAdd_Click (19) , Form_f_PopupCalendar (1,578)
cmdMonthSub_Click (16) , Form_f_PopupCalendar (1,578)
cmdYr_Click (10) , Form_f_PopupCalendar (1,578)
cmdYrAdd_Click (20) , Form_f_PopupCalendar (1,578)
cmdYrSub_Click (18) , Form_f_PopupCalendar (1,578)

Goto Top       Goto Index       Procedure name, Module name       C
D
Date1_AfterUpdate (5) , Form_f_Graph_MENU (966)
Date1_DblClick (6) , Form_f_Graph_MENU (966)
Date2_AfterUpdate (5) , Form_f_Graph_MENU (966)
Date2_DblClick (11) , Form_f_Graph_MENU (966)
DayClick (43) , Form_f_PopupCalendar (1,578)

Goto Top       Goto Index       Procedure name, Module name       D
F
Form_Load (5) , Form_f_Graph_MENU (966)
Form_Load (64) , Form_f_PopupCalendar (1,578)
Form_Open (84) , Form_f_Graph (124)
Form_Open (84) , Form_f_PopupCalendar (1,578)
fraDays_AfterUpdate (7) , Form_f_Graph_MENU (966)
fraFunction_AfterUpdate (6) , Form_f_Graph_MENU (966)
fraScale_AfterUpdate (7) , Form_f_Graph_MENU (966)

Goto Top       Goto Index       Procedure name, Module name       F
G
GetTitle (31) , Form_f_Graph_MENU (966)

Goto Top       Goto Index       Procedure name, Module name       G
H
hDn_Click (11) , Form_f_PopupCalendar (1,578)
HrUpDn (39) , Form_f_PopupCalendar (1,578)
hUp_Click (10) , Form_f_PopupCalendar (1,578)

Goto Top       Goto Index       Procedure name, Module name       H
L
Label_send_email_Click (9) , Form_f_Graph_MENU (966)
Label_strive4peace_Click (7) , Form_f_PopupCalendar (1,578)
loc_BoldMe (206) , Form_f_Graph_MENU (966)
loc_GetSQL_ORDERBY (70) , Form_f_Graph_MENU (966)
loc_GetSQL_WHERE (103) , Form_f_Graph_MENU (966)
loc_MakeQuery (47) , Form_f_Graph_MENU (966)

Goto Top       Goto Index       Procedure name, Module name       L
M
Mark_TodayAndDate (71) , Form_f_PopupCalendar (1,578)
MinUpDn (21) , Form_f_PopupCalendar (1,578)
MyOtherID1_AfterUpdate (5) , Form_f_Graph_MENU (966)
MyOtherID1_MouseUp (5) , Form_f_Graph_MENU (966)
MyOtherID2_AfterUpdate (5) , Form_f_Graph_MENU (966)
MyOtherID2_MouseUp (7) , Form_f_Graph_MENU (966)
MyTopicID_AfterUpdate (18) , Form_f_Graph_MENU (966)

Goto Top       Goto Index       Procedure name, Module name       M
R
ResetCriteria (39) , Form_f_Graph_MENU (966)

Goto Top       Goto Index       Procedure name, Module name       R
S
Set_Calendar (169) , Form_f_PopupCalendar (1,578)
Set_DefaultFormat (26) , Form_f_PopupCalendar (1,578)
SetControl_RowSource (65) , Form_f_Graph_MENU (966)
ShowDatePickerMessage (13) , Form_f_PopupCalendar (1,578)

Goto Top       Goto Index       Procedure name, Module name       S
T
txtCalendarDate_AfterUpdate (14) , Form_f_PopupCalendar (1,578)
txtCalendarDate_BeforeUpdate (18) , Form_f_PopupCalendar (1,578)
txtDate_AfterUpdate (41) , Form_f_PopupCalendar (1,578)
txtDays_DblClick (10) , Form_f_PopupCalendar (1,578)

Goto Top       Goto Index       Procedure name, Module name       T
U
Update_ExternalForms (34) , Form_f_PopupCalendar (1,578)
UseTheTime (12) , Form_f_PopupCalendar (1,578)


     
Goto Top

End of code documentation for GraphExample_Crystal_140817