Contacts_FE_141015_accdb

Access Documentation Generated by Code Documenter
Oct-16-14 12:26 PM
F:\Tools_2012\__Contacts2014\_DEPLOY\Contacts_FE_141015.accdb
File last modified: 10/16/2014 4:08:58 AM
File size: 7,717 Kbytes

Application Title: Contacts FRONT END
Startup Form: f_SplashScreen

227 Objects modified between 7/31/2009 2:04:43 PM and 10/15/2014 10:08:44 PM
97 Tables, 43 Queries, 55 Forms, 14 Reports, 0 Macros, 18 Modules

81 Modules
943 Procedures
49,999 Lines

11,507 Statements
7,110 Comments
4,375 Blank Lines
77% Executable

Index

References

Forms

  1. Form_f_ADMIN (1,024)
  2. Form_f_AnywhereMENU (401)
  3. Form_f_Calendar_sub (1,014)
  4. Form_f_CalendarSub_test (85)
  5. Form_f_CUSTOMER (95)
  6. Form_f_DataDICTIONARY_DisplayControl (507)
  7. Form_f_EMPLOYEE (58)
  8. Form_f_EmpPapers_sub (49)
  9. Form_f_GetDateRange (90)
  10. Form_f_INVOICE (102)
  11. Form_f_Invoice_Charges_sub (32)
  12. Form_f_Invoice_sub_NEEDSWORK (236)
  13. Form_f_InvoiceDetail_sub (101)
  14. Form_f_INVOICEs_NEEDSWORK (61)
  15. Form_f_ITM (141)
  16. Form_f_ITMs (137)
  17. Form_f_MAIN_MENU (93)
  18. Form_f_MENU_HTMLCalendar (2,077)
  19. Form_f_Payments_sub (88)
  20. Form_f_PleaseWait (48)
  21. Form_f_PopupCalendar (1,571)
  22. Form_f_PRJECT (267)
  23. Form_f_PROJECTs (264)
  24. Form_f_PROSPECT (67)
  25. Form_f_SplashScreen (40)
  26. Form_f_UnderConstruction (3)
  27. Form_f_VENDOR (68)
  28. Form_fc_AddrDates_sub (79)
  29. Form_fc_Addresses_sub (367)
  30. Form_fc_AnywhereAttachments (903)
  31. Form_fc_AnywhereNotes (385)
  32. Form_fc_AnywhereNotes_sub (366)
  33. Form_fc_Contact_Categories_sub (193)
  34. Form_fc_eAdr_sub (124)
  35. Form_fc_List_sub (76)
  36. Form_fc_LISTS (87)
  37. Form_fc_Lists_Members_sub (58)
  38. Form_fc_Lists_PickMembers_sub (106)
  39. Form_fc_MbrLists_sub (154)
  40. Form_fc_MENU_CONTACT (1,679)
  41. Form_fc_Notes_sub (65)
  42. Form_fc_Phones_sub (195)
  43. Form_fc_PikPeople (418)
  44. Form_fc_pop_Appointment (139)
  45. Form_fc_Popup_AddContact (302)
  46. Form_fc_Tables (67)
  47. Form_fc_templateAnywhere (37)
  48. Form_fc_ViewAddress_sub (44)
  49. Form_fc_Websites_sub (261)
  50. Form_usys_f_PickUser__NOTUSED (94)
  51. Form_usys_fPw (52)
Goto END of Forms       Goto Top       Goto Index

Form_f_ADMIN (1024)

PROCEDURES       Goto Top       Goto Form_f_ADMIN       Goto Forms       Goto Index
  1. cmd_Browse_PathBE_Click (41)
  2. cmd_Cancel_Click (5)
  3. cmd_DeleteData_Click (5)
  4. cmd_NavigationPane_Click (7)
  5. cmd_OpenUsers_Click (12)
  6. cmd_Relink_Click (17)
  7. cmd_SaveClose_Click (113)
  8. cmdExit_Click (5)
  9. Declaration Lines (37)
  10. Form_Open (147)
  11. Get_ColorDirectory (104)
  12. Get_DirectoryDialog (33)
  13. GetGoodPartOfPath (34)
  14. pri_DropMe (6)
  15. pri_UsrMgt_SetProperties (105)
  16. SetBackColor (19)
  17. SetDirectory (106)
  18. usrCatID_AfterUpdate (27)
  19. UsrID_AfterUpdate (99)
  20. UsrID_BeforeUpdate (8)
  21. UsrID_NotInList (94)

Declaration Lines (37)

1        Option Compare Database 
2        Option Explicit 
3         '
4         '  code behind f_ADMIN
5         '
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, 140629
27        ' ~ Crystal
28        '              * have an awesome day :)
29        '                                                   www.AccessMVP.com/strive4peace
30        ' END LICENSE NOTICE
31        '============================================================
32        '
33        ' NEEDS
34        '  bas_Crystal_ReLinker_97-2013_131112
35        '  mod_crystal_GetFile_Browse
36      
37       Dim booRelinkerRunning As Boolean 
      Goto Top       Goto Form_f_ADMIN       Goto Index

cmd_DeleteData_Click (5)

38      
39       Private Sub cmd_DeleteData_Click() 
40        '141005
41          Call DeleteRecords 
42       End Sub 
      Goto Top       Goto Form_f_ADMIN       Goto Index

Form_Open (147)

43      
44       Public Sub Form_Open(Cancel As Integer) 
45        '110918, 1110, 1125, 140928, 141014 booRelinkerRunning
46      
47        ' CALLS
48        '  SetBackColor
49        ' READS
50        '  property: local_UsrID
51        '  table: c_Usrs
52      
53        'Stop
54      
55          Call pri_UsrMgt_SetProperties 
56           'see if connection is ok
57           'if it is, cancel loading this form
58        '   If IsBEok("c_KeepOpen") Then ', True) Then   'open BE and keep table open
59        '   If IsBEok("c_Contact") Then ', True) Then   'open BE and keep table open
60        '      If Len(Nz(Me.OpenArgs, "")) > 0 Then GoTo LoadData
61        '      'CANCEL THE FORM
62        '      Cancel = True
63        '      'open Contacts form
64        '      DoCmd.OpenForm "fc_MENU_CONTACT"
65        '      Exit Sub
66        '   End If
67           '------------------------------------------
68           'Private Sub Form_Load()
69       LoadData: 
70          Dim nUsrID As Long _ 
71                , nUsrCatID As Long _ 
72                , sPath As String _ 
73                , nNum As Long _ 
74                , sSQL As String 
75      
76          Dim db As DAO.Database _ 
77                , rs As DAO.Recordset 
78      
79          Dim boo As Boolean 
80      
81          nUsrID = Get_Property("local_UsrID") 
82          nNum = Nz(DLookup("UsrID", "c_Usrs", "UsrID=" & nUsrID), -99) 
83      
84          If nNum < 0 Then 
85       User_Not_Found: 
86              'user not found -- read properties
87             nUsrCatID = Get_Property("local_UsrCatID") 
88             If nUsrCatID > 0 Then 
89                Me.usrCatID = nUsrCatID 
90             End If 
91      
92             sPath = Get_Property("local_PathBE") 
93             If Len(Trim(sPath)) > 0 Then 
94                Me.PathBE = sPath 
95             End If 
96             Call SetBackColor("BE", sPath) 
97      
98             Me.PathBE.BackColor = RGB(255, 0, 0) 
99      
100            With Me.PathAtt 
101               If .Visible = True Then 
102                  sPath = Get_Property("local_PathAtt") 
103                  If Len(Trim(sPath)) > 0 Then 
104                     .Value = sPath 
105                  End If 
106                  Call SetBackColor("Att", sPath) 
107               End If 
108            End With     'PathAtt 
109     
110            With Me.Path1 
111               If .Visible = True Then 
112                  sPath = Get_Property("local_Path1") 
113                  If Len(Trim(sPath)) > 0 Then 
114                     .Value = sPath 
115                  End If 
116                  Call SetBackColor("Tpl", sPath) 
117               End If 
118            End With     'Path1 
119             'DONE FILLING INFORMATION -- Exit Sub
120            Exit Sub 
121         End If   'got information from properties 
122     
123         Me.UsrID = nUsrID 
124     
125          ' read User settings from c_Usrs table
126     
127         Set db = CurrentDb 
128         sSQL = "SELECT c_Usrs.* " _ 
129               & " FROM c_Usrs " _ 
130               & " WHERE UsrID = " & nUsrID _ 
131               & ";" 
132         Set rs = db.OpenRecordset(sSQL, dbOpenSnapshot) 
133         With rs 
134            If .EOF Then 
135                'user not found in table
136               GoTo User_Not_Found 
137            End If 
138     
139            If Not IsNull(!usrCatID) Then 
140               Me.usrCatID = !usrCatID 
141            End If 
142            If Not IsNull(!PathBE) Then 
143               sPath = !PathBE 
144               Me.PathBE = sPath 
145            Else 
146               sPath = "" 
147            End If 
148            Call SetBackColor("BE", sPath) 
149     
150            If Me.PathAtt.Visible = True Then 
151               If Not IsNull(!PathAtt) Then 
152                  sPath = !PathAtt 
153                  Me.PathAtt = sPath 
154               Else 
155                  sPath = "" 
156               End If 
157               Call SetBackColor("Att", sPath) 
158            End If 
159     
160            If Me.Path1.Visible = True Then 
161               If Not IsNull(!Path1) Then 
162                  sPath = !Path1 
163                  Me.Path1 = sPath 
164               Else 
165                  sPath = "" 
166               End If 
167               Call SetBackColor("Tpl", sPath) 
168            End If 
169         End With     'rs 
170     
171      Proc_Exit: 
172         On Error Resume Next 
173         booRelinkerRunning = False 
174          'release object variables
175         If Not rs Is Nothing Then 
176            rs.Close 
177            Set rs = Nothing 
178         End If 
179         If Not db Is Nothing Then Set db = Nothing 
180         Exit Sub 
181     
182      Proc_Err: 
183         MsgBox Err.Description, , _ 
184               "ERROR " & Err.Number _ 
185               & "   Form_Load : " & Me.Name 
186     
187         Resume Proc_Exit 
188         Resume 
189      End Sub 
      Goto Top       Goto Form_f_ADMIN       Goto Index

cmd_Browse_PathBE_Click (41)

190     
191      Private Sub cmd_Browse_PathBE_Click() 
192       '140102
193         Call SetDirectory("BE", Nz(Me.PathBE, ""), Me.PathBE) 
194      End Sub 
195     
196       'needs tables:
197       '  c_Usrs
198       '  c_UsrCats
199     
200       'properties:
201       '  local_IsAdmin
202       '  local_UsrID
203       '  local_UsrCatID
204       '  local_UsrName
205       '  local_PathBE
206       '  local_PathAtt
207       '  local_Path1
208       '  local_Password
209     
210       'local procedures that could be in a standard module:
211       '  pri_UsrMgt_SetProperties
212       '  pri_DropMe
213     
214       'Private Sub Form_Open(Cancel As Integer)
215       ''110918, 1110
216       '   'CALLS
217       '   '  pri_UsrMgt_SetProperties
218       '   '  Get_Property
219       '
220       '   'set database properties
221       '   Call pri_UsrMgt_SetProperties
222       '   On Error Resume Next
223       '   DoCmd.OpenForm "usys_fP", , , , , acDialog
224       '   If Get_Property("local_Password") <> "secret" Then
225       '      Cancel = True
226       '      'MsgBox "You do not have permission to open this form" _
227       '         , , "canceling open form"
228       '   End If
229       '
230       'End Sub
      Goto Top       Goto Form_f_ADMIN       Goto Index

cmd_NavigationPane_Click (7)

231     
232     
233     
234      Private Sub cmd_NavigationPane_Click() 
235       '131107
236         DoCmd.SelectObject acTable, "c_Contact", True 
237      End Sub 
      Goto Top       Goto Form_f_ADMIN       Goto Index

cmd_SaveClose_Click (113)

238     
239      Private Sub cmd_SaveClose_Click() 
240       '121125, 141014 iNumChanges, booRelinkerRunning
241         On Error GoTo Proc_Err 
242     
243         Dim nUsrID As Long _ 
244            , nUsrCatID As Long _ 
245            , sUsrName As String _ 
246            , sPath As String _ 
247            , iNumChanges As Integer 
248     
249         iNumChanges = 0 
250     
251         If booRelinkerRunning Then 
252            MsgBox "Wait until the Relinker is done", , "Can't save yet" 
253            GoTo Proc_Exit 
254         End If 
255     
256         With Me.UsrID 
257            If IsNull(.Value) Then 
258               .SetFocus 
259               MsgBox "Please choose a user", , "Cannot Save" 
260               GoTo Proc_Exit 
261            Else 
262               If IsNull(Me.usrCatID) Then 
263                  Me.usrCatID.SetFocus 
264                  If MsgBox("Do you want to set user priviges before saving?" _ 
265                     , vbYesNo + vbDefaultButton2 _ 
266                     , "User Category isn't set -- Save anyway?") = vbNo Then Exit Sub 
267                  Me.usrCatID.Dropdown 
268                  GoTo Proc_Exit 
269               End If 
270               If IsNull(Me.PathBE) Then 
271                  MsgBox "Please choose Back End Path", , "Cannot Save" 
272                  GoTo Proc_Exit 
273               End If 
274               nUsrID = Get_Property("local_UsrID") 
275               If nUsrID <> .Value Then 
276                  iNumChanges = iNumChanges + 1 
277                  nUsrID = Me.UsrID 
278                  Call Set_Property("local_usrID", nUsrID) 
279     
280                  sUsrName = Me.UsrID.Column(1) 
281                  If Not Len(sUsrName) > 0 Then 
282                     sUsrName = " " 
283                  End If 
284                  Call Set_Property("local_UsrName", sUsrName) 
285               End If 
286     
287            End If 
288         End With 
289     
290         With Me.usrCatID 
291            If IsNull(.Value) Then 
292               nUsrCatID = -99 
293            Else 
294               nUsrCatID = Get_Property("local_UsrCatID") 
295            End If 
296            If nUsrCatID <> .Value Then 
297               iNumChanges = iNumChanges + 1 
298               nUsrCatID = .Value 
299               Call Set_Property("local_UsrCatID", nUsrCatID) 
300            End If 
301         End With 
302     
303         sPath = Get_Property("local_PathBE") 
304         With Me.PathBE 
305            If sPath <> .Value Then 
306               iNumChanges = iNumChanges + 1 
307               sPath = .Value 
308               Call Set_Property("local_PathBE", sPath) 
309            End If 
310         End With 
311     
312         With Me.PathAtt 
313            If .Visible Then 
314               sPath = Get_Property("local_PathAtt") 
315               If sPath <> .Value Then 
316                  iNumChanges = iNumChanges + 1 
317                  sPath = .Value 
318                  Call Set_Property("local_PathAtt", sPath) 
319               End If 
320            End If 
321         End With 
322     
323         With Me.Path1 
324            If .Visible Then 
325               sPath = Get_Property("local_Path1") 
326               If sPath <> .Value Then 
327                  iNumChanges = iNumChanges + 1 
328                  sPath = .Value 
329                  Call Set_Property("local_Path1", sPath) 
330               End If 
331            End If 
332         End With 
333     
334          'open Contacts form
335         DoCmd.OpenForm "fc_MENU_CONTACT" 
336         MsgBox "Saved " & iNumChanges & " changed values for user setup", , "Done" 
337         DoCmd.Close acForm, Me.Name, acSaveNo 
338     
339      Proc_Exit: 
340         On Error Resume Next 
341         Exit Sub 
342     
343      Proc_Err: 
344         MsgBox Err.Description, , _ 
345              "ERROR " & Err.Number _ 
346              & "   cmd_SaveClose_Click : " & Me.Name 
347     
348         Resume Proc_Exit 
349         Resume 
350      End Sub 
      Goto Top       Goto Form_f_ADMIN       Goto Index

cmd_Cancel_Click (5)

351     
352      Private Sub cmd_Cancel_Click() 
353       '110519, 121125
354         DoCmd.Close acForm, Me.Name, acSaveNo 
355      End Sub 
      Goto Top       Goto Form_f_ADMIN       Goto Index

usrCatID_AfterUpdate (27)

356     
357     
358     
359      Private Sub usrCatID_AfterUpdate() 
360       '131110
361         If IsNull(Me.UsrID) Then Exit Sub 
362         Dim nUsrID As Long _ 
363            , nUsrCatID As Long _ 
364            , sSQL As String 
365         nUsrID = Me.UsrID 
366         sSQL = "UPDATE c_Usrs SET UsrCatID = " 
367         With Me.usrCatID 
368            If IsNull(.Value) Then 
369               nUsrCatID = -1 
370               sSQL = sSQL & " null " 
371            Else 
372               nUsrCatID = .Value 
373               sSQL = sSQL & nUsrCatID 
374            End If 
375         End With 
376         sSQL = sSQL & " WHERE UsrID=" & nUsrID 
377         Call rSql(sSQL) 
378     
379         Call Set_Property("local_UsrCatID", nUsrCatID) 
380     
381         Me.UsrID.Requery 
382      End Sub 
      Goto Top       Goto Form_f_ADMIN       Goto Index

UsrID_AfterUpdate (99)

383     
384      Private Sub UsrID_AfterUpdate() 
385       '131110, 140210
386          'change the default user
387          'CALLS
388          '  Set_Property
389     
390          '0. UsrID
391          '1. UsrName
392          '2. usrCat
393          '3. PathBE
394          '4. PathAtt
395          '5. Path1
396          '6. usrCatID
397     
398         Dim nUsrID As Long _ 
399            , nUsrCatID As Long _ 
400            , sUserName As String _ 
401            , sPath As String _ 
402            , sMsg As String _ 
403            , sSQL As String 
404     
405         With Me.UsrID 
406            nUsrID = .Value 
407       '      If .Column(1) <> .Text Then
408       '         MsgBox "text changed"
409       '         sMsg = "Do you want to CHANGE current username to '" _
410       '            & Replace(.Text, "'", "''") & "'" & "? "
411       '         If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CHANGE User Name?") = vbYes Then
412       '            sSQL = "UPDATE c_Usrs  " _
413       '                 & " SET UsrName = '" & Replace(.Text, "'", "''") & "'" _
414       '                 & " WHERE UsrID=" & nUsrID _
415       '                 & ";"
416       '            Call rSql(sSQL)
417       '            Me.UsrID.Requery
418       '         End If
419       '      End If
420       '
421       '      If nUsrID = Nz(.OldValue) Then Exit Sub
422            Set_Property "local_UsrID", nUsrID 
423     
424            If .Column(6) <> "" Then 
425               nUsrCatID = .Column(6) 
426               Me.usrCatID = nUsrCatID 
427            Else 
428               Me.usrCatID = Null 
429            End If 
430     
431            If UsrID.Column(3) <> "" Then 
432               sPath = Nz(.Column(3), " ") 
433               If Len(Trim(sPath)) > 0 Then 
434                  Me.PathBE = sPath 
435                   'link to tables
436                  Call ReLinker(sPath) 
437               Else 
438                  Me.PathBE = Null 
439               End If 
440            Else 
441               sPath = "" 
442               Me.PathBE = Null 
443            End If 
444            Call SetBackColor("BE", sPath) 
445     
446             'Attachment directory
447            If Me.PathAtt.Visible = True Then 
448               If UsrID.Column(4) <> "" Then 
449                  sPath = Nz(.Column(4), " ") 
450                  If Len(Trim(sPath)) > 0 Then 
451                     Me.PathAtt = sPath 
452                  Else 
453                     Me.PathAtt = Null 
454                  End If 
455               Else 
456                  sPath = "" 
457                  Me.PathAtt = Null 
458               End If 
459               Call SetBackColor("Att", sPath) 
460            End If 
461             'Template directory
462            If Me.Path1.Visible = True Then 
463               If UsrID.Column(5) <> "" Then 
464                  sPath = Nz(.Column(5), " ") 
465                  If Len(Trim(sPath)) > 0 Then 
466                     Me.Path1 = sPath 
467                  Else 
468                     Me.Path1 = Null 
469                  End If 
470                  Me.Path1 = sPath 
471               Else 
472                  sPath = "" 
473                  Me.Path1 = Null 
474                  Set_Property "local_Path1", " " 
475               End If 
476               Call SetBackColor("Tpl", sPath) 
477            End If 
478         End With   'Me.UsrID 
479     
480     
481      End Sub 
      Goto Top       Goto Form_f_ADMIN       Goto Index

UsrID_BeforeUpdate (8)

482     
483      Private Sub UsrID_BeforeUpdate(Cancel As Integer) 
484       '110918
485         If IsNull(Me.ActiveControl) Then 
486            MsgBox "you are not allowed to leave the User blank", , "Invalid choice" 
487            Cancel = True 
488         End If 
489      End Sub 
      Goto Top       Goto Form_f_ADMIN       Goto Index

pri_DropMe (6)

490     
491       '_____________________________
492      Private Function pri_DropMe() 
493       '131107
494         Me.ActiveControl.Dropdown 
495      End Function 
      Goto Top       Goto Form_f_ADMIN       Goto Index

UsrID_NotInList (94)

496     
497     
498       '_____________________________
499     
500       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NOT IN LIST
501      Private Sub UsrID_NotInList( _ 
502         NewData As String _ 
503         , Response As Integer) 
504       '131110, 25 strive4peace
505     
506          'add new user or modify existing user name
507     
508          'CALLS
509          '  UsrID_AfterUpdate
510     
511          'set up Error Handler
512         On Error GoTo Proc_Err 
513     
514         Dim sSQL As String _ 
515            , sMsg As String _ 
516            , nUsrID As Long _ 
517            , sNewData As String 
518     
519         sNewData = Trim(NewData) 
520     
521         If sNewData = Trim(Me.UsrID.Text) Then 
522             'nothing changed
523            Me.Undo 
524            Response = acDataErrContinue 
525            Exit Sub 
526         End If 
527     
528          ' Display message box asking if user wants to add a new item
529         sMsg = "Do you want to add '" & Replace(sNewData, "'", "''") & "'" & "? " _ 
530     
531          ' if you want the default to be NO instead of Yes,
532          ' substitute --> vbYesNo + vbDefaultButton2
533     
534         If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "ADD New User?") = vbNo Then 
535            nUsrID = Get_Property("local_UsrID") 
536            If nUsrID > 0 Then 
537               sMsg = "Do you want to CHANGE current username to '" _ 
538                  & Replace(sNewData, "'", "''") & "'" & "? " 
539               If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CHANGE User Name?") = vbYes Then 
540                  sSQL = "UPDATE c_Usrs  " _ 
541                       & " SET UsrName = '" & Replace(sNewData, "'", "''") & "'" _ 
542                       & " WHERE UsrID=" & nUsrID _ 
543                       & ";" 
544                  Call rSql(sSQL) 
545       '            Me.UsrID.Requery
546                  Response = acDataErrContinue 
547               Else 
548                  MsgBox "Default User not found", , "Cannot modify" 
549                  Me.UsrID.Undo 
550                  Response = acDataErrContinue 
551               End If 
552               Exit Sub 
553            End If 
554     
555            Me.UsrID.Undo 
556            Response = acDataErrContinue 
557            Exit Sub 
558         End If 
559     
560         nUsrID = Nz(DMax("UsrID", "c_Usrs"), 1) + 1 
561     
562         sSQL = "INSERT INTO c_Usrs (UsrID, UsrName) " _ 
563              & " SELECT " _ 
564              & ", " & nUsrID _ 
565              & ", '" & Replace(sNewData, "'", "''") & "'" _ 
566              & ";" 
567         Call rSql(sSQL) 
568         Me.UsrID = nUsrID 
569     
570         Response = acDataErrAdded 
571     
572          'set database properties
573         Call UsrID_AfterUpdate 
574     
575      Proc_Exit: 
576         On Error Resume Next 
577         Exit Sub 
578     
579      Proc_Err: 
580         MsgBox Err.Description, , _ 
581              "ERROR " & Err.Number _ 
582              & "   NotInList_Aircraft" 
583     
584         Resume Proc_Exit 
585     
586          'if you want to single-step code to find error, CTRL-Break at MsgBox
587          'then set this to be the next statement
588         Resume 
589      End Sub 
      Goto Top       Goto Form_f_ADMIN       Goto Index

SetDirectory (106)

590     
591       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ BROWSE
592      Private Function SetDirectory(psWhich As String _ 
593         , Optional psPath As Variant = "" _ 
594         , Optional ctl As Control _ 
595         ) As Byte 
596       'strive4peace ... 131125, 141014
597     
598          'PARAMETERS
599          '  psWhich = BE, Att, Tpl ... whatever fields/controls/properties you are using
600          '
601          'TITLE is the CAPTION property of the associated label
602          '( or the control Tag)
603     
604          'CALLS
605          '  rSql
606          '  ReLinker
607     
608          'note:
609          'passed path is not checked
610     
611         On Error GoTo Proc_Err 
612     
613         booRelinkerRunning = True 
614         Dim sFieldname As String _ 
615            , sStartPath As String _ 
616            , sPath As String _ 
617            , vTitle As Variant _ 
618            , sSQL As String 
619     
620         psPath = CStr(psPath) 
621     
622         sStartPath = "" 
623         vTitle = Null 
624     
625         sFieldname = "Path" & psWhich 
626     
627         With Me(sFieldname) 
628            If Len(Trim(psPath)) > 0 Then 
629                'have path
630               sStartPath = GetGoodPartOfPath(psPath) 
631            Else 
632                'path not specified -- get from control
633                  If Not IsNull(.Value) Then sStartPath = GetGoodPartOfPath(.Value) 
634            End If 
635            If .Controls.Count > 0 Then 
636               vTitle = .Controls(0).Caption 
637            Else 
638               If Not IsNull(.Tag) Then vTitle = .Tag 
639            End If 
640         End With 
641     
642         sPath = Get_DirectoryDialog(vTitle, sStartPath) 
643         If sPath = "" Then 
644             'user canceled
645             'no change
646            Exit Function 
647         End If 
648     
649          'see if path has something
650         If Len(Trim(sPath)) > 0 Then 
651             'see if path is good
652            If Not Len(Dir(sPath, vbDirectory)) > 0 Then 
653               sPath = GetGoodPartOfPath(sPath) 
654               If Not Len(sPath) > 2 Then 
655                  sPath = Get_DirectoryDialog("Directory for " & psWhich, sPath) 
656                  If sPath = "" Then 
657                      'cancel
658                     Exit Function 
659                  End If 
660               End If 
661            End If 
662            If Not Len(Trim(sPath)) > 0 Then 
663               GoTo Proc_Exit 
664            End If 
665            With Me(sFieldname) 
666               .Value = sPath 
667            End With 
668            sSQL = "UPDATE c_Usrs " _ 
669               & " SET " & sFieldname & " = '" & Replace(sPath, "'", "''") & "'" _ 
670               & " WHERE UsrID=" & Me.UsrID _ 
671               & ";" 
672     
673            Call rSql(sSQL) 
674            Me.UsrID.Requery 
675            If psWhich = "BE" Then 
676                'link to tables
677               Call ReLinker(sPath) 
678            End If 
679         End If 
680     
681      ColorTheControl: 
682         Call SetBackColor(psWhich, sPath) 
683     
684      Proc_Exit: 
685         On Error Resume Next 
686         booRelinkerRunning = False 
687         Exit Function 
688     
689      Proc_Err: 
690         MsgBox Err.Description, , _ 
691              "ERROR " & Err.Number _ 
692              & "   SetDirectory : " & Me.Name 
693         Resume Proc_Exit 
694         Resume 
695      End Function 
      Goto Top       Goto Form_f_ADMIN       Goto Index

cmd_OpenUsers_Click (12)

696     
697     
698     
699      Private Sub cmd_OpenUsers_Click() 
700       '131110, 141008
701         DoCmd.OpenTable "c_Usrs" 
702            MsgBox "If you edit the user category (privileges) while the Admin form is open, " _ 
703            & " pick another user on the Admin form and then pick the users whose settings were changed " _ 
704            & " to ensure the changes are read correctly." _ 
705            & vbCrLf & vbCrLf & "It is better to change the User Category using the Admin form." _ 
706            , , "NOTE: Table Edits may be ignored by the Admin form until it is re-opened" 
707      End Sub 
      Goto Top       Goto Form_f_ADMIN       Goto Index

cmd_Relink_Click (17)

708     
709      Private Sub cmd_Relink_Click() 
710       '131125
711         Dim sPath As String 
712         With Me.PathBE 
713            If IsNull(.Value) Then 
714                'Current Project Path will be used to relink
715               sPath = CurrentProject.Path 
716               Exit Sub 
717            End If 
718            sPath = .Value 
719             'link to tables
720         End With 
721         booRelinkerRunning = True 
722         Call ReLinker(sPath) 
723         booRelinkerRunning = False 
724      End Sub 
      Goto Top       Goto Form_f_ADMIN       Goto Index

cmdExit_Click (5)

725     
726      Private Sub cmdExit_Click()   ' ------------ NOT USED 
727       '110519
728         Application.Quit 
729      End Sub 
      Goto Top       Goto Form_f_ADMIN       Goto Index

pri_UsrMgt_SetProperties (105)

730     
731       '_________________________________________________ PROPERTIES
732     
733      Private Sub pri_UsrMgt_SetProperties( _ 
734           Optional bSkipMsg As Boolean = True _ 
735         ) 
736       '131107, 1110
737     
738          ' PARAMETERS
739          ' bSkipMsg = True: skip user intereraction
740     
741          ' CALLS
742          ' IsPropertyDefined
743          ' Set_Property
744     
745     
746         On Error GoTo Proc_Err 
747     
748         Dim i As Integer _ 
749            , sPropName As String _ 
750            , nPropType As Long _ 
751            , varValue As Variant 
752     
753         Dim db  As DAO.Database 
754     
755         Set db = CurrentDb 
756     
757          '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ set properties
758     
759         For i = 1 To 9 
760     
761            Select Case i 
762     
763            Case 1 
764               sPropName = "local_IsAdmin" 
765               nPropType = dbBoolean 
766               varValue = True 
767     
768            Case 2 
769               sPropName = "local_UsrID" 
770               nPropType = dbLong 
771               varValue = -1 
772     
773            Case 3 
774               sPropName = "local_UsrCatID" 
775               nPropType = dbLong 
776               varValue = -1 
777     
778            Case 4 
779               sPropName = "local_UsrName" 
780               nPropType = dbText 
781               varValue = " " 
782     
783            Case 5 
784               sPropName = "local_PathBE" 
785               nPropType = dbText 
786               varValue = " " 
787     
788            Case 6 
789               sPropName = "local_PathAtt" 
790               nPropType = dbText 
791               varValue = " " 
792     
793            Case 7 
794               sPropName = "local_Path1" 
795               nPropType = dbText 
796               varValue = " " 
797     
798            Case 8 
799               sPropName = "local_Password" 
800               nPropType = dbText 
801               varValue = " " 
802     
803            Case 9 
804               sPropName = "local_AdminMode" 
805               nPropType = dbBoolean 
806               varValue = False 
807     
808            End Select 
809     
810            If Not IsPropertyDefined(sPropName, db) Then 
811               Call Set_Property(sPropName, varValue, nPropType, db, bSkipMsg) 
812            End If 
813     
814         Next i 
815     
816     
817         If Not bSkipMsg Then 
818            MsgBox "Default Database Properties are set", , "Done" 
819         End If 
820     
821      Proc_Exit: 
822         Exit Sub 
823     
824      Proc_Err: 
825         MsgBox Err.Description, , _ 
826             "ERROR " & Err.Number _ 
827              & "   pri_UsrMgt_SetProperties" 
828     
829         Resume Proc_Exit 
830     
831          'if you want to single-step code to find error, CTRL-Break at MsgBox
832          'then set this to be the next statement
833         Resume 
834      End Sub 
      Goto Top       Goto Form_f_ADMIN       Goto Index

SetBackColor (19)

835     
836      Private Function SetBackColor(psWhich As String _ 
837         , psPath As String _ 
838         , Optional ctlnameEnable As String = "" _ 
839         ) As Byte 
840       '131125
841          'CALLS
842          '  Get_ColorDirectory
843     
844         Dim sControlname As String 
845     
846         sControlname = "Path" & psWhich 
847     
848         With Me(sControlname) 
849       'MsgBox .Value
850            .BackColor = Get_ColorDirectory(psWhich, psPath, Me, sControlname, , "cmd_SaveClose") 
851       '      .BackColor = RGB(255, 0, 0)
852         End With 
853      End Function 
      Goto Top       Goto Form_f_ADMIN       Goto Index

Get_ColorDirectory (104)

854     
855      Public Function Get_ColorDirectory(psWhich As String _ 
856         , Optional pvPath As Variant = "" _ 
857         , Optional frm As Form _ 
858         , Optional ctlname As String = "" _ 
859          , Optional pIsPath As Boolean = True _ 
860         , Optional ctlnameEnable As String = "" _ 
861        ) As Long 
862       '131114, 15, 25, 141014 booEnable
863     
864         Dim nDirAttrib As Integer _ 
865            , sControlTipText As String _ 
866            , booEnable As Variant 
867     
868         sControlTipText = "" 
869         booEnable = False 
870     
871         If IsNull(pvPath) Then 
872            pvPath = "" 
873         End If 
874     
875         If Not Len(Trim(pvPath)) > 1 Then 
876             'path not specified (enough)
877            Get_ColorDirectory = RGB(255, 255, 200)   'yellow 
878            sControlTipText = "Path not specified" 
879            GoTo Proc_Exit 
880         End If 
881     
882         If InStr(pvPath, ".") = 0 And Len(Trim(pvPath)) > 1 Then 
883            If Right(pvPath, 1) <> "\" Then 
884               pvPath = pvPath & "\" 
885            End If 
886         End If 
887     
888         If pIsPath Then 
889            nDirAttrib = vbDirectory 
890         Else 
891             'File
892            nDirAttrib = vbNormal 
893         End If 
894     
895         If Not Len(Dir(pvPath, nDirAttrib)) > 0 Then 
896             'not found
897            Get_ColorDirectory = RGB(255, 0, 0)   'red 
898            sControlTipText = "Directory does not exist" 
899            booEnable = False 
900            GoTo Proc_Exit 
901         Else 
902             'found
903            If psWhich = "BE" Then 
904                'BACK END
905               If Right(pvPath, 1) <> "\" Then 
906                  pvPath = pvPath & "\" 
907               End If 
908               pvPath = pvPath & "*_be_*.*db" 'assume '_be_' is in the filename 
909               If Len(Dir(pvPath, nDirAttrib)) > 0 Then 
910                  Get_ColorDirectory = RGB(255, 255, 255)   'white 
911                  sControlTipText = "Path " & psWhich 
912                  booEnable = True 
913                  GoTo Proc_Exit 
914               Else 
915                   'path found but not file
916                  Get_ColorDirectory = RGB(255, 200, 100)   'orange 
917                  sControlTipText = "Path found but no file" 
918                  GoTo Proc_Exit 
919               End If 
920            Else 
921                'found
922               Get_ColorDirectory = RGB(255, 255, 255)   'white 
923               sControlTipText = "Path found" 
924               GoTo Proc_Exit 
925            End If 
926         End If 
927     
928     
929      Proc_Exit: 
930         On Error Resume Next 
931       '   If Len(ctlname) > 0 Then
932       '      frm(ctlname).ControlTipText = sControlTipText
933       '   End If
934       '   If Len(ctlnameEnable) > 0 Then
935       '      frm(ctlnameEnable).Enabled = booEnable
936       '   End If
937       '   DoEvents
938     
939         Exit Function 
940     
941      Proc_Err: 
942         If Err.Number = 13 Then   'directory not found 
943             'not found
944      Debug.Print pvPath 
945            Get_ColorDirectory = RGB(255, 0, 0)   'red 
946            Resume Proc_Exit 
947         End If 
948         MsgBox Err.Description, , _ 
949              "ERROR " & Err.Number _ 
950              & "   Get_ColorDirectory " 
951         Resume Proc_Exit 
952         Resume 
953     
954     
955          '13 -- not found
956     
957      End Function 
      Goto Top       Goto Form_f_ADMIN       Goto Index

Get_DirectoryDialog (33)

958     
959     
960       '_________________________________________________ Get_DirectoryDialog
961     
962      Public Function Get_DirectoryDialog( _ 
963         Optional pvTitle As Variant _ 
964         , Optional psStartPath As String = vbNullString _ 
965         ) As String 
966       '131110 strive4peace, 140102
967     
968          'NEEDS REFERENCE
969          '  Microsoft Office #.# Object Library
970     
971         Dim oFileDialog As Office.FileDialog 
972     
973         Set oFileDialog = Application.FileDialog(4)   '4 = Folder Picker 
974     
975         With oFileDialog 
976     
977            .AllowMultiSelect = False 
978            .Title = "Select folder " & (" for " + pvTitle) 
979            If psStartPath <> vbNullString Then 
980               If Right(psStartPath, 1) <> "\" Then psStartPath = psStartPath & "\" 
981               .InitialFileName = psStartPath 
982            End If 
983            If .Show = True Then 
984               Get_DirectoryDialog = .SelectedItems(1) 
985            Else 
986               Get_DirectoryDialog = vbNullString 
987            End If 
988         End With 
989         Set oFileDialog = Nothing 
990      End Function 
      Goto Top       Goto Form_f_ADMIN       Goto Index

GetGoodPartOfPath (34)

991     
992     
993     
994      Public Function GetGoodPartOfPath( _ 
995         Optional ByVal psPath As Variant = "") As String 
996       '131125, 140102 strive4peace
997          'return the part of the path that is valid
998     
999         Dim iPos As Integer _ 
1,000       , sPath As String 
1,001   
1,002       sPath = psPath 
1,003   
1,004       If Len(Dir(sPath, vbDirectory)) > 0 Then 
1,005          GetGoodPartOfPath = psPath 
1,006          Exit Function 
1,007       End If 
1,008   
1,009       Do While Len(sPath) > 0 
1,010          If Right(sPath, 1) = "\" Then 
1,011             sPath = Left(sPath, Len(sPath) - 1) 
1,012          End If 
1,013          iPos = InStrRev(sPath, "\") 
1,014          sPath = Left(sPath, iPos) 
1,015          If Len(Dir(sPath, vbDirectory)) > 0 Then 
1,016             GetGoodPartOfPath = sPath 
1,017             Exit Function 
1,018          End If 
1,019       Loop 
1,020   
1,021       GetGoodPartOfPath = "\" 
1,022   
1,023    End Function 
1,024   
      Goto Top       Goto Form_f_ADMIN       Goto Index

Form_f_AnywhereMENU (401)

PROCEDURES       Goto Top       Goto Form_f_AnywhereMENU       Goto Forms       Goto Index
  1. cmd_Attachments_Click (15)
  2. cmd_AttachNote_Click (20)
  3. cmd_ClearFilter_Click (6)
  4. cmd_Design_Click (8)
  5. cmd_Open_Click (8)
  6. Declaration Lines (28)
  7. fltrTablename_AfterUpdate (5)
  8. Form_Load (9)
  9. Form_Open (11)
  10. Label_By_Click (6)
  11. local_GetDataType (55)
  12. local_MakeQuery (49)
  13. RowSource_Fieldlist (75)
  14. RowSource_TID (38)
  15. SourceObject_fc_AnywhereSub (39)
  16. TID_AfterUpdate (22)
  17. TID_MouseUp (7)

Declaration Lines (28)

1        Option Compare Database 
2        Option Explicit 
3         '============================================================ LICENSE NOTICE -- must not be modified
4         ' This software is licensed to you under CC BY-NC-SA 3.0
5         '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
6         ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
7         '
8         ' You are free to:
9         '    Share  copy and redistribute the material in any medium or format
10        '    Adapt  remix, transform, and build upon the material
11        ' The licensor cannot revoke these freedoms as long as you follow these terms:
12        '    Attribution  You must give appropriate credit, provide a link to the license,
13        '                   and indicate if changes were made.
14        '                   You may do so in any reasonable manner,
15        '                   but not in any way that suggests the licensor endorses you or your use.
16        '    NonCommercial  You may not use the material for commercial purposes.
17        '    ShareAlike  If you remix, transform, or build upon the material,
18        '                 you must distribute your contributions under the same license as the original.
19        '
20        ' many procedures and module names contain author or controbitor names that must be left intact
21        ' if you make changes, add your name, date, and descriptive information to the comments
22        '
23        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629
24        ' ~ Crystal
25        '              * have an awesome day :)
26        '                                                   www.AccessMVP.com/strive4peace
27        ' END LICENSE NOTICE
28        '============================================================
      Goto Top       Goto Form_f_AnywhereMENU       Goto Index

cmd_Attachments_Click (15)

29      
30       Private Sub cmd_Attachments_Click() 
31        '130908
32          On Error Resume Next 
33      
34          With Me.fc_AnywhereSub.Form 
35        '      If .Dirty Then .Dirty = False
36             If Not .NewRecord Then 
37                Call Set_Property("local_TID", .TID) 
38                Call Set_Property("local_RecordID", .ID) 
39                DoCmd.OpenForm "fc_AnywhereAttachments", , , , , acDialog 
40                .Refresh 
41             End If 
42          End With   'Me 
43       End Sub 
      Goto Top       Goto Form_f_AnywhereMENU       Goto Index

cmd_AttachNote_Click (20)

44      
45       Private Sub cmd_AttachNote_Click() 
46        '130908
47          On Error Resume Next 
48          Dim nTID As Long _ 
49             , nRecordID As Long 
50      
51          With Me.fc_AnywhereSub.Form 
52             If Me.TID.Column(1) = "c_notes" Then 
53                 'popup form to see selected note instead of attaching
54                nTID = DLookup("TID", "c_notes", "NoteID=" & .ID) 
55                nRecordID = DLookup("RecordID", "c_notes", "NoteID=" & .ID) 
56                Call popNotes(Me, nTID, nRecordID) 
57             Else 
58                Call popNotes(Me, .TID, .ID) 
59             End If 
60      
61             .Refresh 
62          End With   'Me 
63       End Sub 
      Goto Top       Goto Form_f_AnywhereMENU       Goto Index

Form_Open (11)

64      
65      
66      
67       Private Sub Form_Open(Cancel As Integer) 
68        '120426 Crystal, 130919
69          With Me 
70             .lstFieldname.RowSource = "Pick Table" 
71             .TID.RowSource = .TID.Tag 
72             .fc_AnywhereSub.SourceObject = "" 
73          End With   'me 
74       End Sub 
      Goto Top       Goto Form_f_AnywhereMENU       Goto Index

Form_Load (9)

75      
76       Private Sub Form_Load() 
77        '120426 Crystal, 130919
78          On Error Resume Next 
79          With Me 
80             .SumSize = 0 
81          End With 
82      
83       End Sub 
      Goto Top       Goto Form_f_AnywhereMENU       Goto Index

fltrTablename_AfterUpdate (5)

84      
85       Private Sub fltrTablename_AfterUpdate() 
86        '130425, 130919
87          Call RowSource_TID(Me.fltrTablename.Value) 
88       End Sub 
      Goto Top       Goto Form_f_AnywhereMENU       Goto Index

cmd_ClearFilter_Click (6)

89      
90       Private Sub cmd_ClearFilter_Click() 
91        '130919 Crystal
92          Me.fltrTablename.Value = Null 
93          Call RowSource_TID(Me.fltrTablename.Value) 
94       End Sub 
      Goto Top       Goto Form_f_AnywhereMENU       Goto Index

RowSource_TID (38)

95      
96       Private Sub RowSource_TID( _ 
97          Optional varTableLike As Variant _ 
98          , Optional booReset As Boolean = False _ 
99          ) 
100       '120426 Crystal
101         Dim sSQL As String _ 
102            , varWhere As Variant _ 
103            , iPos As Integer 
104     
105         sSQL = Me.TID.Tag 
106     
107         If Not IsNull(varTableLike) Then 
108               iPos = InStr(sSQL, "WHERE ") + 5 
109               sSQL = Left(sSQL, iPos) _ 
110                  & " (Tbl Like ""*" & varTableLike & "*"") AND " _ 
111                  & Mid(sSQL, iPos) 
112         End If 
113     
114      Debug.Print sSQL 
115     
116         With Me.TID 
117            .RowSource = sSQL 
118     
119            If booReset Then 
120               .Requery 
121               If IsNull(.Column(0)) Then 
122                  .Value = Null 
123                  Me.lstFieldname.RowSource = "Pick Table" 
124                  Me.lstFieldname.Requery 
125                  Me.SumSize = 0 
126               End If 
127            End If 
128            .SetFocus 
129            .Dropdown 
130         End With 
131     
132      End Sub 
      Goto Top       Goto Form_f_AnywhereMENU       Goto Index

TID_AfterUpdate (22)

133     
134      Private Sub TID_AfterUpdate() 
135       ' 130427, 130913
136         Dim sTablename As String _ 
137            , nTID As Long 
138     
139         Me.fc_AnywhereSub.SourceObject = "" 
140     
141         If IsNull(Me.TID) Then 
142            Me.lstFieldname.RowSource = "Pick a Table" 
143            Exit Sub 
144         End If 
145     
146         With Me.TID 
147            sTablename = .Column(1) 
148         End With   'Me.TID 
149         DoEvents 
150     
151         Call RowSource_Fieldlist(sTablename) 
152     
153         Call SourceObject_fc_AnywhereSub 
154      End Sub 
      Goto Top       Goto Form_f_AnywhereMENU       Goto Index

SourceObject_fc_AnywhereSub (39)

155     
156      Private Sub SourceObject_fc_AnywhereSub() 
157       '130917
158         Dim nTID As Long _ 
159            , sTablename As String _ 
160            , sFriendlyTable As String _ 
161            , sIDFieldname As String _ 
162            , sEquation As String _ 
163            , sSQL As String 
164     
165         With Me.TID 
166            If IsNull(.Value) Then 
167               Me.fc_AnywhereSub.SourceObject = "" 
168               Exit Sub 
169            End If 
170     
171            nTID = .Value 
172            sTablename = .Column(1) 
173            sFriendlyTable = .Column(2) 
174            sIDFieldname = .Column(5) 
175            sEquation = .Column(6) 
176     
177            sSQL = "SELECT tbl.[" & sIDFieldname & "] AS ID" _ 
178               & ", " & sEquation & " AS Record " _ 
179               & ", clng(DCount(""*"",""c_Attachments""" _ 
180                  & ",""TID=" & nTID & " AND RecordID= "" & " & sIDFieldname _ 
181                  & ")) AS NumAtt" _ 
182               & ", clng(DCount(""*"",""c_Notes""" _ 
183                  & ",""TID=" & nTID & " AND RecordID= "" & " & sIDFieldname _ 
184                  & ")) AS NumNote" _ 
185               & ", " & nTID & " AS TID " _ 
186               & " FROM [" & sTablename & "] AS tbl " _ 
187               & " ORDER BY " & sEquation & ";" 
188            Call local_MakeQuery(sSQL, "c_qAnywhere") 
189         End With 
190     
191         Me.fc_AnywhereSub.SourceObject = "fc_AnywhereSub" 
192     
193      End Sub 
      Goto Top       Goto Form_f_AnywhereMENU       Goto Index

RowSource_Fieldlist (75)

194     
195      Private Sub RowSource_Fieldlist(psTablename As String) 
196       '130425, 26, 130427
197     
198          'CALLS
199          '  dd_GetPropertyValue
200          '  local_GetDataType
201          '  dd_GetControlType
202          '  dd_CanGet_ObjectProperty (dd_CanGet_PropertyValue)
203     
204         On Error GoTo Proc_Err 
205         Dim sSQL As String _ 
206            , sRowSource As String _ 
207            , bBoo As Boolean _ 
208            , sFieldname As String _ 
209            , nSumSize As Long 
210     
211     
212         sRowSource = "" 
213     
214         Dim db As DAO.Database _ 
215            , tdf As DAO.TableDef _ 
216            , fld As DAO.Field 
217     
218         If IsNull(Me.TID) Then GoTo Proc_WriteResults 
219     
220         Set db = CurrentDb 
221         psTablename = Me.TID.Column(1) 
222         Set tdf = db.TableDefs(psTablename) 
223     
224         For Each fld In tdf.Fields 
225            With fld 
226     
227               sRowSource = sRowSource _ 
228                              & .Name & ";" _ 
229                              & local_GetDataType(.Type, True) & ";" _ 
230                              & .Size & ";" 
231               nSumSize = nSumSize + .Size   'not taking unicode compression into account 
232            End With   'fld 
233         Next fld 
234         If Len(sRowSource) > 0 Then 
235            sRowSource = "Fieldname;DataType;Size;" & sRowSource 
236         Else 
237            sRowSource = "Pick Table" 
238         End If 
239     
240      Proc_WriteResults: 
241         Me.SumSize = nSumSize 
242     
243         With Me.lstFieldname 
244            .Value = Null 
245            .RowSource = sRowSource 
246            .Requery 
247         End With 
248     
249      Proc_Exit: 
250         On Error Resume Next 
251         Set fld = Nothing 
252         Set tdf = Nothing 
253         Set db = Nothing 
254         Exit Sub 
255     
256      Proc_Err: 
257         If Err.Number = 3265 Then 
258            MsgBox "Cannot View Table: " & psTablename, , "Error" 
259            sRowSource = "Pick Table" 
260            Resume Proc_WriteResults 
261         End If 
262         MsgBox Err.Description, , _ 
263              "ERROR " & Err.Number _ 
264              & "   RowSource_Fieldlist : " & Me.Name 
265     
266         Resume Proc_Exit 
267         Resume 
268      End Sub 
      Goto Top       Goto Form_f_AnywhereMENU       Goto Index

TID_MouseUp (7)

269     
270     
271      Private Sub TID_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
272       '130425
273         On Error Resume Next 
274         Me.ActiveControl.Dropdown 
275      End Sub 
      Goto Top       Goto Form_f_AnywhereMENU       Goto Index

cmd_Design_Click (8)

276     
277      Private Sub cmd_Design_Click() 
278       '130425
279         Dim sTablename As String 
280         If IsNull(Me.TID) Then Exit Sub 
281         sTablename = Me.TID.Column(1) 
282         DoCmd.OpenTable sTablename, acViewDesign 
283      End Sub 
      Goto Top       Goto Form_f_AnywhereMENU       Goto Index

cmd_Open_Click (8)

284     
285      Private Sub cmd_Open_Click() 
286       '130425
287         If IsNull(Me.TID) Then Exit Sub 
288         Dim sTablename As String 
289         sTablename = Me.TID.Column(1) 
290         DoCmd.OpenTable sTablename, acViewNormal 
291      End Sub 
      Goto Top       Goto Form_f_AnywhereMENU       Goto Index

Label_By_Click (6)

292     
293      Private Sub Label_By_Click() 
294         On Error Resume Next 
295         Application.FollowHyperlink _ 
296            "mailto: strive4peace2010@yahoo.com?subject=Anywhere Contact comment " 
297      End Sub 
      Goto Top       Goto Form_f_AnywhereMENU       Goto Index

local_GetDataType (55)

298     
299     
300     
301      Private Function local_GetDataType(ByVal pDataTypN As Long _ 
302         , Optional pBooShort As Boolean = False _ 
303         ) As String 
304     
305       '100310
306     
307         local_GetDataType = "" 
308         On Error Resume Next 
309     
310         Switch 
311         Select Case Nz(pDataTypN) 
312            Case 1: local_GetDataType = IIf(pBooShort, "YN", "Boolean") 
313            Case 2: local_GetDataType = IIf(pBooShort, "Byt", "Byte") 
314            Case 3: local_GetDataType = IIf(pBooShort, "Int", "Integer") 
315            Case 4: local_GetDataType = IIf(pBooShort, "Lng", "Long") 
316            Case 5: local_GetDataType = IIf(pBooShort, "Cur", "Currency") 
317            Case 6: local_GetDataType = IIf(pBooShort, "Sgl", "Single") 
318            Case 7: local_GetDataType = IIf(pBooShort, "Dbl", "Double") 
319            Case 8: local_GetDataType = IIf(pBooShort, "DatT", "DateTime") 
320            Case 10: local_GetDataType = IIf(pBooShort, "Txt", "Text") 
321            Case 12: local_GetDataType = IIf(pBooShort, "Mem", "Memo") 
322     
323            Case 9: local_GetDataType = IIf(pBooShort, "Bin", "Binary") 
324            Case 11: local_GetDataType = IIf(pBooShort, "Ole", "Ole BinBMP") 
325     
326            Case 15: local_GetDataType = IIf(pBooShort, "Guid", "GUID") 
327            Case 16: local_GetDataType = IIf(pBooShort, "BigInt", "Big Integer") 
328            Case 17: local_GetDataType = IIf(pBooShort, "BinVar", "Binary Variable") 
329     
330       '      Case 16: mStr = "Auto"
331     
332            Case 18: local_GetDataType = IIf(pBooShort, "TxtFix", "Fixed Text") 
333     
334            Case 19: local_GetDataType = IIf(pBooShort, "oNum", "Numeric odbc") 
335            Case 20: local_GetDataType = IIf(pBooShort, "oDec", "Decimal odbc") 
336            Case 21: local_GetDataType = IIf(pBooShort, "oFlo", "Float odbc") 
337            Case 22: local_GetDataType = IIf(pBooShort, "oTime", "Time odbc") 
338            Case 23: local_GetDataType = IIf(pBooShort, "oDatT", "DateTime odbc") 
339     
340            Case 101: local_GetDataType = IIf(pBooShort, "att", "Attachment") 
341            Case 102: local_GetDataType = IIf(pBooShort, "mvByt", "Byte MV") 
342            Case 103: local_GetDataType = IIf(pBooShort, "mvInt", "Integer MV") 
343            Case 104: local_GetDataType = IIf(pBooShort, "mvLng", "Long Integer MV") 
344            Case 105: local_GetDataType = IIf(pBooShort, "mvSgl", "Single MV") 
345            Case 106: local_GetDataType = IIf(pBooShort, "mvDbl", "Double MV") 
346            Case 107: local_GetDataType = IIf(pBooShort, "mvGuid", "Guid MV") 
347            Case 108: local_GetDataType = IIf(pBooShort, "mvDec", "Decimal MV") 
348            Case 109: local_GetDataType = IIf(pBooShort, "mvTxt", "Text MV") 
349     
350            Case Else: local_GetDataType = Format(Nz(pDataTypN), "0") 
351         End Select 
352      End Function 
      Goto Top       Goto Form_f_AnywhereMENU       Goto Index

local_MakeQuery (49)

353     
354     
355     
356       '~~~~~~~~~~~~~~~~~~~~~ MakeQuery
357      Private Sub local_MakeQuery( _ 
358         ByVal pSQL As String, _ 
359         ByVal qName As String) 
360     
361          'modified 3-30-08 -- meant to be a general Sub, included here for convenience
362          'crystal
363          'strive4peace2009 at yahoo dot com
364     
365         On Error GoTo Proc_Err 
366     
367      Debug.Print pSQL 
368     
369          'if query already exists, update the SQL
370          'if not, create the query
371     
372          If Nz(DLookup("[Name]", "MSysObjects", _ 
373              "[Name]='" & qName _ 
374              & "' And [Type]=5"), "") = "" Then 
375              CurrentDb.CreateQueryDef qName, pSQL 
376          Else 
377              'if query is open, close it
378             On Error Resume Next 
379             DoCmd.Close acQuery, qName, acSaveNo 
380             On Error GoTo Proc_Err 
381             CurrentDb.QueryDefs(qName).SQL = pSQL 
382          End If 
383     
384      Proc_Exit: 
385         CurrentDb.QueryDefs.Refresh 
386         Application.RefreshDatabaseWindow 
387         DoEvents 
388         Exit Sub 
389     
390      Proc_Err: 
391         MsgBox Err.Description, , _ 
392           "ERROR " & Err.Number & "  MakeQuery" 
393     
394         Resume Proc_Exit 
395     
396          'if you want to single-step code to find error, CTRL-Break at MsgBox
397          'then set this to be the next statement
398         Resume 
399      End Sub 
400       '~~~~~~~~~~~~~~~~~~~~~~~~~~
401     
      Goto Top       Goto Form_f_AnywhereMENU       Goto Index

Form_f_Calendar_sub (1014)

PROCEDURES       Goto Top       Goto Form_f_Calendar_sub       Goto Forms       Goto Index
  1. Add_SetCalendar (32)
  2. cal_GetCardinalNumber (28)
  3. cal_GetCol4Calendar (5)
  4. cal_GetDowN4Calendar (26)
  5. cal_GetRoman (51)
  6. cal_GetRow4Calendar (38)
  7. cal_IsSubform (17)
  8. cal_ShowHideControlsTag (34)
  9. cmd11_Click (4)
  10. cmd12_Click (4)
  11. cmd13_Click (4)
  12. cmd14_Click (4)
  13. cmd15_Click (4)
  14. cmd16_Click (4)
  15. cmd17_Click (4)
  16. cmd21_Click (4)
  17. cmd22_Click (4)
  18. cmd23_Click (4)
  19. cmd24_Click (4)
  20. cmd25_Click (4)
  21. cmd26_Click (4)
  22. cmd27_Click (4)
  23. cmd31_Click (4)
  24. cmd32_Click (4)
  25. cmd33_Click (4)
  26. cmd34_Click (4)
  27. cmd35_Click (4)
  28. cmd36_Click (4)
  29. cmd37_Click (4)
  30. cmd41_Click (4)
  31. cmd42_Click (4)
  32. cmd43_Click (4)
  33. cmd44_Click (4)
  34. cmd45_Click (4)
  35. cmd46_Click (4)
  36. cmd47_Click (4)
  37. cmd51_Click (4)
  38. cmd52_Click (4)
  39. cmd53_Click (4)
  40. cmd54_Click (4)
  41. cmd55_Click (4)
  42. cmd56_Click (4)
  43. cmd57_Click (4)
  44. cmd61_Click (4)
  45. cmd62_Click (4)
  46. cmd63_Click (4)
  47. cmd64_Click (4)
  48. cmd65_Click (4)
  49. cmd66_Click (4)
  50. cmd67_Click (4)
  51. cmdDayAdd_Click (18)
  52. cmdDaySub_Click (19)
  53. cmdMonthAdd_Click (23)
  54. cmdMonthSub_Click (16)
  55. cmdYrAdd_Click (20)
  56. cmdYrSub_Click (19)
  57. DayClick (41)
  58. Declaration Lines (43)
  59. Form_Load (50)
  60. Form_Open (9)
  61. Label_strive4peace_Click (8)
  62. Mark_TodayAndDate (68)
  63. Set_Calendar (189)
  64. Set_DefaultFormat (26)
  65. ShowDatePickerMessage (13)
  66. txtCalendarDate_AfterUpdate (14)
  67. txtCalendarDate_BeforeUpdate (18)
  68. Update_ExternalForms (21)

Declaration Lines (43)

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_Calendar_sub
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        ' me.txtCalendarDate holds the calendar date
40        '
41        ' the sub Update_ExternalForms is for YOU to customize
42        '                              in case you want to synchronize the calendar with other forms
43        '
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

Update_ExternalForms (21)

44      
45        '-------------------------------------------------------------------- external forms -- CUSTOMIZE
46        '---------------------------------------- Update_ExternalForms
47       Public Sub Update_ExternalForms(pDate As Variant) 
48        '130119
49      
50          On Error GoTo Proc_Err 
51          Me.Parent.dtmAppt = pDate 
52      
53       Proc_Exit: 
54        '   On Error Resume Next
55          Exit Sub 
56      
57       Proc_Err: 
58          MsgBox Err.Description, , _ 
59               "ERROR " & Err.Number _ 
60               & "   Update_ExternalForms : " & Me.Name 
61      
62          Resume Proc_Exit 
63          Resume 
64       End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

Form_Open (9)

65      
66      
67      
68       Private Sub Form_Open(Cancel As Integer) 
69        '130119 Crystal
70          Me.cmdMonth.Caption = Format(Date, "mmmm") 
71          Me.cmdMonth.Tag = Format(Date, "m") 
72          Me.cmdYr.Caption = Format(Date, "yyyy") 
73       End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

Form_Load (50)

74      
75        '-------------------------------------------------------------------- FORM
76      
77       Private Sub Form_Load() 
78        '120514, commented 120622, 23
79        '   sets the calendar to TODAY
80        '   unless a date is in the active control
81        '    or a date is passed in the OpenArgs
82        '
83        ' CALLS
84        '    cal_cal_GetRow4Calendar
85        '    cal_cal_GetCol4Calendar
86        '    Set_Calendar
87        '    cal_ShowHideControlsTag
88      
89           On Error GoTo Proc_Err 
90      
91           Dim nRow As Integer _ 
92             , nCol As Integer _ 
93                , iPos As Integer _ 
94                , nDate As Date _ 
95                , sStr As String 
96      
97          nDate = Date 
98      
99          nRow = cal_GetRow4Calendar(nDate) 
100         nCol = cal_GetCol4Calendar(nDate) 
101     
102          'keep track so colors can be set back to normal
103     
104         Me.txtRowPick = nRow 
105         Me.txtColPick = nCol 
106         Me.txtRowCur = nRow 
107         Me.txtColCur = nCol 
108         Me.txtCalendarDate = nDate 
109     
110         Set_Calendar nDate 
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_Load : " & Me.Name 
120     
121         Resume Proc_Exit 
122         Resume 
123      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

DayClick (41)

124     
125     
126       '-------------------------------------------------------------------- CHANGE CALENDAR DAY
127      Public Sub DayClick() 
128       '... 120622
129     
130       ' CALLS
131          ' Set_Calendar
132          ' Update_ExternalForms
133     
134          On Error GoTo Proc_Err 
135          If Me.ActiveControl.Caption = "" Then 
136               'user clicked on a day with no number - do nothing
137              Exit Sub 
138          End If 
139     
140          Dim nRow As Integer _ 
141              , nCol As Integer 
142     
143          Dim nDate As Date _ 
144              , nDay As Integer 
145     
146          nDay = Me.ActiveControl.Caption 
147     
148          nDate = DateSerial(Me.cmdYr.Caption, Me.cmdMonth.Tag, nDay) 
149     
150          Set_Calendar nDate 
151          Update_ExternalForms nDate 
152     
153      Proc_Exit: 
154         On Error Resume Next 
155         Exit Sub 
156     
157      Proc_Err: 
158         MsgBox Err.Description, , _ 
159              "ERROR " & Err.Number _ 
160              & "   DayClick : " & Me.Name 
161     
162         Resume Proc_Exit 
163         Resume 
164      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

txtCalendarDate_AfterUpdate (14)

165     
166      Public Sub txtCalendarDate_AfterUpdate() 
167       '120701
168          Dim nDate As Date 
169          nDate = Me.txtCalendarDate 
170          Set_Calendar nDate 
171          Update_ExternalForms nDate 
172     
173      Proc_Exit: 
174         On Error Resume Next 
175         Exit Sub 
176      Proc_Err: 
177         Resume Proc_Exit 
178      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmdDayAdd_Click (18)

179     
180      Private Sub cmdDayAdd_Click() 
181       '120623
182       ' CALLS
183          ' Add_SetCalendar
184          ' Update_ExternalForms
185     
186          Dim nDate As Date 
187          nDate = Me.txtCalendarDate 
188          Add_SetCalendar nDate, 0, 0, 1 
189          Update_ExternalForms nDate 
190     
191      Proc_Exit: 
192         On Error Resume Next 
193         Exit Sub 
194      Proc_Err: 
195         Resume Proc_Exit 
196      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmdDaySub_Click (19)

197     
198      Private Sub cmdDaySub_Click() 
199       '120623
200       ' CALLS
201          ' Add_SetCalendar
202          ' Update_ExternalForms
203     
204          Dim nDate As Date 
205          nDate = Me.txtCalendarDate 
206          Add_SetCalendar nDate, 0, 0, -1 
207          Update_ExternalForms nDate 
208     
209      Proc_Exit: 
210         On Error Resume Next 
211         Exit Sub 
212      Proc_Err: 
213         Resume Proc_Exit 
214      End Sub 
215       '---------------------------------------------------------------------
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd11_Click (4)

216     
217      Private Sub cmd11_Click() 
218          DayClick 
219      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd12_Click (4)

220     
221      Private Sub cmd12_Click() 
222          DayClick 
223      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd13_Click (4)

224     
225      Private Sub cmd13_Click() 
226          DayClick 
227      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd14_Click (4)

228     
229      Private Sub cmd14_Click() 
230          DayClick 
231      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd15_Click (4)

232     
233      Private Sub cmd15_Click() 
234          DayClick 
235      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd16_Click (4)

236     
237      Private Sub cmd16_Click() 
238          DayClick 
239      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd17_Click (4)

240     
241      Private Sub cmd17_Click() 
242          DayClick 
243      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd21_Click (4)

244     
245      Private Sub cmd21_Click() 
246          DayClick 
247      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd22_Click (4)

248     
249      Private Sub cmd22_Click() 
250          DayClick 
251      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd23_Click (4)

252     
253      Private Sub cmd23_Click() 
254          DayClick 
255      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd24_Click (4)

256     
257      Private Sub cmd24_Click() 
258          DayClick 
259      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd25_Click (4)

260     
261      Private Sub cmd25_Click() 
262          DayClick 
263      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd26_Click (4)

264     
265      Private Sub cmd26_Click() 
266          DayClick 
267      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd27_Click (4)

268     
269      Private Sub cmd27_Click() 
270          DayClick 
271      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd31_Click (4)

272     
273      Private Sub cmd31_Click() 
274          DayClick 
275      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd32_Click (4)

276     
277      Private Sub cmd32_Click() 
278          DayClick 
279      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd33_Click (4)

280     
281      Private Sub cmd33_Click() 
282          DayClick 
283      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd34_Click (4)

284     
285      Private Sub cmd34_Click() 
286          DayClick 
287      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd35_Click (4)

288     
289      Private Sub cmd35_Click() 
290          DayClick 
291      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd36_Click (4)

292     
293      Private Sub cmd36_Click() 
294          DayClick 
295      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd37_Click (4)

296     
297      Private Sub cmd37_Click() 
298          DayClick 
299      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd41_Click (4)

300     
301      Private Sub cmd41_Click() 
302          DayClick 
303      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd42_Click (4)

304     
305      Private Sub cmd42_Click() 
306          DayClick 
307      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd43_Click (4)

308     
309      Private Sub cmd43_Click() 
310          DayClick 
311      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd44_Click (4)

312     
313      Private Sub cmd44_Click() 
314          DayClick 
315      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd45_Click (4)

316     
317      Private Sub cmd45_Click() 
318          DayClick 
319      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd46_Click (4)

320     
321      Private Sub cmd46_Click() 
322          DayClick 
323      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd47_Click (4)

324     
325      Private Sub cmd47_Click() 
326          DayClick 
327      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd51_Click (4)

328     
329      Private Sub cmd51_Click() 
330          DayClick 
331      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd52_Click (4)

332     
333      Private Sub cmd52_Click() 
334          DayClick 
335      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd53_Click (4)

336     
337      Private Sub cmd53_Click() 
338          DayClick 
339      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd54_Click (4)

340     
341      Private Sub cmd54_Click() 
342          DayClick 
343      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd55_Click (4)

344     
345      Private Sub cmd55_Click() 
346          DayClick 
347      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd56_Click (4)

348     
349      Private Sub cmd56_Click() 
350          DayClick 
351      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd57_Click (4)

352     
353      Private Sub cmd57_Click() 
354          DayClick 
355      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd61_Click (4)

356     
357      Private Sub cmd61_Click() 
358          DayClick 
359      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd62_Click (4)

360     
361      Private Sub cmd62_Click() 
362          DayClick 
363      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd63_Click (4)

364     
365      Private Sub cmd63_Click() 
366          DayClick 
367      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd64_Click (4)

368     
369      Private Sub cmd64_Click() 
370          DayClick 
371      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd65_Click (4)

372     
373      Private Sub cmd65_Click() 
374          DayClick 
375      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd66_Click (4)

376     
377      Private Sub cmd66_Click() 
378          DayClick 
379      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmd67_Click (4)

380     
381      Private Sub cmd67_Click() 
382          DayClick 
383      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

Add_SetCalendar (32)

384     
385       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Adjust Date
386     
387       '-------------------------------------------------------------------- Add_SetCalendar
388      Public Sub Add_SetCalendar( _ 
389            pDate As Date _ 
390          , Optional pYearAdd As Integer = 0 _ 
391          , Optional pMonthAdd As Integer = 0 _ 
392          , Optional pDayAdd As Integer = 0 _ 
393          ) 
394       '120623
395     
396         On Error GoTo Proc_Err 
397     
398          If pMonthAdd <> 0 Or pYearAdd <> 0 Or pDayAdd <> 0 Then 
399            pDate = DateSerial(Year(pDate) + pYearAdd, Month(pDate) + pMonthAdd, Day(pDate) + pDayAdd) 
400          End If 
401     
402          Set_Calendar pDate 
403     
404      Proc_Exit: 
405          On Error Resume Next 
406         Exit Sub 
407     
408      Proc_Err: 
409         MsgBox Err.Description, , _ 
410              "ERROR " & Err.Number _ 
411              & "   Add_SetCalendar" 
412     
413         Resume Proc_Exit 
414         Resume 
415      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

Set_Calendar (189)

416     
417       '-------------------------------------- CUSTOMIZE
418       '-------------------------------------------------------------------- Set_Calendar
419      Public Sub Set_Calendar( _ 
420            pDate As Date _ 
421          ) 
422       '---------- CUSTOMIZE Defaults for -- Set_Calendar
423     
424       'Crystal 120512, 13
425       '120623 remove need for Dates table
426     
427           'set calendar to month for pDate
428           'and mark days
429     
430       'PARAMETERS
431          'pDate - optional. if specified and > 1900, calendar will be set to the date
432     
433       ' CALLS
434       '  cal_GetRow4Calendar
435       '  cal_GetCol4Calendar
436       '  Set_DefaultFormat
437       '  Mark_TodayAndDate
438     
439       ' CALLED BY
440          ' Form Load and buttons to change calendar day
441          ' FormName: txtDate_AfterUpdate, FindTheDay, DayAddSub
442     
443         On Error GoTo Proc_Err 
444     
445           '----- dimension variables
446          Dim ctl As Control _ 
447            , db As DAO.Database _ 
448            , rs As DAO.Recordset 
449     
450          Dim nMonth As Integer _ 
451              , nYear As Integer _ 
452              , nFirstCol As Integer _ 
453              , nLastRow As Integer _ 
454              , nLastCol As Integer _ 
455              , iRow As Integer _ 
456              , iCol As Integer _ 
457              , nRowPick As Integer _ 
458              , nColPick As Integer _ 
459              , nRowCur As Integer _ 
460              , nColCur As Integer _ 
461              , sSQL As String _ 
462              , sStr As String _ 
463              , iDay As Integer 
464     
465           '----- set variables
466     
467         nMonth = Month(pDate) 
468         nYear = Year(pDate) 
469     
470         If Year(Date) = nYear And Month(Date) = nMonth Then 
471             'calendar is showing the current month
472            nRowCur = cal_GetRow4Calendar(Date) 
473            nColCur = cal_GetCol4Calendar(Date) 
474         Else 
475             'calendar is not showing the current month
476            nRowCur = 0 
477            nColCur = 0 
478         End If 
479     
480         nRowPick = cal_GetRow4Calendar(pDate) 
481         nColPick = cal_GetCol4Calendar(pDate) 
482     
483         nLastCol = Weekday(DateSerial(nYear, nMonth + 1, 0)) 
484         nLastRow = cal_GetRow4Calendar(DateSerial(nYear, nMonth + 1, 0)) 
485         nFirstCol = Weekday(DateSerial(nYear, nMonth, 1)) 
486     
487          'keep track of picked day so colors can be set back to normal
488          'when the date is changed
489     
490       '   If Me.txtRowPick <> nRowPick Then
491       '      Set_DefaultFormat Me("cmd" & Me.txtRowPick & Me.txtColPick), , False
492       '      Me.txtRowPick = nRowPick
493       '      Me.txtColPick = nColPick
494       '   End If
495       '
496       '   If Me.txtRowCur <> nRowCur Then
497       '      'reset previous current date if is was showing
498       '      If Me.txtRowCur <> 0 And Me.txtColCur <> 0 Then
499       '         Set_DefaultFormat Me("cmd" & Me.txtRowCur & Me.txtColCur), , False
500       '      End If
501       '      Me.txtRowCur = nRowCur
502       '      Me.txtColCur = nColCur
503       '   End If
504     
505         If Me.txtRowPick <> nRowPick Then 
506            If Not IsNull(Me.txtRowPick) Then 
507               Set_DefaultFormat Me("cmd" & Me.txtRowPick & Me.txtColPick), , False 
508            End If 
509            Me.txtRowPick = nRowPick 
510            Me.txtColPick = nColPick 
511         End If 
512     
513         If Me.txtRowCur <> nRowCur Then 
514             'reset previous current date if is was showing
515            If Not IsNull(Me.txtRowCur) Then 
516               If Me.txtRowCur <> 0 And Me.txtColCur <> 0 Then 
517                  Set_DefaultFormat Me("cmd" & Me.txtRowCur & Me.txtColCur), , False 
518               End If 
519            End If 
520            Me.txtRowCur = nRowCur 
521            Me.txtColCur = nColCur 
522         End If 
523     
524         Me.txtCalendarDate = pDate 
525         Me.txtCalendarDate.Tag = "cmd" & nRowPick & nColPick 
526     
527          If nLastRow = 0 Or nLastCol = 0 Then 
528              MsgBox "Error getting last row or column for calendar", , "Aborting" 
529              Exit Sub 
530          End If 
531     
532           'caption for cmdMonth
533          Me.cmdMonth.Caption = Format(pDate, "mmmm") 
534          Me.cmdMonth.Tag = Format(pDate, "m") 
535          Me.cmdYr.Caption = nYear 
536     
537           'hide unused squares in the first row
538          For iCol = 1 To (nFirstCol - 1) 
539            Set ctl = Me("cmd1" & iCol) 
540            With ctl 
541               .Visible = False 
542            End With 
543          Next iCol 
544     
545          '-----------------------------------------------------------------------
546          ' reset visible cells to default format
547     
548         iDay = 1 
549     
550         iRow = 1 
551         iCol = 1 
552     
553         For iRow = 1 To 6 
554            For iCol = 1 To 7 
555     
556               Set ctl = Me("cmd" & iRow & iCol) 
557     
558               Select Case iRow 
559               Case 1 
560                  If iCol < nFirstCol Then 
561                     ctl.Visible = False 
562                     GoTo NextDay 
563                  Else 
564                     Set_DefaultFormat ctl, iDay, iCol, False 
565                     iDay = iDay + 1 
566                  End If 
567     
568               Case nLastRow 
569                  If iCol <= nLastCol Then 
570                     Set_DefaultFormat ctl, iDay, iCol, False 
571                     iDay = iDay + 1 
572                  Else 
573                     ctl.Visible = False 
574                     GoTo NextDay 
575                  End If 
576     
577               Case Is < nLastRow 
578                     Set_DefaultFormat ctl, iDay, iCol, False 
579                     iDay = iDay + 1 
580     
581               Case Is > nLastRow 
582                  ctl.Visible = False 
583                  GoTo NextDay 
584     
585               End Select 
586      NextDay: 
587            Next iCol 
588         Next iRow 
589     
590         Call Mark_TodayAndDate(pDate) 
591     
592      Proc_Exit: 
593          On Error Resume Next 
594          Set ctl = Nothing 
595         Exit Sub 
596     
597      Proc_Err: 
598         MsgBox Err.Description, , _ 
599              "ERROR " & Err.Number _ 
600              & "   Set_Calendar" 
601     
602         Resume Proc_Exit 
603         Resume 
604      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

Set_DefaultFormat (26)

605     
606      Private Sub Set_DefaultFormat(pCtl As Control _ 
607         , Optional iDay As Integer = 0 _ 
608         , Optional iCol As Integer = 0 _ 
609         , Optional BoldWkend As Boolean = True) 
610       'Private Sub Set_DefaultFormat(pCtl As Control, Optional iDay As Integer = 0)
611       '120623, 120627, 120701
612         Dim booBold As Boolean 
613     
614         With pCtl 
615            .Visible = True 
616            .FontSize = 10 
617            .ForeColor = 0   'black 
618            booBold = True 
619            If iDay > 0 Then 
620               .Caption = iDay & Chr(160) & Chr(160) & Chr(160) & Chr(160) & vbCrLf & Chr(160) 
621               If Not BoldWkend _ 
622                     And (iCol = 1 Or iCol = 7) Then 
623                  booBold = False 
624               End If 
625            End If 
626            .BorderColor = Me.Detail.BackColor 
627            .BorderWidth = 2 
628            .FontBold = booBold 
629         End With 
630      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

Mark_TodayAndDate (68)

631     
632      Private Sub Mark_TodayAndDate(pDate As Date) 
633       '120623, 120627, 120701
634         Dim nRow As Integer _ 
635            , nCol As Integer _ 
636            , sCtlName As String 
637     
638          'set format back for last current date
639     
640          ' clear current date
641         If Not Format(pDate, "yyyymm") = Format(Date, "yyyymm") Then 
642             'calendar is not showing current month
643            If Nz(Me.txtRowCur, 0) <> 0 And Nz(Me.txtColCur, 0) <> 0 Then 
644               sCtlName = "cmd" & Me.txtRowCur & Me.txtColCur 
645               Set_DefaultFormat Me(sCtlName) 
646            End If 
647            GoTo MarkScheduleDate 
648         Else 
649            nRow = cal_GetRow4Calendar(Date) 
650            nCol = cal_GetCol4Calendar(Date) 
651            sCtlName = "cmd" & nRow & nCol 
652            With Me(sCtlName) 
653               .ForeColor = RGB(255, 0, 0)   'red 
654               .BorderWidth = 0   'hairline 
655               .BorderColor = RGB(255, 0, 0) 
656            End With 
657         End If 
658     
659       '   ' clear pick date date
660       '   If Not Format(pDate, "yyyymm") = Format(Me.txtCalendarDate, "yyyymm") Then
661       '      'pick date is different
662       '      If Nz(Me.txtRowPick, 0) <> 0 And Nz(Me.txtColPick, 0) <> 0 Then
663       '         sCtlName = "cmd" & Me.txtRowPick & Me.txtColPick
664       '         Set_DefaultFormat Me(sCtlName)
665       '      End If
666       '   End If
667     
668     
669         If pDate = Date Then 
670             'make control purple if Pick = Today
671            With Me(sCtlName) 
672               .ForeColor = RGB(150, 0, 250)   'purple 
673               .BorderWidth = 0   'hairline 
674               .BorderColor = RGB(150, 0, 250) 
675            End With 
676            GoTo Proc_Exit 
677         End If 
678     
679      MarkScheduleDate: 
680          'mark schedule date
681         nRow = cal_GetRow4Calendar(pDate) 
682         nCol = cal_GetCol4Calendar(pDate) 
683         sCtlName = "cmd" & nRow & nCol 
684     
685         With Me(sCtlName) 
686            .ForeColor = RGB(0, 0, 255)   'blue 
687               .BorderColor = RGB(0, 0, 255) 
688               .BorderWidth = 0   'hairline 
689       '      If IsSubform(Me) Then '120623
690       '         Me.Parent.Label_DayDesc.Caption = .ControlTipText
691       '      End If
692         End With 
693     
694     
695      Proc_Exit: 
696         On Error Resume Next 
697         Exit Sub 
698      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

ShowDatePickerMessage (13)

699     
700      Private Sub ShowDatePickerMessage() 
701       '120701
702         MsgBox "To use this popup calendar in a form," _ 
703            & " assign the DOUBLE-CLICK event " _ 
704            & " of date control on a form to" & vbCrLf & vbCrLf _ 
705            & "   DoCmd.OpenForm ""f_PopupCalendar""" & vbCrLf & vbCrLf _ 
706            & vbCrLf & vbCrLf _ 
707            & "To use this in another database, " _ 
708            & "import form f_PopupCalendar" _ 
709            , , "Popup Calendar by Crystal" 
710     
711      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cal_GetCardinalNumber (28)

712     
713       '--------------------------------------------- general
714     
715      Function cal_GetCardinalNumber(Optional pNumber) As String 
716       '11-24-08
717          'written by fdcusa (John)
718          'modified by Crystal
719     
720          'returns the string from a number in this form:
721          '1st, 2nd, 3rd, 10th, 301st, 1000th
722     
723         If IsMissing(pNumber) Or IsNull(pNumber) Or (Not IsNumeric(pNumber)) Then Exit Function 
724     
725         Dim strEnding As String 
726     
727          'convert to string, get the last character
728          'then turn back into an integer for comparison
729     
730          Select Case CInt(Right(CStr(pNumber), 1)) 
731              Case 1: strEnding = "st" 
732              Case 2: strEnding = "nd" 
733              Case 3: strEnding = "rd" 
734              Case Else: strEnding = "th" 
735          End Select 
736     
737          cal_GetCardinalNumber = CStr(pNumber) & strEnding 
738     
739      End Function 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cal_GetCol4Calendar (5)

740     
741      Public Function cal_GetCol4Calendar(pDate As Date) As Integer 
742         cal_GetCol4Calendar = 0 
743         cal_GetCol4Calendar = Weekday(pDate, vbSunday) 
744      End Function 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cal_GetRow4Calendar (38)

745     
746      Public Function cal_GetRow4Calendar(pDate As Date) As Integer 
747       '120623 Crystal
748     
749         On Error GoTo Proc_Err 
750         cal_GetRow4Calendar = 0 
751     
752         Dim nCol_First As Integer _ 
753            , nDate_First As Date _ 
754            , nRow As Integer _ 
755            , nCol As Integer _ 
756            , nNumDaysRow1 As Integer 
757     
758         nDate_First = DateSerial(Year(pDate), Month(pDate), 1) 
759         nCol_First = Weekday(nDate_First, vbSunday) 
760         nNumDaysRow1 = 7 - nCol_First + 1 
761     
762         nCol = Weekday(pDate, vbSunday) 
763     
764         nRow = (Day(pDate)) \ 7 + 1 
765     
766         If Day(pDate) Mod 7 > nNumDaysRow1 Then nRow = nRow + 1 
767         If Day(pDate) Mod 7 = 0 And nCol >= nCol_First Then nRow = nRow - 1 
768     
769         cal_GetRow4Calendar = nRow 
770     
771      Proc_Exit: 
772         On Error Resume Next 
773         Exit Function 
774     
775      Proc_Err: 
776         MsgBox Err.Description, , _ 
777              "ERROR " & Err.Number _ 
778              & "   cal_GetRow4Calendar" 
779     
780         Resume Proc_Exit 
781         Resume 
782      End Function 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cal_GetDowN4Calendar (26)

783     
784      Public Function cal_GetDowN4Calendar(pDate As Date) As Integer 
785       '120623 Crystal
786     
787         On Error GoTo Proc_Err 
788         cal_GetDowN4Calendar = 0 
789     
790         Dim nDowN As Integer 
791     
792         nDowN = (Day(pDate)) \ 7 + 1 
793         If Day(pDate) Mod 7 = 0 Then nDowN = nDowN - 1 
794     
795         cal_GetDowN4Calendar = nDowN 
796     
797      Proc_Exit: 
798         On Error Resume Next 
799         Exit Function 
800     
801      Proc_Err: 
802         MsgBox Err.Description, , _ 
803              "ERROR " & Err.Number _ 
804              & "   cal_GetDowN4Calendar" 
805     
806         Resume Proc_Exit 
807         Resume 
808      End Function 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cal_IsSubform (17)

809     
810     
811       '~~~~~~~~~~~~~~~~~~~~~~~~~~ IsSubform
812      Private Function cal_IsSubform(pForm As Form) As Boolean 
813       '8-29-07
814          'return:
815          ' TRUE is specified form reference is being used as a subform
816          ' FALSE if it is not
817     
818          'example useage: in code before parent controls are used
819          'If IsSubform(Me) then ...
820     
821          On Error Resume Next 
822          cal_IsSubform = _ 
823             Not IsError(Len(pForm.Parent.Name) > 0) 
824     
825      End Function 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cal_ShowHideControlsTag (34)

826     
827       '~~~~~~~~~~~~~~~~~~~~~~~~~~ cal_ShowHideControlsTag
828      Private Function cal_ShowHideControlsTag( _ 
829         pBoo As Boolean _ 
830         , pTag As String) 
831     
832     
833         On Error GoTo Proc_Err 
834     
835         Dim ctl As Control 
836     
837         On Error Resume Next 
838         For Each ctl In Me.Detail.Controls 
839            If InStr(ctl.Tag, pTag) > 0 Then 
840               ctl.Visible = pBoo 
841            End If 
842         Next ctl 
843     
844      Proc_Exit: 
845         If Not ctl Is Nothing Then Set ctl = Nothing 
846         Exit Function 
847     
848      Proc_Err: 
849         MsgBox Err.Description, , _ 
850              "ERROR " & Err.Number _ 
851              & "   ShowHideControlsTag" 
852     
853          'press F8 to step through code
854          'comment next line when debugged
855         Stop: Resume 
856     
857         Resume Proc_Exit 
858     
859      End Function 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cal_GetRoman (51)

860     
861      Private Function cal_GetRoman(ByVal pNumber As Integer) As String 
862       '120627
863       'modified from Microsoft Support
864       ' OFF97: VBA Procedure to Convert Numbers to Roman Numerals
865       ' http://support.microsoft.com/kb/184657
866     
867         On Error GoTo Proc_Err 
868     
869         Const ROMAN = "IVXLCDM"   'I=1,V=5, X=10, L=100, C=1,000, D=500   M=1,000 
870     
871         Dim i As Integer, Digit As Integer, sStr As String 
872     
873         i = 1 
874         sStr = "" 
875         Do While pNumber > 0 
876            Digit = pNumber Mod 10 
877            pNumber = pNumber \ 10 
878            Select Case Digit 
879               Case 1 
880                 sStr = Mid(ROMAN, i, 1) & sStr 
881               Case 2 
882                 sStr = Mid(ROMAN, i, 1) & Mid(ROMAN, i, 1) & sStr 
883               Case 3 
884                 sStr = Mid(ROMAN, i, 1) & Mid(ROMAN, i, 1) & _ 
885                        Mid(ROMAN, i, 1) & sStr 
886               Case 4 
887                 sStr = Mid(ROMAN, i, 2) & sStr 
888               Case 5 
889                 sStr = Mid(ROMAN, i + 1, 1) & sStr 
890               Case 6 
891                 sStr = Mid(ROMAN, i + 1, 1) & Mid(ROMAN, i, 1) & sStr 
892               Case 7 
893                 sStr = Mid(ROMAN, i + 1, 1) & Mid(ROMAN, i, 1) & _ 
894                        Mid(ROMAN, i, 1) & sStr 
895               Case 8 
896                 sStr = Mid(ROMAN, i + 1, 1) & Mid(ROMAN, i, 1) & _ 
897                        Mid(ROMAN, i, 1) & Mid(ROMAN, i, 1) & sStr 
898               Case 9 
899                 sStr = Mid(ROMAN, i, 1) & Mid(ROMAN, i + 2, 1) & sStr 
900            End Select 
901            i = i + 2 
902         Loop 
903         cal_GetRoman = sStr 
904     
905      Proc_Exit: 
906         Exit Function 
907      Proc_Err: 
908         Resume Proc_Exit 
909     
910      End Function 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

Label_strive4peace_Click (8)

911     
912     
913      Private Sub Label_strive4peace_Click() 
914       '120627
915         On Error Resume Next 
916         Application.FollowHyperlink _ 
917            "mailto: strive4peace2012@yahoo.com?subject=Calendar sub comment " 
918      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

txtCalendarDate_BeforeUpdate (18)

919     
920     
921     
922      Private Sub txtCalendarDate_BeforeUpdate(Cancel As Integer) 
923       '120701
924         On Error Resume Next 
925         If IsNull(Me.ActiveControl) Then 
926            Me.ActiveControl.Undo 
927            Cancel = True 
928            Exit Sub 
929         End If 
930         If Not IsDate(Me.ActiveControl) Then 
931            MsgBox Me.ActiveControl & " is not a valid date", , "Cannot change" 
932            Me.ActiveControl.Undo 
933            Cancel = True 
934            Exit Sub 
935         End If 
936      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmdMonthAdd_Click (23)

937     
938     
939     
940     
941     
942      Private Sub cmdMonthAdd_Click() 
943       '120512, 120622
944       ' CALLS
945          ' Add_SetCalendar
946          ' Update_ExternalForms
947     
948          On Error GoTo Proc_Err 
949          Dim nDate As Date 
950          nDate = Me.txtCalendarDate 
951          Add_SetCalendar nDate, 0, 1, 0 
952          Update_ExternalForms nDate 
953     
954      Proc_Exit: 
955         On Error Resume Next 
956         Exit Sub 
957      Proc_Err: 
958         Resume Proc_Exit 
959      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmdMonthSub_Click (16)

960     
961      Private Sub cmdMonthSub_Click() 
962       '120512 Crystal, 120622
963           'move calendar back one month
964       '
965       ' CALLS
966          ' Add_SetCalendar
967          ' Update_ExternalForms
968         On Error Resume Next 
969     
970         Dim nDate As Date 
971         nDate = Me.txtCalendarDate 
972         Add_SetCalendar nDate, 0, -1, 0 
973         Update_ExternalForms nDate 
974     
975      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmdYrAdd_Click (20)

976     
977     
978     
979      Private Sub cmdYrAdd_Click() 
980       '120512, 120622
981       ' CALLS
982          ' Add_SetCalendar
983          ' Update_ExternalForms
984     
985          Dim nDate As Date 
986          nDate = Me.txtCalendarDate 
987          Add_SetCalendar nDate, 1, 0, 0 
988          Update_ExternalForms nDate 
989     
990      Proc_Exit: 
991         On Error Resume Next 
992         Exit Sub 
993      Proc_Err: 
994         Resume Proc_Exit 
995      End Sub 
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

cmdYrSub_Click (19)

996     
997      Private Sub cmdYrSub_Click() 
998       '120512, 120622
999       ' CALLS
1,000        ' Add_SetCalendar
1,001        ' Update_ExternalForms
1,002   
1,003        Dim nDate As Date 
1,004        nDate = Me.txtCalendarDate 
1,005        Add_SetCalendar nDate, -1, 0, 0 
1,006        Update_ExternalForms nDate 
1,007   
1,008    Proc_Exit: 
1,009       On Error Resume Next 
1,010       Exit Sub 
1,011    Proc_Err: 
1,012       Resume Proc_Exit 
1,013    End Sub 
1,014   
      Goto Top       Goto Form_f_Calendar_sub       Goto Index

Form_f_CalendarSub_test (85)

PROCEDURES       Goto Top       Goto Form_f_CalendarSub_test       Goto Forms       Goto Index
  1. Date1_AfterUpdate (6)
  2. Date2_AfterUpdate (6)
  3. Date3_AfterUpdate (8)
  4. Declaration Lines (2)
  5. Form_Load (52)
  6. Label_emailCrystal_Click (6)
  7. Label_website_Click (5)

Declaration Lines (2)

1        Option Compare Database 
2        Option Explicit 
      Goto Top       Goto Form_f_CalendarSub_test       Goto Index

Form_Load (52)

3         '============================================================ LICENSE NOTICE -- must not be modified
4         ' This software is licensed to you under CC BY-NC-SA 3.0
5         '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
6         ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
7         '
8         ' You are free to:
9         '    Share  copy and redistribute the material in any medium or format
10        '    Adapt  remix, transform, and build upon the material
11        ' The licensor cannot revoke these freedoms as long as you follow these terms:
12        '    Attribution  You must give appropriate credit, provide a link to the license,
13        '                   and indicate if changes were made.
14        '                   You may do so in any reasonable manner,
15        '                   but not in any way that suggests the licensor endorses you or your use.
16        '    NonCommercial  You may not use the material for commercial purposes.
17        '    ShareAlike  If you remix, transform, or build upon the material,
18        '                 you must distribute your contributions under the same license as the original.
19        '
20        ' many procedures and module names contain author or controbitor names that must be left intact
21        ' if you make changes, add your name, date, and descriptive information to the comments
22        '
23        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629
24        ' ~ Crystal
25        '              * have an awesome day :)
26        '                                                   www.AccessMVP.com/strive4peace
27        ' END LICENSE NOTICE
28        '============================================================
29       Private Sub Form_Load() 
30        '130119 Crystal
31          On Error GoTo Proc_Err 
32          Dim i As Integer 
33          For i = 1 To 3 
34             With Me("Calendar" & i).Form 
35                If Not IsNull(Me("Date" & i)) Then 
36                   .Set_Calendar Me("Date" & i) 
37                Else 
38                   .Set_Calendar Date 
39                End If 
40                .Label_LinkControlname.Caption = "Date" & i 
41             End With 
42          Next i 
43       Proc_Exit: 
44          On Error Resume Next 
45          Exit Sub 
46      
47       Proc_Err: 
48          MsgBox Err.Description, , _ 
49               "ERROR " & Err.Number _ 
50               & "   Form_Load : " & Me.Name 
51      
52          Resume Proc_Exit 
53          Resume 
54       End Sub 
      Goto Top       Goto Form_f_CalendarSub_test       Goto Index

Label_emailCrystal_Click (6)

55      
56       Private Sub Label_emailCrystal_Click() 
57          On Error Resume Next 
58          Application.FollowHyperlink _ 
59             "mailto: strive4peace2012@yahoo.com?subject=Calendar subform comment " 
60       End Sub 
      Goto Top       Goto Form_f_CalendarSub_test       Goto Index

Label_website_Click (5)

61      
62       Private Sub Label_website_Click() 
63          On Error Resume Next 
64          Application.FollowHyperlink "http://www.AccessMVP.com/strive4peace" 
65       End Sub 
      Goto Top       Goto Form_f_CalendarSub_test       Goto Index

Date1_AfterUpdate (6)

66      
67       Private Sub Date1_AfterUpdate() 
68        '130119
69          If IsNull(Me.ActiveControl) Then Exit Sub 
70          Me.Calendar1.Form.Set_Calendar Me.Date1 
71       End Sub 
      Goto Top       Goto Form_f_CalendarSub_test       Goto Index

Date2_AfterUpdate (6)

72      
73       Private Sub Date2_AfterUpdate() 
74        '130119
75          If IsNull(Me.ActiveControl) Then Exit Sub 
76          Me.Calendar2.Form.Set_Calendar Me.Date2 
77       End Sub 
      Goto Top       Goto Form_f_CalendarSub_test       Goto Index

Date3_AfterUpdate (8)

78      
79      
80       Private Sub Date3_AfterUpdate() 
81        '130119
82          If IsNull(Me.ActiveControl) Then Exit Sub 
83          Me.Calendar3.Form.Set_Calendar Me.Date3 
84       End Sub 
85      
      Goto Top       Goto Form_f_CalendarSub_test       Goto Index

Form_f_CUSTOMER (95)

PROCEDURES       Goto Top       Goto Form_f_CUSTOMER       Goto Forms       Goto Index
  1. cmd_Add_Click (8)
  2. cmd_Del_Click (5)
  3. Declaration Lines (28)
  4. dt1Bus_DblClick (4)
  5. dtPurch_DblClick (6)
  6. fnd_Customer_AfterUpdate (6)
  7. fnd_CustomerContact_AfterUpdate (6)
  8. fnd_Project_AfterUpdate (6)
  9. Form_BeforeUpdate (5)
  10. Form_Current (21)

Declaration Lines (28)

1        Option Compare Database 
2        Option Explicit 
3         '============================================================ LICENSE NOTICE -- must not be modified
4         ' This software is licensed to you under CC BY-NC-SA 3.0
5         '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
6         ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
7         '
8         ' You are free to:
9         '    Share  copy and redistribute the material in any medium or format
10        '    Adapt  remix, transform, and build upon the material
11        ' The licensor cannot revoke these freedoms as long as you follow these terms:
12        '    Attribution  You must give appropriate credit, provide a link to the license,
13        '                   and indicate if changes were made.
14        '                   You may do so in any reasonable manner,
15        '                   but not in any way that suggests the licensor endorses you or your use.
16        '    NonCommercial  You may not use the material for commercial purposes.
17        '    ShareAlike  If you remix, transform, or build upon the material,
18        '                 you must distribute your contributions under the same license as the original.
19        '
20        ' many procedures and module names contain author or controbitor names that must be left intact
21        ' if you make changes, add your name, date, and descriptive information to the comments
22        '
23        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629
24        ' ~ Crystal
25        '              * have an awesome day :)
26        '                                                   www.AccessMVP.com/strive4peace
27        ' END LICENSE NOTICE
28        '============================================================
      Goto Top       Goto Form_f_CUSTOMER       Goto Index

cmd_Add_Click (8)

29      
30      
31       Private Sub cmd_Add_Click() 
32        '131002
33          Call RecordNew(Me, "CID") 
34          DoEvents 
35          Me.CID.Dropdown 
36       End Sub 
      Goto Top       Goto Form_f_CUSTOMER       Goto Index

cmd_Del_Click (5)

37      
38       Private Sub cmd_Del_Click() 
39        '131002
40          MsgBox "Under construction" 
41       End Sub 
      Goto Top       Goto Form_f_CUSTOMER       Goto Index

dtPurch_DblClick (6)

42      
43       Private Sub dtPurch_DblClick(Cancel As Integer) 
44        '131002
45           'popup calendar for date purchased
46           DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog 
47       End Sub 
      Goto Top       Goto Form_f_CUSTOMER       Goto Index

dt1Bus_DblClick (4)

48      
49       Private Sub dt1Bus_DblClick(Cancel As Integer) 
50           DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog 
51       End Sub 
      Goto Top       Goto Form_f_CUSTOMER       Goto Index

fnd_Customer_AfterUpdate (6)

52      
53       Private Sub fnd_Customer_AfterUpdate() 
54        '131002
55           'find record by customer
56          Call FindRecordN(Me, "CustomerID", "CustRate") 
57       End Sub 
      Goto Top       Goto Form_f_CUSTOMER       Goto Index

fnd_CustomerContact_AfterUpdate (6)

58      
59       Private Sub fnd_CustomerContact_AfterUpdate() 
60        '131002
61           'find record by customer contact
62          Call FindRecordN(Me, "CustomerID", "CustRate") 
63       End Sub 
      Goto Top       Goto Form_f_CUSTOMER       Goto Index

fnd_Project_AfterUpdate (6)

64      
65       Private Sub fnd_Project_AfterUpdate() 
66        '131002
67           'find record by project name
68          Call FindRecordN(Me, "CustomerID", "CustRate") 
69       End Sub 
      Goto Top       Goto Form_f_CUSTOMER       Goto Index

Form_BeforeUpdate (5)

70      
71       Private Sub Form_BeforeUpdate(Cancel As Integer) 
72        '131002
73          Call FormBeforeUpdate(Me) 
74       End Sub 
      Goto Top       Goto Form_f_CUSTOMER       Goto Index

Form_Current (21)

75      
76       Private Sub Form_Current() 
77        '131002
78          Dim sSQL As String 
79      
80          With Me.lst_CompanyContacts 
81             sSQL = Replace(.Tag, "ORDER BY" _ 
82                      , " WHERE  c.[cid_]=" & Nz(Me.CID, -99) & " ORDER BY ") 
83             If .RowSource <> sSQL Then 
84                .RowSource = sSQL 
85                .Requery 
86             End If 
87          End With   'Me.lst_CompanyContacts 
88      
89           'me.cid
90        '      If Me.NewRecord Then  'can't add records here -- filter CID for NOT ALREADY a CUSTOMER
91        '         sSQL = Replace(.Tag, "ORDER BY" _
92        '            , "WHERE (((DLookUp(""CustomerID"",""Customers"",""CID="" & [c].[cid])) Is Null)) ORDER BY")
93        '      End If
94      
95       End Sub 
      Goto Top       Goto Form_f_CUSTOMER       Goto Index

Form_f_DataDICTIONARY_DisplayControl (507)

PROCEDURES       Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Forms       Goto Index
  1. chkExclusive_Click (5)
  2. chkHid_Click (5)
  3. chkLinked_Click (5)
  4. chkODBC_Click (5)
  5. chkSavePW_Click (5)
  6. chkSys_AfterUpdate (4)
  7. cmd_Checkbox_Click (4)
  8. cmd_Design_Click (10)
  9. cmd_Open_Click (8)
  10. cmd_Textbox_Click (4)
  11. cmdRename_Click (62)
  12. Declaration Lines (36)
  13. fltrTablename_AfterUpdate (5)
  14. Form_Load (24)
  15. Form_Open (8)
  16. Label_By_Click (6)
  17. lstFieldname_AfterUpdate (61)
  18. MakeTheChanges (37)
  19. RowSource_Fieldlist (116)
  20. RowSource_Tablename (76)
  21. RowSource_TablenameForm (6)
  22. Tablename_AfterUpdate (5)
  23. Tablename_MouseUp (10)

Declaration Lines (36)

1        Option Compare Database 
2        Option Explicit 
3         '=============================================
4         '============================================================ LICENSE NOTICE -- must not be modified
5         ' This software is licensed to you under CC BY-NC-SA 3.0
6         '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
7         ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
8         '
9         ' You are free to:
10        '    Share  copy and redistribute the material in any medium or format
11        '    Adapt  remix, transform, and build upon the material
12        ' The licensor cannot revoke these freedoms as long as you follow these terms:
13        '    Attribution  You must give appropriate credit, provide a link to the license,
14        '                   and indicate if changes were made.
15        '                   You may do so in any reasonable manner,
16        '                   but not in any way that suggests the licensor endorses you or your use.
17        '    NonCommercial  You may not use the material for commercial purposes.
18        '    ShareAlike  If you remix, transform, or build upon the material,
19        '                 you must distribute your contributions under the same license as the original.
20        '
21        ' many procedures and module names contain author or controbitor names that must be left intact
22        ' if you make changes, add your name, date, and descriptive information to the comments
23        '
24        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629
25        ' ~ Crystal
26        '              * have an awesome day :)
27        '                                                   www.AccessMVP.com/strive4peace
28        ' END LICENSE NOTICE
29        '============================================================'=============================================
30        '  CALLS
31        '     dd_SetDisplayControlCheckbox
32        '     dd_SetDisplayControlTextbox
33        '     dd_GetPropertyValue
34        '     dd_GetDataType
35        '     dd_GetControlType
36        '     dd_CanGet_ObjectProperty (dd_CanGet_PropertyValue)
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

Form_Open (8)

37      
38       Private Sub Form_Open(Cancel As Integer) 
39        '120426 Crystal
40          RowSource_Tablename 
41          With Me.lstFieldname 
42             .RowSource = "Pick Table" 
43          End With 
44       End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

Form_Load (24)

45      
46       Private Sub Form_Load() 
47        '120426 Crystal
48           'CALL
49           '  RowSource_Tablename
50      
51          Me.SumSize = 0 
52          Me.Label_CheckUnicodeCompression.Visible = False 
53          Me.cmd_Textbox.Enabled = False 
54          Me.cmd_Checkbox.Enabled = False 
55      
56          Me.chkSys = False 
57          Me.chkHid = False 
58          Me.chkODBC = False 
59          Me.chkLinked = False 
60          Me.chkExclusive = False 
61          Me.chkSavePW = False 
62          Me.fltrTablename = Null 
63          Me.chk_CorrectName = True 
64      
65        '   With Me.Tablename
66        '      .RowSource = .Tag
67        '   End With
68       End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

fltrTablename_AfterUpdate (5)

69      
70       Private Sub fltrTablename_AfterUpdate() 
71        '130425
72          RowSource_TablenameForm 
73       End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

chkSys_AfterUpdate (4)

74      
75       Private Sub chkSys_AfterUpdate() 
76          RowSource_TablenameForm 
77       End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

chkExclusive_Click (5)

78      
79       Private Sub chkExclusive_Click() 
80        '130426 Crystal
81          RowSource_TablenameForm 
82       End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

chkHid_Click (5)

83      
84       Private Sub chkHid_Click() 
85        '130426 Crystal
86          RowSource_TablenameForm 
87       End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

chkLinked_Click (5)

88      
89       Private Sub chkLinked_Click() 
90        '130426 Crystal
91          RowSource_TablenameForm 
92       End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

chkODBC_Click (5)

93      
94       Private Sub chkODBC_Click() 
95        '130426 Crystal
96          RowSource_TablenameForm 
97       End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

chkSavePW_Click (5)

98      
99       Private Sub chkSavePW_Click() 
100       '130426 Crystal
101         RowSource_TablenameForm 
102      End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

RowSource_TablenameForm (6)

103     
104      Private Sub RowSource_TablenameForm() 
105       '130426 Crystal
106         RowSource_Tablename Me.fltrTablename, Me.chkSys, Me.chkHid _ 
107                      ', Me.chkODBC, Me.chkLinked, Me.chkExclusive, Me.chkSavePW
108      End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

RowSource_Tablename (76)

109     
110     
111      Private Sub RowSource_Tablename( _ 
112         Optional varFilterOnName As Variant _ 
113         , Optional booSys As Boolean = False _ 
114         , Optional booHid As Boolean = False _ 
115         , Optional booODBC As Boolean = True _ 
116         , Optional booLinked As Boolean = True _ 
117         , Optional booExclusive As Boolean = True _ 
118         , Optional booSavePW As Boolean = True _ 
119         , Optional booReset As Boolean = False _ 
120         ) 
121       '120426 Crystal
122         Dim sSQL As String _ 
123            , varWhere As Variant 
124     
125         sSQL = "SELECT MSysObjects.Name" _ 
126            & ", MSysObjects.DateUpdate AS Modified " _ 
127            & ", GetTableFlags([MSysObjects].[Flags]) AS Flagz" _ 
128            & " FROM MSysObjects" _ 
129     
130         varWhere = "(MSysObjects.Type = 1)"   'FUTURE: this needs to be conditional 
131     
132         If Not booSys Then   'assumption is NOT to show system objects 
133            varWhere = (varWhere + " AND ") & "Not ([MSysObjects].[Flags] And -2147483646) " 
134         End If 
135     
136         If booHid Then   'default is to show everything regardless of whether or not it is hidden 
137            varWhere = (varWhere + " AND ") & "([MSysObjects].[Flags] And 1) " 
138         End If 
139     
140          'different Type needs to be set to implement these
141     
142       '   If booODBC Then
143       '      varWhere = (varWhere + " AND ") & "([MSysObjects].[Flags] And 536870912) "
144       '   End If
145       '   If booLinked Then
146       '      varWhere = (varWhere + " AND ") & "([MSysObjects].[Flags] And 1073741824) "
147       '   End If
148       '
149       '   If booExclusive Then
150       '      varWhere = (varWhere + " AND ") & "([MSysObjects].[Flags] And 65536) "
151       '   End If
152       '   If booSavePW Then
153       '      varWhere = (varWhere + " AND ") & "([MSysObjects].[Flags] And 131072) "
154       '   End If
155     
156         If Not IsNull(Me.fltrTablename) Then 
157            varWhere = varWhere & " AND (MSysObjects.Name Like ""*" & Me.fltrTablename & "*"")" 
158         End If 
159     
160         If Not IsNull(varWhere) Then 
161            sSQL = sSQL & " WHERE " & varWhere 
162         End If 
163     
164         sSQL = sSQL & " ORDER BY MSysObjects.Name;" 
165     
166       'Debug.Print sSQL
167     
168         With Me.Tablename 
169            .RowSource = sSQL 
170            If booReset Then 
171               .Requery 
172               If IsNull(.Column(0)) Then 
173                  .Value = Null 
174                  Me.lstFieldname.RowSource = "Pick Table" 
175                  Me.lstFieldname.Requery 
176                  Me.SumSize = 0 
177                  Me.Label_CheckUnicodeCompression.Visible = False 
178               End If 
179            End If 
180            .SetFocus 
181            .Dropdown 
182         End With 
183     
184      End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

Tablename_AfterUpdate (5)

185     
186      Private Sub Tablename_AfterUpdate() 
187       ' 130427
188         RowSource_Fieldlist 
189      End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

RowSource_Fieldlist (116)

190     
191      Private Sub RowSource_Fieldlist() 
192       '130425, 26, 130427
193     
194          'CALLS
195          '  dd_GetPropertyValue
196          '  dd_GetDataType
197          '  dd_GetControlType
198          '  dd_CanGet_ObjectProperty (dd_CanGet_PropertyValue)
199     
200         On Error GoTo Proc_Err 
201         Dim sSQL As String _ 
202            , sRowSource As String _ 
203            , bytDisplayControl As Byte _ 
204            , bBoo As Boolean _ 
205            , bCheckUnicode As Boolean _ 
206            , bHasIntegerNotCheckbox As Boolean _ 
207            , bHasComboList As Boolean _ 
208            , sTablename As String _ 
209            , sFieldname As String _ 
210            , nSumSize As Long _ 
211            , sUni As String _ 
212            , iMult As Integer 
213     
214         Dim varValue As Variant 
215     
216         nSumSize = 0 
217         sRowSource = "" 
218         bCheckUnicode = False 
219         bHasComboList = False 
220         bHasIntegerNotCheckbox = False 
221     
222         Dim db As DAO.Database _ 
223            , tdf As DAO.TableDef _ 
224            , fld As DAO.Field 
225     
226         If IsNull(Me.Tablename) Then GoTo Proc_WriteResults 
227     
228         Set db = CurrentDb 
229         sTablename = Me.Tablename 
230         Set tdf = db.TableDefs(sTablename) 
231     
232         For Each fld In tdf.Fields 
233            iMult = 1 
234            sUni = "" 
235            With fld 
236               bytDisplayControl = Nz(dd_GetPropertyValue(fld, "DisplayControl"), 0) 
237               If bytDisplayControl = 109 Then   'textbox 
238                  bytDisplayControl = 0 
239               ElseIf bytDisplayControl = 110 Or bytDisplayControl = 111 Then 
240                  bHasComboList = True 
241               End If 
242     
243                '10 = text, 12 = memo
244               If .Type = 10 Or .Type = 12 Then 
245                   '1 = boolean
246                  If dd_CanGet_ObjectProperty(fld, "UnicodeCompression", varValue, 1) Then 
247                     If Not CInt(varValue) = -1 Then   'no unicode compression 
248                        iMult = 2 
249                        sUni = "*" 
250                        bCheckUnicode = True 
251                     End If 
252                  End If 
253               ElseIf .Type = 3 And bytDisplayControl <> 106 Then 
254                   'integer that is not already a checkbox
255                  bHasIntegerNotCheckbox = True 
256               End If 
257     
258               sRowSource = sRowSource _ 
259                              & .Name & ";" _ 
260                              & dd_GetDataType(.Type, True) & ";" _ 
261                              & .Size & sUni & ";" _ 
262                              & dd_GetControlType(bytDisplayControl) & ";" _ 
263                              & .Type & ";" _ 
264                              & bytDisplayControl & ";" 
265               nSumSize = nSumSize + (.Size * iMult) 
266            End With   'fld 
267         Next fld 
268         If Len(sRowSource) > 0 Then 
269            sRowSource = "Fieldname;DataType;Size;Control;Type;DisplayControl;" & sRowSource 
270         Else 
271            sRowSource = "Pick Table" 
272         End If 
273     
274      Proc_WriteResults: 
275         Me.SumSize = nSumSize 
276         Me.Label_CheckUnicodeCompression.Visible = bCheckUnicode 
277         Me.cmd_Textbox.Enabled = bHasComboList 
278         Me.cmd_Checkbox.Enabled = bHasIntegerNotCheckbox 
279     
280         With Me.lstFieldname 
281            .Value = Null 
282            .RowSource = sRowSource 
283            .Requery 
284         End With 
285     
286      Proc_Exit: 
287         On Error Resume Next 
288         Set fld = Nothing 
289         Set tdf = Nothing 
290         Set db = Nothing 
291         Exit Sub 
292     
293      Proc_Err: 
294         If Err.Number = 3265 Then 
295            MsgBox "Cannot View Table", , "Error" 
296            sRowSource = "Pick Table" 
297            Resume Proc_WriteResults 
298         End If 
299         MsgBox Err.Description, , _ 
300              "ERROR " & Err.Number _ 
301              & "   Tablename_AfterUpdate : " & Me.Name 
302     
303         Resume Proc_Exit 
304         Resume 
305      End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

Tablename_MouseUp (10)

306     
307     
308     
309     
310     
311      Private Sub Tablename_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
312       '130425
313         On Error Resume Next 
314         Me.ActiveControl.Dropdown 
315      End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

cmd_Design_Click (10)

316     
317     
318     
319      Private Sub cmd_Design_Click() 
320       '130425
321         Dim sTablename As String 
322         If IsNull(Me.Tablename) Then Exit Sub 
323         sTablename = Me.Tablename 
324         DoCmd.OpenTable sTablename, acViewDesign 
325      End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

cmd_Open_Click (8)

326     
327      Private Sub cmd_Open_Click() 
328       '130425
329         If IsNull(Me.Tablename) Then Exit Sub 
330         Dim sTablename As String 
331         sTablename = Me.Tablename 
332         DoCmd.OpenTable sTablename, acViewNormal 
333      End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

cmd_Checkbox_Click (4)

334     
335      Private Sub cmd_Checkbox_Click() 
336         MakeTheChanges "dd_SetDisplayControlCheckbox", Me.ActiveControl 
337      End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

cmd_Textbox_Click (4)

338     
339      Private Sub cmd_Textbox_Click() 
340         MakeTheChanges "dd_SetDisplayControlTextbox", Me.ActiveControl 
341      End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

Label_By_Click (6)

342     
343      Private Sub Label_By_Click() 
344         On Error Resume Next 
345         Application.FollowHyperlink _ 
346            "mailto: strive4peace2010@yahoo.com?subject=Change DisplayControl Contact comment " 
347      End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

MakeTheChanges (37)

348     
349      Private Sub MakeTheChanges(psProcedureName As String, ctl As Control) 
350     
351         Dim sTablename As String _ 
352         , sFieldname As String _ 
353         , sMsg As String _ 
354         , varItem As Variant 
355     
356         With Me.Tablename 
357            If IsNull(.Value) Then 
358               .SetFocus 
359               MsgBox "Table must be specified", , "Aborting" 
360               .Dropdown 
361            End If 
362         End With 
363     
364         sTablename = Me.Tablename 
365         sMsg = sTablename & vbCrLf & Space(3) 
366     
367          'NOTE (from Help): "The ItemsSelected collection is unlike other collections in that it is
368          'a collection of Variants rather than of objects.
369          'Each Variant is an integer index referring to a selected row in a list box or combo box."
370     
371         With Me.lstFieldname 
372            For Each varItem In .ItemsSelected 
373               sFieldname = Nz(.Column(0, varItem), "") 
374               sMsg = Application.Run(psProcedureName, sTablename, sFieldname, sMsg) 
375            Next varItem   'selected field 
376         End With   'field list 
377         Me.txtMsg = "Table: " & sMsg 
378     
379         MsgBox "Done with " & psProcedureName, , "Done" 
380     
381         Call dd_ClearList(ctl) 
382         Call Tablename_AfterUpdate 
383     
384      End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

lstFieldname_AfterUpdate (61)

385     
386     
387      Private Sub lstFieldname_AfterUpdate() 
388       '120426 Crystal
389       'would be more efficient to use ListBox1.Selected[ListBox1.Items.Count-1] to update LastSelected
390     
391         Dim sMsg As String _ 
392            , varItem As Variant _ 
393            , sFieldname As String 
394     
395         Dim db As DAO.Database _ 
396            , tdf As DAO.TableDef _ 
397            , fld As DAO.Field 
398     
399         sMsg = "" 
400     
401         If IsNull(Me.Tablename) Then GoTo Proc_WriteResults 
402     
403         Set db = CurrentDb 
404     
405         Set tdf = db.TableDefs(Me.Tablename) 
406     
407         sMsg = "" 
408         With Me.lstFieldname 
409            For Each varItem In .ItemsSelected 
410               sFieldname = Nz(.Column(0, varItem), "") 
411               Set fld = tdf.Fields(sFieldname) 
412               sMsg = sMsg _ 
413                  & vbCrLf & vbCrLf _ 
414                  & fld.Name & vbCrLf 
415     
416     
417                'lookup RowSource
418               On Error Resume Next 
419               sMsg = sMsg _ 
420                  & fld.Properties("RowSource") 
421               On Error GoTo Proc_Err 
422            Next varItem   'selected field 
423         End With   'field list 
424         If Len(sMsg) > 0 Then sMsg = "Selected Fields: " & sMsg 
425     
426      Proc_WriteResults: 
427         With Me.txtMsg 
428            .Value = sMsg 
429         End With 
430      Proc_Exit: 
431         On Error Resume Next 
432         Set fld = Nothing 
433         Set tdf = Nothing 
434         Set db = Nothing 
435         Exit Sub 
436     
437      Proc_Err: 
438       '   MsgBox Err.Description, , _
439               "ERROR " & Err.Number _
440               & "   lstFieldname_AfterUpdate : " & Me.Name
441     
442         Resume Proc_Exit 
443         Resume 
444     
445      End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

cmdRename_Click (62)

446     
447      Private Sub cmdRename_Click() 
448       '130427
449         If IsNull(Me.TableNameNew) Then 
450            MsgBox "You have not typed in a new name", , "Can't rename" 
451            Exit Sub 
452         End If 
453         If IsNull(Me.Tablename) Then 
454            MsgBox "You have not selected a table to rename", , "Can't rename" 
455            Exit Sub 
456         End If 
457     
458         Dim sTableNameNew As String _ 
459            , sCorrectName As String _ 
460            , sTableNameOld As String _ 
461            , sMsg As String 
462     
463         Dim db As DAO.Database 
464     
465         sTableNameOld = Me.Tablename 
466         sTableNameNew = Trim(Me.TableNameNew) 
467     
468         If Me.chk_CorrectName Then 
469             'user wants to remove bad characters from the name
470     
471            sCorrectName = Get_CorrectName(sTableNameNew, True) 
472     
473            sMsg = "Correct the specified New Name, """"" & sTableNameNew & """ to:" _ 
474               & vbCrLf & vbCrLf & """" & sCorrectName & """" _ 
475               & vbCrLf & "?" 
476     
477            If sTableNameNew <> sCorrectName Then 
478               If MsgBox(sMsg, vbYesNo, "Accept the suggested correction?") = vbNo Then 
479                  Exit Sub 
480               End If 
481               sTableNameNew = sCorrectName 
482               Me.TableNameNew = sCorrectName 
483     
484            End If 
485         End If 
486     
487         If sTableNameOld <> sTableNameNew Then 
488            DoCmd.Rename sTableNameNew, acTable, sTableNameOld 
489            Set db = CurrentDb 
490            db.TableDefs.Refresh 
491            DoEvents 
492            Me.Tablename = sTableNameNew 
493            If Not IsNull(Me.fltrTablename) Then 
494                'clear filter if new tablename is not in it
495               If Not InStr(sTableNameNew, Me.fltrTablename) > 0 Then 
496                  Me.fltrTablename = Null 
497                  Call RowSource_Tablename(Null, Me.chkSys, Me.chkHid) 
498               End If 
499            Else 
500               Me.Tablename.Requery 
501            End If 
502         End If 
503     
504         Me.TableNameNew = Null 
505     
506      End Sub 
507     
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

Form_f_EMPLOYEE (58)

PROCEDURES       Goto Top       Goto Form_f_EMPLOYEE       Goto Forms       Goto Index
  1. Declaration Lines (28)
  2. fnd_EmpID_AfterUpdate (5)
  3. Form_BeforeUpdate (25)

Declaration Lines (28)

1        Option Compare Database 
2        Option Explicit 
3         '============================================================ LICENSE NOTICE -- must not be modified
4         ' This software is licensed to you under CC BY-NC-SA 3.0
5         '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
6         ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
7         '
8         ' You are free to:
9         '    Share  copy and redistribute the material in any medium or format
10        '    Adapt  remix, transform, and build upon the material
11        ' The licensor cannot revoke these freedoms as long as you follow these terms:
12        '    Attribution  You must give appropriate credit, provide a link to the license,
13        '                   and indicate if changes were made.
14        '                   You may do so in any reasonable manner,
15        '                   but not in any way that suggests the licensor endorses you or your use.
16        '    NonCommercial  You may not use the material for commercial purposes.
17        '    ShareAlike  If you remix, transform, or build upon the material,
18        '                 you must distribute your contributions under the same license as the original.
19        '
20        ' many procedures and module names contain author or controbitor names that must be left intact
21        ' if you make changes, add your name, date, and descriptive information to the comments
22        '
23        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629
24        ' ~ Crystal
25        '              * have an awesome day :)
26        '                                                   www.AccessMVP.com/strive4peace
27        ' END LICENSE NOTICE
28        '============================================================
      Goto Top       Goto Form_f_EMPLOYEE       Goto Index

fnd_EmpID_AfterUpdate (5)

29      
30       Private Sub fnd_EmpID_AfterUpdate() 
31        '131002
32          Call FindRecordN(Me, "EmpID", "empNote") 
33       End Sub 
      Goto Top       Goto Form_f_EMPLOYEE       Goto Index

Form_BeforeUpdate (25)

34      
35       Private Sub Form_BeforeUpdate(Cancel As Integer) 
36        '131002
37          Call FormBeforeUpdate(Me) 
38       End Sub 
39      
40      
41        '
42        'Private Sub Form_Current()
43        ''131002
44        '   Dim sSQL As String
45        '
46        '   With Me.lst_CompanyContacts
47        '      sSQL = Replace(.Tag, "ORDER BY" _
48        '               , " WHERE  c.[cid_]=" & Nz(Me.CID, -99) & " ORDER BY ")
49        '      If .RowSource <> sSQL Then
50        '         .RowSource = sSQL
51        '         .Requery
52        '      End If
53        '   End With 'Me.lst_CompanyContacts
54        '
55        '
56        'End Sub
57      
58      
      Goto Top       Goto Form_f_EMPLOYEE       Goto Index

Form_f_EmpPapers_sub (49)

PROCEDURES       Goto Top       Goto Form_f_EmpPapers_sub       Goto Forms       Goto Index
  1. StatusID_GotFocus (42)
  2. StatusID_LostFocus (6)
1        Option Compare Database 

StatusID_GotFocus (42)

2         '============================================================ LICENSE NOTICE -- must not be modified
3         ' This software is licensed to you under CC BY-NC-SA 3.0
4         '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
5         ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
6         '
7         ' You are free to:
8         '    Share  copy and redistribute the material in any medium or format
9         '    Adapt  remix, transform, and build upon the material
10        ' The licensor cannot revoke these freedoms as long as you follow these terms:
11        '    Attribution  You must give appropriate credit, provide a link to the license,
12        '                   and indicate if changes were made.
13        '                   You may do so in any reasonable manner,
14        '                   but not in any way that suggests the licensor endorses you or your use.
15        '    NonCommercial  You may not use the material for commercial purposes.
16        '    ShareAlike  If you remix, transform, or build upon the material,
17        '                 you must distribute your contributions under the same license as the original.
18        '
19        ' many procedures and module names contain author or controbitor names that must be left intact
20        ' if you make changes, add your name, date, and descriptive information to the comments
21        '
22        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629
23        ' ~ Crystal
24        '              * have an awesome day :)
25        '                                                   www.AccessMVP.com/strive4peace
26        ' END LICENSE NOTICE
27        '============================================================
28       Private Sub StatusID_GotFocus() 
29        '140206
30           Dim nGrpID As Long 
31           With Me.PaperID 
32               If IsNull(.Value) Then 
33                   .SetFocus 
34                   .Dropdown 
35                   Exit Sub 
36               End If 
37               nGrpID = .Column(2) 
38           End With 
39      
40           Call SetControl_RowSource(Me.StatusID _ 
41               , "Statusez.GrpID=" & nGrpID) 
42      
43       End Sub 
      Goto Top       Goto Form_f_EmpPapers_sub       Goto Index

StatusID_LostFocus (6)

44      
45       Private Sub StatusID_LostFocus() 
46        '140206
47           Call SetControl_RowSource(Me.StatusID) 
48      
49       End Sub 
      Goto Top       Goto Form_f_EmpPapers_sub       Goto Index

Form_f_GetDateRange (90)

PROCEDURES       Goto Top       Goto Form_f_GetDateRange       Goto Forms       Goto Index
  1. ASDay (6)
  2. ASMonth (6)
  3. ASYear (6)
  4. cmd_Clear_Click (6)
  5. Date1_DblClick (5)
  6. Date2_DblClick (6)
  7. Declaration Lines (2)
  8. FillDate (7)
  9. FillMonth (6)
  10. FillMTD (6)
  11. FillOneWeek (6)
  12. FillOneYear (6)
  13. FillQuarter (9)
  14. FillWorkWeek (7)
  15. FillYTD (6)

Declaration Lines (2)

1        Option Compare Database 
2        Option Explicit 
      Goto Top       Goto Form_f_GetDateRange       Goto Index

ASDay (6)

3       
4        Private Function ASDay(pNum As Integer) 
5           On Error Resume Next 
6           Me.Date1 = DateSerial(Year(Me.Date1), Month(Me.Date1), Day(Me.Date1) + pNum) 
7           Me.Date2 = DateSerial(Year(Me.Date2), Month(Me.Date2), Day(Me.Date2) + pNum) 
8        End Function 
      Goto Top       Goto Form_f_GetDateRange       Goto Index

ASMonth (6)

9       
10       Private Function ASMonth(pNum As Integer) 
11          On Error Resume Next 
12          Me.Date1 = DateSerial(Year(Me.Date1), Month(Me.Date1) + pNum, Day(Me.Date1)) 
13          Me.Date2 = DateSerial(Year(Me.Date2), Month(Me.Date2) + pNum, Day(Me.Date2)) 
14       End Function 
      Goto Top       Goto Form_f_GetDateRange       Goto Index

ASYear (6)

15      
16       Private Function ASYear(pNum As Integer) 
17          On Error Resume Next 
18          Me.Date1 = DateSerial(Year(Me.Date1) + pNum, Month(Me.Date1), Day(Me.Date1)) 
19          Me.Date2 = DateSerial(Year(Me.Date2) + pNum, Month(Me.Date2), Day(Me.Date2)) 
20       End Function 
      Goto Top       Goto Form_f_GetDateRange       Goto Index

FillOneYear (6)

21      
22       Private Function FillOneYear() 
23          On Error Resume Next 
24          Me.Date2 = Date - 1 
25          Me.Date1 = DateSerial(Year(Me.Date2) - 1, Month(Me.Date2), Day(Me.Date2)) + 1 
26       End Function 
      Goto Top       Goto Form_f_GetDateRange       Goto Index

FillQuarter (9)

27      
28       Private Function FillQuarter(pQtr As Integer) 
29          Dim mMonth As Integer, mEndQ As Integer, mYear As Integer 
30          mMonth = Month(Date) 
31          mEndQ = pQtr * 3 
32          If mMonth > mEndQ Then mYear = Year(Date) Else mYear = Year(Date) - 1 
33          Me.Date1 = DateSerial(mYear, mEndQ - 2, 1) 
34          Me.Date2 = DateSerial(mYear, mEndQ + 1, 1) - 1 
35       End Function 
      Goto Top       Goto Form_f_GetDateRange       Goto Index

FillDate (7)

36      
37       Private Function FillDate(Optional pDate) 
38          On Error Resume Next 
39          If IsMissing(pDate) Then pDate = Date 
40             Me.Date1 = pDate 
41             Me.Date2 = pDate 
42       End Function 
      Goto Top       Goto Form_f_GetDateRange       Goto Index

FillMTD (6)

43      
44       Private Function FillMTD() 
45          On Error Resume Next 
46          Me.Date1 = DateSerial(Year(Date), Month(Date), 1) 
47          Me.Date2 = Date 
48       End Function 
      Goto Top       Goto Form_f_GetDateRange       Goto Index

FillYTD (6)

49      
50       Private Function FillYTD() 
51          On Error Resume Next 
52          Me.Date1 = DateSerial(Year(Date), 1, 1) 
53          Me.Date2 = Date 
54       End Function 
      Goto Top       Goto Form_f_GetDateRange       Goto Index

FillOneWeek (6)

55      
56       Private Function FillOneWeek() 
57          On Error Resume Next 
58          Me.Date1 = Date - 6 
59          Me.Date2 = Date 
60       End Function 
      Goto Top       Goto Form_f_GetDateRange       Goto Index

FillMonth (6)

61      
62       Private Function FillMonth() 
63          On Error Resume Next 
64          Me.Date1 = DateSerial(Year(Date), Month(Date), 1) 
65          Me.Date2 = DateSerial(Year(Date), Month(Date) + 1, 1) - 1 
66       End Function 
      Goto Top       Goto Form_f_GetDateRange       Goto Index

FillWorkWeek (7)

67      
68       Private Function FillWorkWeek() 
69          Dim mDOW As Integer 
70          mDOW = Weekday(Date) 
71          Me.Date1 = Date - mDOW + 1 
72          Me.Date2 = Me.Date1 + 6 
73       End Function 
      Goto Top       Goto Form_f_GetDateRange       Goto Index

cmd_Clear_Click (6)

74      
75       Private Sub cmd_Clear_Click() 
76        '141007
77          Me.Date1 = Null 
78          Me.Date2 = Null 
79       End Sub 
      Goto Top       Goto Form_f_GetDateRange       Goto Index

Date1_DblClick (5)

80      
81       Private Sub Date1_DblClick(Cancel As Integer) 
82        '141011
83          Call PopCalendar(True) 
84       End Sub 
      Goto Top       Goto Form_f_GetDateRange       Goto Index

Date2_DblClick (6)

85      
86       Private Sub Date2_DblClick(Cancel As Integer) 
87        '141011
88          Call PopCalendar(True, Me.Date1.Value) 
89      
90       End Sub 
      Goto Top       Goto Form_f_GetDateRange       Goto Index

Form_f_INVOICE (102)

PROCEDURES       Goto Top       Goto Form_f_INVOICE       Goto Forms       Goto Index
  1. CalculateTax (57)
  2. CIDCust_AfterUpdate (12)
  3. cmd_New_Click (17)
  4. Declaration Lines (2)
  5. dtio_DblClick (5)
  6. Form_Current (4)
  7. txtTaxRate_AfterUpdate (5)

Declaration Lines (2)

1        Option Compare Database 
2        Option Explicit 
      Goto Top       Goto Form_f_INVOICE       Goto Index

CalculateTax (57)

3         '============================================================ LICENSE NOTICE -- must not be modified
4         ' This software is licensed to you under CC BY-NC-SA 3.0
5         '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
6         ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
7         '
8         ' You are free to:
9         '    Share  copy and redistribute the material in any medium or format
10        '    Adapt  remix, transform, and build upon the material
11        ' The licensor cannot revoke these freedoms as long as you follow these terms:
12        '    Attribution  You must give appropriate credit, provide a link to the license,
13        '                   and indicate if changes were made.
14        '                   You may do so in any reasonable manner,
15        '                   but not in any way that suggests the licensor endorses you or your use.
16        '    NonCommercial  You may not use the material for commercial purposes.
17        '    ShareAlike  If you remix, transform, or build upon the material,
18        '                 you must distribute your contributions under the same license as the original.
19        '
20        ' many procedures and module names contain author or controbitor names that must be left intact
21        ' if you make changes, add your name, date, and descriptive information to the comments
22        '
23        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629
24        ' ~ Crystal
25        '              * have an awesome day :)
26        '                                                   www.AccessMVP.com/strive4peace
27        ' END LICENSE NOTICE
28        '============================================================
29       Public Function CalculateTax() 
30          Dim curTax As Currency _ 
31             , curTotal As Currency 
32          curTotal = 0 
33          If Me.Dirty Then Me.Dirty = False 
34        '   With Me.f_InvoiceDetail_sub.Form
35        '      If .Recordset.RecordCount > 0 Then
36        '         If .Dirty Then .Dirty = False
37        '         .txtSum.Requery
38        '         curTotal = curTotal + .txtSum
39        '      End If
40        '   End With
41        '   With Me.f_Invoice_Charges_sub.Form
42        '      If .Recordset.RecordCount > 0 Then
43        '         If .Dirty Then .Dirty = False
44        '         .txtSum.Requery
45        '         curTotal = curTotal + .txtSum
46        '      End If
47        '   End With
48      
49          CurrentDb.TableDefs.Refresh 
50          DoEvents 
51      
52          curTotal = Nz(DSum("qtyship * UnitPric" _ 
53             , "InvOrdDetail", "ioid=" & Me.ioID), 0) _ 
54             + Nz(DSum("AmtChg", "AddCharges", "ioid=" & Me.ioID), 0) 
55      
56          curTax = curTotal * Nz(Me.txtTaxRate, 0) 
57          Me.AmtTax = CCur(Round(curTax, 2)) 
58          Me.txtSum = curTotal + curTax 
59       End Function 
      Goto Top       Goto Form_f_INVOICE       Goto Index

CIDCust_AfterUpdate (12)

60      
61       Private Sub CIDCust_AfterUpdate() 
62        '140623
63          With Me.CIDCust 
64             If IsNull(.Value) Then Exit Sub 
65             If Len(.Column(2)) > 0 Then 
66                Me.txtTaxRate = CDbl(.Column(2)) 
67                Me.Dirty = False 
68             End If 
69          End With 
70          Call CalculateTax 
71       End Sub 
      Goto Top       Goto Form_f_INVOICE       Goto Index

cmd_New_Click (17)

72      
73       Private Sub cmd_New_Click() 
74        '140622
75          Dim nSeqNum As Long _ 
76             , sSQL As String 
77          If Not Me.NewRecord Then 
78             DoCmd.RunCommand acCmdRecordsGoToNew 
79          End If 
80          Me.SeqNum = Nz(DMax("SeqNum", "InvOrd"), 2948) + 1 
81          sSQL = "INSERT into AddCharges (InvOrdID, ChgTyID, AmtChg, ChgPc) " _ 
82             & " SELECT InvOrdID, ChgTyID, AmtChg, ChgPcDf FROM VhgTypes" _ 
83             & " WHERE ChgCat='I' and IsActiv;" 
84          rSql sSQL 
85          CurrentDb.TableDefs.Refresh 
86          DoEvents 
87          Me.f_Invoice_Charges_sub.Requery 
88       End Sub 
      Goto Top       Goto Form_f_INVOICE       Goto Index

dtio_DblClick (5)

89      
90       Private Sub dtio_DblClick(Cancel As Integer) 
91        '140622
92          DoCmd.OpenForm "f_PopupCalendar" 
93       End Sub 
      Goto Top       Goto Form_f_INVOICE       Goto Index

Form_Current (4)

94      
95       Private Sub Form_Current() 
96          Call CIDCust_AfterUpdate 
97       End Sub 
      Goto Top       Goto Form_f_INVOICE       Goto Index

txtTaxRate_AfterUpdate (5)

98      
99       Private Sub txtTaxRate_AfterUpdate() 
100       '140623
101         Call CalculateTax 
102      End Sub 
      Goto Top       Goto Form_f_INVOICE       Goto Index

Form_f_Invoice_Charges_sub (32)

PROCEDURES       Goto Top       Goto Form_f_Invoice_Charges_sub       Goto Forms       Goto Index
  1. AmtChg_AfterUpdate (30)
  2. Declaration Lines (2)

Declaration Lines (2)

1        Option Compare Database 
2        Option Explicit 
      Goto Top       Goto Form_f_Invoice_Charges_sub       Goto Index

AmtChg_AfterUpdate (30)

3         '============================================================ LICENSE NOTICE -- must not be modified
4         ' This software is licensed to you under CC BY-NC-SA 3.0
5         '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
6         ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
7         '
8         ' You are free to:
9         '    Share  copy and redistribute the material in any medium or format
10        '    Adapt  remix, transform, and build upon the material
11        ' The licensor cannot revoke these freedoms as long as you follow these terms:
12        '    Attribution  You must give appropriate credit, provide a link to the license,
13        '                   and indicate if changes were made.
14        '                   You may do so in any reasonable manner,
15        '                   but not in any way that suggests the licensor endorses you or your use.
16        '    NonCommercial  You may not use the material for commercial purposes.
17        '    ShareAlike  If you remix, transform, or build upon the material,
18        '                 you must distribute your contributions under the same license as the original.
19        '
20        ' many procedures and module names contain author or controbitor names that must be left intact
21        ' if you make changes, add your name, date, and descriptive information to the comments
22        '
23        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629
24        ' ~ Crystal
25        '              * have an awesome day :)
26        '                                                   www.AccessMVP.com/strive4peace
27        ' END LICENSE NOTICE
28        '============================================================
29       Private Sub AmtChg_AfterUpdate() 
30          Me.Dirty = False 
31          Me.Parent.CalculateTax 
32       End Sub 
      Goto Top       Goto Form_f_Invoice_Charges_sub       Goto Index

Form_f_Invoice_sub_NEEDSWORK (236)

PROCEDURES       Goto Top       Goto Form_f_Invoice_sub_NEEDSWORK       Goto Forms       Goto Index
  1. CalculateAmtTran (19)
  2. Declaration Lines (52)
  3. DtIDTran_DblClick (6)
  4. EmpID_AfterUpdate (38)
  5. Form_BeforeUpdate (6)
  6. QtyTran_AfterUpdate (6)
  7. QtyTyID_AfterUpdate (5)
  8. SetTabStops (36)
  9. TranTyID_AfterUpdate (63)
  10. UnitCost_AfterUpdate (5)

Declaration Lines (52)

1        Option Compare Database 
2        Option Explicit 
3         '=======================================================
4         ' f_Expenses_sub
5         '=======================================================
6         '=============================================
7         ' LICENSE NOTICE:
8         ' This code was originally written by Crystal (strive4peace)
9         ' strive4peace2012@yahoo.com
10        ' 131002
11        ' It is not to be altered or distributed,
12        ' except as part of a NON-COMMERCIAL application.
13        ' This License Notice must not be deleted.
14        '
15        ' Licensed under Creative Commons
16        ' License name: Attribution-NonCommercial-ShareAlike 3.0 Unported (CC BY-NC-SA 3.0)
17        ' This license lets you remix, tweak, and build upon your work non-commercially,
18        ' as long as I am credited and you license your new creations under the identical terms.
19        ' You can download and redistribute my work, translate, make remixes,
20        ' and create new applications based on my work.
21        ' All new work based on my work must carry the same license,
22        ' so any derivatives will also be non-commercial in nature.
23        ' legal code: http://creativecommons.org/licenses/by-nc-sa/3.0/legalcode
24        ' human-readable summary: http://creativecommons.org/licenses/by-nc-sa/3.0/
25        ' ~ Crystal
26        ' www.AccessMVP.com/strive4peace
27        ' ~ have an awesome day :)
28        '=============================================
29        '=======================================================
30        'Private Sub SetMyRecordSource(Optional pBooAll As Boolean = False)
31        ''130908, 1002
32        '   On Error GoTo Proc_Err
33        '   Dim sSQL As String
34        '   sSQL = "SELECT Expenses.* FROM Expenses"
35        '   If Not pBooAll Then
36        '      sSQL = sSQL & " WHERE IsNull([InvoiceID]) "
37        '   End If
38        '   sSQL = sSQL & " ORDER BY Expenses.DtIDTran;"
39        '   Me.RecordSource = sSQL
40        '
41        'Proc_Exit:
42        '   On Error Resume Next
43        '   Exit Sub
44        '
45        'Proc_Err:
46        '   MsgBox Err.Description, , _
47        '        "ERROR " & Err.Number _
48        '        & "   SetMyRecordSource : " & Me.Name
49        '
50        '   Resume Proc_Exit
51        '   Resume
52        'End Sub
      Goto Top       Goto Form_f_Invoice_sub_NEEDSWORK       Goto Index

EmpID_AfterUpdate (38)

53      
54       Private Sub EmpID_AfterUpdate() 
55        '131002
56          If Len(Me.EmpID.Column(2)) > 0 Then 
57             Me.UnitCost = Me.EmpID.Column(2) 
58          End If 
59       End Sub 
60        '
61        'Private Sub Form_Open(Cancel As Integer)
62        ''130908, 1002
63        '   'CALLS
64        '   '  SetMyRecordSource
65        '
66        '   On Error GoTo Proc_Err
67        '   Dim sSQL As String _
68        '      , booAll As Boolean
69        '   booAll = True
70        '
71        '   If IsSubform(Me) Then
72        '      If InStr(Me.Parent.Name, "Project") > 0 Then
73        '         booAll = False
74        '      End If
75        '   End If
76        '
77        '   Call SetMyRecordSource(booAll)
78        '
79        'Proc_Exit:
80        '   On Error Resume Next
81        '   Exit Sub
82        '
83        'Proc_Err:
84        '   MsgBox Err.Description, , _
85        '        "ERROR " & Err.Number _
86        '        & "   Form_Open : " & Me.Name
87        '
88        '   Resume Proc_Exit
89        '   Resume
90        'End Sub
      Goto Top       Goto Form_f_Invoice_sub_NEEDSWORK       Goto Index

Form_BeforeUpdate (6)

91      
92       Private Sub Form_BeforeUpdate(Cancel As Integer) 
93        '130907
94          On Error Resume Next 
95          Me.dtmEdit = Now() 
96       End Sub 
      Goto Top       Goto Form_f_Invoice_sub_NEEDSWORK       Goto Index

DtIDTran_DblClick (6)

97      
98      
99       Private Sub DtIDTran_DblClick(Cancel As Integer) 
100       '130906
101          DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog 
102      End Sub 
      Goto Top       Goto Form_f_Invoice_sub_NEEDSWORK       Goto Index

TranTyID_AfterUpdate (63)

103     
104      Private Sub TranTyID_AfterUpdate() 
105       '130906
106          'ExpID=0: TIME
107          'any other Expense -- don't prompt for Employee or Hours
108     
109          'column(3) = default UnitCost type
110          ' 4 = default expense AmtTran
111     
112         On Error GoTo Proc_Err 
113     
114         Dim nQtyTyID As Long _ 
115            , nAmtTran As Currency 
116     
117         Dim booFixedCost As Boolean 
118     
119         nAmtTran = 0 
120     
121         With Me 
122            If IsNull(.TranTyID) Then 
123               nQtyTyID = 1 
124            Else 
125               If Len(.TranTyID.Column(2)) > 0 Then 
126                  nQtyTyID = CLng(.TranTyID.Column(2)) 
127                  Me.QtyTyID = nQtyTyID 
128               End If 
129               If .TranTyID.Column(3) <> "" Then   '--------- default is 0.00 ?? keep 
130                  nAmtTran = CCur(.TranTyID.Column(3)) 
131               End If 
132               If nAmtTran <> 0 Then 
133                  Me.AmtTran = nAmtTran 
134               Else 
135                  Me.AmtTran = Null 
136               End If 
137            End If 
138     
139             'if Fixed UnitCost, don't stop at Employee, Hours, UnitCost
140             'if Fixed UnitCost, do stop at AmtTran
141     
142            If nQtyTyID = 0 Then   'Fixed 
143               booFixedCost = False 
144            Else 
145               booFixedCost = True 
146            End If 
147     
148            Call SetTabStops(booFixedCost) 
149     
150            .AmtTran.TabStop = Not booFixedCost 
151     
152         End With   'me 
153     
154      Proc_Exit: 
155         On Error Resume Next 
156         Exit Sub 
157     
158      Proc_Err: 
159         MsgBox Err.Description, , _ 
160              "ERROR " & Err.Number _ 
161              & "   TranTyID_AfterUpdate : " & Me.Name 
162     
163         Resume Proc_Exit 
164         Resume 
165      End Sub 
      Goto Top       Goto Form_f_Invoice_sub_NEEDSWORK       Goto Index

SetTabStops (36)

166     
167      Private Sub SetTabStops(ByVal booFixedCost As Boolean) 
168       '131002
169     
170         With Me 
171            .AmtTran.TabStop = Not booFixedCost 
172     
173            .EmpID.TabStop = booFixedCost 
174            .QtyTran.TabStop = booFixedCost 
175            .UnitCost.TabStop = booFixedCost 
176            If Not booFixedCost Then 
177               .EmpID.Value = Null 
178               .QtyTyID.Value = 0   'fixed 
179               .QtyTran.Value = Null 
180               .UnitCost.Value = Null 
181            Else 
182                'Time -- hourly or daily
183               If .QtyTyID.Value <> 0 Then 
184                  .QtyTyID = 1   'Hourly -- can be changed by user 
185               End If 
186            End If 
187     
188         End With   'me 
189     
190      Proc_Exit: 
191         On Error Resume Next 
192         Exit Sub 
193     
194      Proc_Err: 
195         MsgBox Err.Description, , _ 
196              "ERROR " & Err.Number _ 
197              & "   TranTyID_AfterUpdate : " & Me.Name 
198     
199         Resume Proc_Exit 
200         Resume 
201      End Sub 
      Goto Top       Goto Form_f_Invoice_sub_NEEDSWORK       Goto Index

QtyTran_AfterUpdate (6)

202     
203     
204      Private Sub QtyTran_AfterUpdate() 
205       '130908
206         Call CalculateAmtTran 
207      End Sub 
      Goto Top       Goto Form_f_Invoice_sub_NEEDSWORK       Goto Index

QtyTyID_AfterUpdate (5)

208     
209      Private Sub QtyTyID_AfterUpdate() 
210         If IsNull(Me.QtyTyID) Then Exit Sub 
211         Call SetTabStops((Me.QtyTyID = 0)) 
212      End Sub 
      Goto Top       Goto Form_f_Invoice_sub_NEEDSWORK       Goto Index

UnitCost_AfterUpdate (5)

213     
214      Private Sub UnitCost_AfterUpdate() 
215       '130906
216         Call CalculateAmtTran 
217      End Sub 
      Goto Top       Goto Form_f_Invoice_sub_NEEDSWORK       Goto Index

CalculateAmtTran (19)

218     
219      Private Sub CalculateAmtTran() 
220       '130906,8
221     
222         On Error Resume Next 
223     
224         If Nz(Me.QtyTyID, 0) = 0 Then 'don't calculate if cost is FIXED 
225            Exit Sub 
226         End If 
227         Me.AmtTran = Round(Nz(Me.QtyTran, 0) * Nz(Me.UnitCost, 0), 2) 
228     
229       '   Select Case Me.QtyTyID
230       '   Case 1 'hourly
231       '      Me.AmtTran = Round(Me.QtyTran * Me.UnitCost, 2)
232       '   Case 2 'daily
233       '   End Select
234     
235      End Sub 
236     
      Goto Top       Goto Form_f_Invoice_sub_NEEDSWORK       Goto Index

Form_f_InvoiceDetail_sub (101)

PROCEDURES       Goto Top       Goto Form_f_InvoiceDetail_sub       Goto Forms       Goto Index
  1. Declaration Lines (2)
  2. Form_AfterUpdate (30)
  3. fraItmBy_AfterUpdate (46)
  4. ItmID_AfterUpdate (11)
  5. QtyShip_AfterUpdate (6)
  6. UnitPric_AfterUpdate (6)

Declaration Lines (2)

1        Option Compare Database 
2        Option Explicit 
      Goto Top       Goto Form_f_InvoiceDetail_sub       Goto Index

Form_AfterUpdate (30)

3         '============================================================ LICENSE NOTICE -- must not be modified
4         ' This software is licensed to you under CC BY-NC-SA 3.0
5         '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
6         ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
7         '
8         ' You are free to:
9         '    Share  copy and redistribute the material in any medium or format
10        '    Adapt  remix, transform, and build upon the material
11        ' The licensor cannot revoke these freedoms as long as you follow these terms:
12        '    Attribution  You must give appropriate credit, provide a link to the license,
13        '                   and indicate if changes were made.
14        '                   You may do so in any reasonable manner,
15        '                   but not in any way that suggests the licensor endorses you or your use.
16        '    NonCommercial  You may not use the material for commercial purposes.
17        '    ShareAlike  If you remix, transform, or build upon the material,
18        '                 you must distribute your contributions under the same license as the original.
19        '
20        ' many procedures and module names contain author or controbitor names that must be left intact
21        ' if you make changes, add your name, date, and descriptive information to the comments
22        '
23        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629
24        ' ~ Crystal
25        '              * have an awesome day :)
26        '                                                   www.AccessMVP.com/strive4peace
27        ' END LICENSE NOTICE
28        '============================================================
29       Private Sub Form_AfterUpdate() 
30        '140623
31          Call Me.Parent.CalculateTax 
32       End Sub 
      Goto Top       Goto Form_f_InvoiceDetail_sub       Goto Index

fraItmBy_AfterUpdate (46)

33      
34       Private Sub fraItmBy_AfterUpdate() 
35        '140620
36          Dim sSQL As String 
37      
38          Select Case Me.fraItmBy 
39          Case 1   'Name 
40             sSQL = "SELECT I.itmID " _ 
41                & ", i.itmName " _ 
42                & "& IIf(i.ItmCode<>i.itmName,(', '+i.ItmCode),'') " _ 
43                & "& (IIf(i.itmid_<>i.itmID,(', ' & ip.itmName),'')) " _ 
44                & "AS itm" _ 
45                & ",i.ListPrice " _ 
46                & " FROM Itms AS I " _ 
47                & " LEFT JOIN Itms AS Ip ON I.itmID_ = Ip.itmID" _ 
48                & " ORDER BY i.itmName,i.ItmCode,ip.itmName;" 
49      
50          Case 2   'Code 
51             sSQL = "SELECT I.itmID " _ 
52                & ", i.ItmCode " _ 
53                & "& ', ' & i.itmName " _ 
54                & "& (IIf(i.itmid_<>i.itmID,(', ' & ip.itmName),'')) " _ 
55                & "AS itm" _ 
56                & ",i.ListPrice " _ 
57                & " FROM Itms AS I " _ 
58                & " LEFT JOIN Itms AS Ip ON I.itmID_ = Ip.itmID" _ 
59                & " ORDER BY i.ItmCode,i.itmName, ip.itmName;" 
60      
61          Case 3   'Category 
62             sSQL = "SELECT I.itmID " _ 
63                & ", trim(ip.itmName " _ 
64                & "& ' ' & i.itmName " _ 
65                & "& IIf(i.ItmCode<>i.itmName,(', '+i.ItmCode),'') " _ 
66                & ") AS itm" _ 
67                & ",i.ListPrice " _ 
68                & " FROM Itms AS I " _ 
69                & " LEFT JOIN Itms AS Ip ON I.itmID_ = Ip.itmID" _ 
70                & " ORDER BY ip.itmName, i.itmName,i.ItmCode;" 
71      
72          End Select 
73          With Me.ItmID 
74             .RowSource = sSQL 
75             .Requery 
76          End With 
77      
78       End Sub 
      Goto Top       Goto Form_f_InvoiceDetail_sub       Goto Index

ItmID_AfterUpdate (11)

79      
80      
81       Private Sub ItmID_AfterUpdate() 
82        '140623
83          With Me.ItmID 
84             If IsNull(.Value) Then Exit Sub 
85             If Len(.Column(2)) > 0 Then 
86                Me.UnitPric = .Column(2) 
87             End If 
88          End With 
89       End Sub 
      Goto Top       Goto Form_f_InvoiceDetail_sub       Goto Index

QtyShip_AfterUpdate (6)

90      
91       Private Sub QtyShip_AfterUpdate() 
92        '140623
93          Me.Dirty = False 
94          Call Me.Parent.CalculateTax 
95       End Sub 
      Goto Top       Goto Form_f_InvoiceDetail_sub       Goto Index

UnitPric_AfterUpdate (6)

96      
97       Private Sub UnitPric_AfterUpdate() 
98        '140623
99          Me.Dirty = False 
100         Call Me.Parent.CalculateTax 
101      End Sub 
      Goto Top       Goto Form_f_InvoiceDetail_sub       Goto Index

Form_f_INVOICEs_NEEDSWORK (61)

PROCEDURES       Goto Top       Goto Form_f_INVOICEs_NEEDSWORK       Goto Forms       Goto Index
  1. Declaration Lines (24)
  2. fnd_Invoice_AfterUpdate (6)
  3. fnd_PO_AfterUpdate (7)
  4. fnd_Project_AfterUpdate (6)
  5. Form_BeforeUpdate (6)
  6. Form_Open (12)

Declaration Lines (24)

1        Option Compare Database 
2         '=============================================
3         ' LICENSE NOTICE:
4         ' This code was originally written by Crystal Long (strive4peace)
5         ' strive4peace2010@yahoo.com
6         ' 130923
7         ' It is not to be altered or distributed,
8         ' except as part of a NON-COMMERCIAL application without written permission from Crystal Long
9         ' This License Notice must not be deleted.
10        '
11        ' Licensed under Creative Commons
12        ' License name: Attribution-NonCommercial-ShareAlike 3.0 Unported (CC BY-NC-SA 3.0)
13        ' This license lets you remix, tweak, and build upon your work non-commercially,
14        ' as long as I am credited and you license your new creations under the identical terms.
15        ' You can download and redistribute my work, translate, make remixes,
16        ' and create new applications based on my work.
17        ' All new work based on my work must carry the same license,
18        ' so any derivatives will also be non-commercial in nature.
19        ' legal code: http://creativecommons.org/licenses/by-nc-sa/3.0/legalcode
20        ' human-readable summary: http://creativecommons.org/licenses/by-nc-sa/3.0/
21        ' ~ Crystal
22        ' www.AccessMVP.com/strive4peace
23        ' ~ have an awesome day :)
24        '=============================================
      Goto Top       Goto Form_f_INVOICEs_NEEDSWORK       Goto Index

Form_Open (12)

25      
26      
27      
28       Private Sub Form_Open(Cancel As Integer) 
29        '131114
30           'update transaction dates
31          Dim sSQL As String 
32          sSQL = "UPDATE Jobs INNER JOIN Transactionz ON Jobs.JobID = Transactionz.JobID " _ 
33             & " SET Transactionz.DtIDTran = CLng([dtmJob1]) " _ 
34             & " WHERE ((Transactionz.DtIDTran Is Null) AND (Jobs.dtmJob1 Is Not Null));" 
35          Call rSql(sSQL) 
36       End Sub 
      Goto Top       Goto Form_f_INVOICEs_NEEDSWORK       Goto Index

Form_BeforeUpdate (6)

37      
38       Private Sub Form_BeforeUpdate(Cancel As Integer) 
39        '131002
40           'update the tracking fields
41          Call FormBeforeUpdate(Me) 
42       End Sub 
      Goto Top       Goto Form_f_INVOICEs_NEEDSWORK       Goto Index

fnd_Invoice_AfterUpdate (6)

43      
44       Private Sub fnd_Invoice_AfterUpdate() 
45        '131002
46           'find an invoice
47          Call FindRecordN(Me, "InvoiceID", "invNote") 
48       End Sub 
      Goto Top       Goto Form_f_INVOICEs_NEEDSWORK       Goto Index

fnd_Project_AfterUpdate (6)

49      
50       Private Sub fnd_Project_AfterUpdate() 
51        '131006
52           'find an invoice by Project
53          Call FindRecordN(Me, "InvoiceID", "invNote") 
54       End Sub 
      Goto Top       Goto Form_f_INVOICEs_NEEDSWORK       Goto Index

fnd_PO_AfterUpdate (7)

55      
56       Private Sub fnd_PO_AfterUpdate() 
57        '131115
58           'find an invoice by Project
59          Call FindRecordN(Me, "InvoiceID", "invNote") 
60       End Sub 
61      
      Goto Top       Goto Form_f_INVOICEs_NEEDSWORK       Goto Index

Form_f_ITM (141)

PROCEDURES       Goto Top       Goto Form_f_ITM       Goto Forms       Goto Index
  1. cmd_Clear_fltr_ItmID__Click (6)
  2. cmd_Close_Click (5)
  3. Declaration Lines (28)
  4. FilterMe (62)
  5. fltr_ItmID__AfterUpdate (5)
  6. Fnd_ItmID_Code_AfterUpdate (5)
  7. Fnd_ItmID_Name_AfterUpdate (5)
  8. Fnd_ItmID_SupCode_AfterUpdate (5)
  9. Form_BeforeUpdate (5)
  10. Form_Load (15)

Declaration Lines (28)

1        Option Compare Database 
2        Option Explicit 
3         '============================================================ LICENSE NOTICE -- must not be modified
4         ' This software is licensed to you under CC BY-NC-SA 3.0
5         '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
6         ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
7         '
8         ' You are free to:
9         '    Share  copy and redistribute the material in any medium or format
10        '    Adapt  remix, transform, and build upon the material
11        ' The licensor cannot revoke these freedoms as long as you follow these terms:
12        '    Attribution  You must give appropriate credit, provide a link to the license,
13        '                   and indicate if changes were made.
14        '                   You may do so in any reasonable manner,
15        '                   but not in any way that suggests the licensor endorses you or your use.
16        '    NonCommercial  You may not use the material for commercial purposes.
17        '    ShareAlike  If you remix, transform, or build upon the material,
18        '                 you must distribute your contributions under the same license as the original.
19        '
20        ' many procedures and module names contain author or controbitor names that must be left intact
21        ' if you make changes, add your name, date, and descriptive information to the comments
22        '
23        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629
24        ' ~ Crystal
25        '              * have an awesome day :)
26        '                                                   www.AccessMVP.com/strive4peace
27        ' END LICENSE NOTICE
28        '============================================================
      Goto Top       Goto Form_f_ITM       Goto Index

Form_Load (15)

29      
30      
31       Private Sub Form_Load() 
32        '140701
33          Dim nItmID As Long 
34           'find a particular item if ItmID is in OpenArgs
35          With Me 
36             If Len(.OpenArgs) > 0 Then 
37                If IsNumeric(.OpenArgs) Then 
38                   nItmID = CLng(.OpenArgs) 
39                   Call FindRecordN(Me, "ItmID", "ItmName", nItmID) 
40                End If 
41             End If 
42          End With   'me 
43       End Sub 
      Goto Top       Goto Form_f_ITM       Goto Index

Form_BeforeUpdate (5)

44      
45       Private Sub Form_BeforeUpdate(Cancel As Integer) 
46        '140701
47          Me.dtmEdit = Now() 
48       End Sub 
      Goto Top       Goto Form_f_ITM       Goto Index

cmd_Close_Click (5)

49      
50       Private Sub cmd_Close_Click() 
51        '140701
52          DoCmd.Close acForm, Me.Name, acSaveNo 
53       End Sub 
      Goto Top       Goto Form_f_ITM       Goto Index

fltr_ItmID__AfterUpdate (5)

54      
55       Private Sub fltr_ItmID__AfterUpdate() 
56        '140701
57          Call FilterMe 
58       End Sub 
      Goto Top       Goto Form_f_ITM       Goto Index

Fnd_ItmID_Code_AfterUpdate (5)

59      
60       Private Sub Fnd_ItmID_Code_AfterUpdate() 
61        '140701
62          Call FindRecordN(Me, "ItmID", "ItmName") 
63       End Sub 
      Goto Top       Goto Form_f_ITM       Goto Index

Fnd_ItmID_Name_AfterUpdate (5)

64      
65       Private Sub Fnd_ItmID_Name_AfterUpdate() 
66        '140701
67          Call FindRecordN(Me, "ItmID", "ItmName") 
68       End Sub 
      Goto Top       Goto Form_f_ITM       Goto Index

Fnd_ItmID_SupCode_AfterUpdate (5)

69      
70       Private Sub Fnd_ItmID_SupCode_AfterUpdate() 
71        '140701
72          Call FindRecordN(Me, "ItmID", "ItmName") 
73       End Sub 
      Goto Top       Goto Form_f_ITM       Goto Index

cmd_Clear_fltr_ItmID__Click (6)

74      
75       Private Sub cmd_Clear_fltr_ItmID__Click() 
76        '140701
77          Me.fltr_ItmID_ = Null 
78          Call FilterMe 
79       End Sub 
      Goto Top       Goto Form_f_ITM       Goto Index

FilterMe (62)

80      
81       Private Function FilterMe() As Boolean 
82        '140701
83           'CALLS
84           '  SetControl_RowSource
85           '
86           'Called By
87           '  cmd_Clear_fltr_ItmID_
88           '  fltr_ItmID_
89      
90          On Error GoTo Proc_Err 
91      
92          Dim sSQL As String _ 
93             , vWhere As Variant _ 
94             , sOrderBy As String _ 
95             , sEqn_Fullname As String _ 
96             , iPos1 As Integer _ 
97             , iPos2 As Integer 
98      
99          vWhere = Null 
100     
101          '-------------------------- Filter
102         With Me.fltr_ItmID_ 
103            If Not IsNull(.Value) Then 
104               vWhere = (vWhere + " AND ") & "i.ItmID_=" & .Value 
105            Else 
106               vWhere = "" 
107            End If 
108         End With 
109     
110          ' other FIND combo and listbox rowsources
111         Call SetControl_RowSource(Me.Fnd_ItmID_Code, vWhere) 
112         Call SetControl_RowSource(Me.Fnd_ItmID_Name, vWhere) 
113         Call SetControl_RowSource(Me.Fnd_ItmID_SupCode, vWhere) 
114     
115         With Me 
116            If Len(vWhere) > 0 Then 
117               If .FilterOn Or .Filter <> vWhere Then 
118                  .Filter = vWhere 
119                  .FilterOn = True 
120               End If   'filter needs to change 
121            Else 
122               If .FilterOn Then .FilterOn = False 
123            End If 
124         End With 
125     
126      Proc_Exit: 
127         On Error Resume Next 
128         Exit Function 
129     
130      Proc_Err: 
131         MsgBox Err.Description, , _ 
132              "ERROR " & Err.Number _ 
133              & "   FilterMe : " & Me.Name 
134     
135         Resume Proc_Exit 
136         Resume 
137      End Function 
138     
139     
140     
141     
      Goto Top       Goto Form_f_ITM       Goto Index

Form_f_ITMs (137)

PROCEDURES       Goto Top       Goto Form_f_ITMs       Goto Forms       Goto Index
  1. cmd_Clear_fltr_ItmID__Click (6)
  2. cmd_Close_Click (6)
  3. Declaration Lines (28)
  4. FilterMe (58)
  5. fltr_ItmID__AfterUpdate (5)
  6. Fnd_ItmID_Code_AfterUpdate (5)
  7. Fnd_ItmID_Name_AfterUpdate (7)
  8. Fnd_ItmID_SupCode_AfterUpdate (5)
  9. Form_BeforeUpdate (5)
  10. ItmCode_DblClick (5)
  11. OpenTheItem (7)

Declaration Lines (28)

1        Option Compare Database 
2        Option Explicit 
3         '============================================================ LICENSE NOTICE -- must not be modified
4         ' This software is licensed to you under CC BY-NC-SA 3.0
5         '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
6         ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
7         '
8         ' You are free to:
9         '    Share  copy and redistribute the material in any medium or format
10        '    Adapt  remix, transform, and build upon the material
11        ' The licensor cannot revoke these freedoms as long as you follow these terms:
12        '    Attribution  You must give appropriate credit, provide a link to the license,
13        '                   and indicate if changes were made.
14        '                   You may do so in any reasonable manner,
15        '                   but not in any way that suggests the licensor endorses you or your use.
16        '    NonCommercial  You may not use the material for commercial purposes.
17        '    ShareAlike  If you remix, transform, or build upon the material,
18        '                 you must distribute your contributions under the same license as the original.
19        '
20        ' many procedures and module names contain author or controbitor names that must be left intact
21        ' if you make changes, add your name, date, and descriptive information to the comments
22        '
23        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629
24        ' ~ Crystal
25        '              * have an awesome day :)
26        '                                                   www.AccessMVP.com/strive4peace
27        ' END LICENSE NOTICE
28        '============================================================
      Goto Top       Goto Form_f_ITMs       Goto Index

cmd_Close_Click (6)

29      
30      
31       Private Sub cmd_Close_Click() 
32        '140701
33          DoCmd.Close acForm, Me.Name, acSaveNo 
34       End Sub 
      Goto Top       Goto Form_f_ITMs       Goto Index

fltr_ItmID__AfterUpdate (5)

35      
36       Private Sub fltr_ItmID__AfterUpdate() 
37        '140701
38          Call FilterMe 
39       End Sub 
      Goto Top       Goto Form_f_ITMs       Goto Index

Fnd_ItmID_Code_AfterUpdate (5)

40      
41       Private Sub Fnd_ItmID_Code_AfterUpdate() 
42        '140701
43          Call FindRecordN(Me, "ItmID", "ItmName") 
44       End Sub 
      Goto Top       Goto Form_f_ITMs       Goto Index

Fnd_ItmID_Name_AfterUpdate (7)

45      
46      
47      
48       Private Sub Fnd_ItmID_Name_AfterUpdate() 
49        '140701
50          Call FindRecordN(Me, "ItmID", "ItmName") 
51       End Sub 
      Goto Top       Goto Form_f_ITMs       Goto Index

Fnd_ItmID_SupCode_AfterUpdate (5)

52      
53       Private Sub Fnd_ItmID_SupCode_AfterUpdate() 
54        '140701
55          Call FindRecordN(Me, "ItmID", "ItmName") 
56       End Sub 
      Goto Top       Goto Form_f_ITMs       Goto Index

cmd_Clear_fltr_ItmID__Click (6)

57      
58       Private Sub cmd_Clear_fltr_ItmID__Click() 
59        '140701
60          Me.fltr_ItmID_ = Null 
61          Call FilterMe 
62       End Sub 
      Goto Top       Goto Form_f_ITMs       Goto Index

FilterMe (58)

63      
64       Private Function FilterMe() As Boolean 
65        '140701
66           'CALLS
67           '  SetControl_RowSource
68           '
69           'Called By
70           '  cmd_Clear_fltr_ItmID_
71           '  fltr_ItmID_
72      
73          On Error GoTo Proc_Err 
74      
75          Dim sSQL As String _ 
76             , vWhere As Variant _ 
77             , sOrderBy As String _ 
78             , sEqn_Fullname As String _ 
79             , iPos1 As Integer _ 
80             , iPos2 As Integer 
81      
82          vWhere = Null 
83      
84           '-------------------------- Filter
85          With Me.fltr_ItmID_ 
86             If Not IsNull(.Value) Then 
87                vWhere = (vWhere + " AND ") & "i.ItmID_=" & .Value 
88             Else 
89                vWhere = "" 
90             End If 
91          End With 
92      
93           ' other FIND combo and listbox rowsources
94          Call SetControl_RowSource(Me.Fnd_ItmID_Code, vWhere) 
95          Call SetControl_RowSource(Me.Fnd_ItmID_Name, vWhere) 
96          Call SetControl_RowSource(Me.Fnd_ItmID_SupCode, vWhere) 
97      
98          With Me 
99             If Len(vWhere) > 0 Then 
100               If .FilterOn Or .Filter <> vWhere Then 
101                  .Filter = vWhere 
102                  .FilterOn = True 
103               End If   'filter needs to change 
104            Else 
105               If .FilterOn Then .FilterOn = False 
106            End If 
107         End With 
108     
109      Proc_Exit: 
110         On Error Resume Next 
111         Exit Function 
112     
113      Proc_Err: 
114         MsgBox Err.Description, , _ 
115              "ERROR " & Err.Number _ 
116              & "   FilterMe : " & Me.Name 
117     
118         Resume Proc_Exit 
119         Resume 
120      End Function 
      Goto Top       Goto Form_f_ITMs       Goto Index

Form_BeforeUpdate (5)

121     
122      Private Sub Form_BeforeUpdate(Cancel As Integer) 
123       '140701
124         Me.dtmEdit = Now() 
125      End Sub 
      Goto Top       Goto Form_f_ITMs       Goto Index

OpenTheItem (7)

126     
127      Private Sub OpenTheItem() 
128       '140701
129         If Me.Dirty Then Me.Dirty = False 
130         If Me.NewRecord Then Exit Sub 
131         DoCmd.OpenForm "f_ITM", , , , , , Me.ItmID 
132      End Sub 
      Goto Top       Goto Form_f_ITMs       Goto Index

ItmCode_DblClick (5)

133     
134      Private Sub ItmCode_DblClick(Cancel As Integer) 
135       '140701`
136         Call OpenTheItem 
137      End Sub 
      Goto Top       Goto Form_f_ITMs       Goto Index

Form_f_MAIN_MENU (93)

PROCEDURES       Goto Top       Goto Form_f_MAIN_MENU       Goto Forms       Goto Index
  1. cmd_Anywhere_Click (5)
  2. cmd_Contacts_Click (8)
  3. cmd_Customer_Click (9)
  4. cmd_Demo_Click (4)
  5. cmd_Employees_Click (9)
  6. cmd_Followup_Click (4)
  7. cmd_Prospects_Click (9)
  8. cmd_Vendors_Click (9)
  9. Declaration Lines (28)
  10. Form_Open (8)

Declaration Lines (28)

1        Option Compare Database 
2        Option Explicit 
3         '============================================================ LICENSE NOTICE -- must not be modified
4         ' This software is licensed to you under CC BY-NC-SA 3.0
5         '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
6         ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
7         '
8         ' You are free to:
9         '    Share  copy and redistribute the material in any medium or format
10        '    Adapt  remix, transform, and build upon the material
11        ' The licensor cannot revoke these freedoms as long as you follow these terms:
12        '    Attribution  You must give appropriate credit, provide a link to the license,
13        '                   and indicate if changes were made.
14        '                   You may do so in any reasonable manner,
15        '                   but not in any way that suggests the licensor endorses you or your use.
16        '    NonCommercial  You may not use the material for commercial purposes.
17        '    ShareAlike  If you remix, transform, or build upon the material,
18        '                 you must distribute your contributions under the same license as the original.
19        '
20        ' many procedures and module names contain author or controbitor names that must be left intact
21        ' if you make changes, add your name, date, and descriptive information to the comments
22        '
23        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629
24        ' ~ Crystal
25        '              * have an awesome day :)
26        '                                                   www.AccessMVP.com/strive4peace
27        ' END LICENSE NOTICE
28        '============================================================
      Goto Top       Goto Form_f_MAIN_MENU       Goto Index

cmd_Anywhere_Click (5)

29      
30       Private Sub cmd_Anywhere_Click() 
31        '131002
32          DoCmd.OpenForm "f_AnywhereMENU" 
33       End Sub 
      Goto Top       Goto Form_f_MAIN_MENU       Goto Index

cmd_Contacts_Click (8)

34      
35       Private Sub cmd_Contacts_Click() 
36        '131001, 131010
37          If Not FoundBackEnd("c_KeepOpen") Then 
38             Exit Sub 
39          End If 
40          DoCmd.OpenForm "fc_MENU_CONTACT" 
41       End Sub 
      Goto Top       Goto Form_f_MAIN_MENU       Goto Index

cmd_Customer_Click (9)

42      
43       Private Sub cmd_Customer_Click() 
44        '131002, 131010
45          If Not FoundBackEnd("c_KeepOpen") Then 
46             Exit Sub 
47          End If 
48      
49          DoCmd.OpenForm "f_CUSTOMER" 
50       End Sub 
      Goto Top       Goto Form_f_MAIN_MENU       Goto Index

cmd_Demo_Click (4)

51      
52       Private Sub cmd_Demo_Click() 
53       MsgBox "under construction" 
54       End Sub 
      Goto Top       Goto Form_f_MAIN_MENU       Goto Index

cmd_Employees_Click (9)

55      
56       Private Sub cmd_Employees_Click() 
57        '131002, 131010
58          If Not FoundBackEnd("c_KeepOpen") Then 
59             Exit Sub 
60          End If 
61      
62          DoCmd.OpenForm "f_EMPLOYEE" 
63       End Sub 
      Goto Top       Goto Form_f_MAIN_MENU       Goto Index

cmd_Followup_Click (4)

64      
65       Private Sub cmd_Followup_Click() 
66       MsgBox "under construction" 
67       End Sub 
      Goto Top       Goto Form_f_MAIN_MENU       Goto Index

cmd_Prospects_Click (9)

68      
69       Private Sub cmd_Prospects_Click() 
70        '131002, 131010
71          If Not FoundBackEnd("c_KeepOpen") Then 
72             Exit Sub 
73          End If 
74      
75          DoCmd.OpenForm "f_PROSPECT" 
76       End Sub 
      Goto Top       Goto Form_f_MAIN_MENU       Goto Index

cmd_Vendors_Click (9)

77      
78       Private Sub cmd_Vendors_Click() 
79        '131002, 131010
80          If Not FoundBackEnd("c_KeepOpen") Then 
81             Exit Sub 
82          End If 
83      
84          DoCmd.OpenForm "f_VENDOR" 
85       End Sub 
      Goto Top       Goto Form_f_MAIN_MENU       Goto Index

Form_Open (8)

86      
87       Private Sub Form_Open(Cancel As Integer) 
88        '131001
89          On Error Resume Next 
90          Call Custom_SetDefaultProperties 
91          Call SetPathAttachment(CurrentProject.Path) 
92      
93       End Sub 
      Goto Top       Goto Form_f_MAIN_MENU       Goto Index

Form_f_MENU_HTMLCalendar (2077)

PROCEDURES       Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Forms       Goto Index
  1. ASDay (14)
  2. ASMonth (6)
  3. ASYear (6)
  4. btn1_Click (16)
  5. btnClearDates_Click (7)
  6. btnClearEmail_Click (5)
  7. cal_MoAdd_Click (5)
  8. cal_Month_Click (5)
  9. cal_MoSub_Click (5)
  10. cal_MTD_Click (5)
  11. cal_Q1_Click (5)
  12. cal_Q2_Click (5)
  13. cal_Q3_Click (5)
  14. cal_Q4_Click (5)
  15. cal_Today_Click (5)
  16. cal_Week_Click (5)
  17. cal_WorkWeek_Click (5)
  18. cal_YrAdd_Click (5)
  19. cal_YrSub_Click (5)
  20. CalTitle_DblClick (5)
  21. CheckDates (40)
  22. CheckEmailOptions (14)
  23. chkOpen_AfterUpdate (4)
  24. ClearList (7)
  25. CloseMeMe (8)
  26. cmdAdd_eMail_Click (7)
  27. Color3_AfterUpdate (5)
  28. Color3B_AfterUpdate (5)
  29. ColorMe (18)
  30. Create_HTMLCalendar (533)
  31. createXLSfile (14)
  32. Date1_DblClick (5)
  33. Date2_DblClick (5)
  34. Declaration Lines (23)
  35. Edit_TQ (17)
  36. EmailAddress_AfterUpdate (5)
  37. EmailTheReport (12)
  38. Examples1_DblClick (4)
  39. Examples2_DblClick (4)
  40. Examples3_DblClick (4)
  41. Examples4_DblClick (4)
  42. Field1_AfterUpdate (4)
  43. Field2_AfterUpdate (4)
  44. Field3_AfterUpdate (5)
  45. Field4_AfterUpdate (6)
  46. FillDate (7)
  47. FillMonth (6)
  48. FillMTD (6)
  49. FillOneWeek (6)
  50. FillOneYear (6)
  51. FillQuarter (9)
  52. FillWorkWeek (7)
  53. FillYTD (6)
  54. Form_Load (27)
  55. fraOutput_AfterUpdate (26)
  56. FraTQ_AfterUpdate (4)
  57. Generate_Index (128)
  58. Generate_Index_TOC (84)
  59. html_EndTime (8)
  60. html_StartTime (9)
  61. label_Footer1_DblClick (4)
  62. label_Footer2_DblClick (4)
  63. label_Footer3_DblClick (4)
  64. label_Footer4_DblClick (4)
  65. Label_writtenBy_Click (6)
  66. ListTQ_AfterUpdate (5)
  67. ListTQ_DblClick (5)
  68. NewFooterText (13)
  69. PopCalendarAndDoStuff (31)
  70. Report_Calendar (136)
  71. ResetData (59)
  72. RFTtheReport (33)
  73. setCritDates (65)
  74. SQL_Examples (255)
  75. SQL_Fields (116)
  76. SQL_TQ (48)
  77. UnderConstruction (4)
  78. WriteHTMLfooter (26)
  79. WriteHTMLheader (39)

Declaration Lines (23)

1        Option Compare Database 
2        Option Explicit 
3        Option Base 1   'set arrays to start with 1 instead of 0 
4       
5         'crystal
6         'strive4peace2004@yahoo.ca
7         'modified 6-18-05
8          '5-15-06, 140929
9       
10        '  main routine: Report_Calendar
11      
12        'usys_REPORTMENU_Calendar
13        'CALLS
14        '   MkDir
15      
16      
17       Dim mvCrit As Variant _ 
18       , msUserCriteria As String 
19      
20       Dim gStartTime As Date 
21      
22      
23       Const gNUMREPORTS As Integer = 1   '1 = Calendar Report (the ONLY report) -- used to color command button(s) 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

btnClearDates_Click (7)

24      
25      
26       Private Sub btnClearDates_Click() 
27        '140929
28          Me.Date1 = Null 
29          Me.Date2 = Null 
30       End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

cal_MoAdd_Click (5)

31      
32       Private Sub cal_MoAdd_Click() 
33        '140930
34          Call ASMonth(1) 
35       End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

cal_Month_Click (5)

36      
37       Private Sub cal_Month_Click() 
38        '140930
39          Call FillMonth 
40       End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

cal_MoSub_Click (5)

41      
42       Private Sub cal_MoSub_Click() 
43        '140930
44          Call ASMonth(-1) 
45       End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

cal_MTD_Click (5)

46      
47       Private Sub cal_MTD_Click() 
48        '140930
49          Call FillMTD 
50       End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

cal_Q1_Click (5)

51      
52       Private Sub cal_Q1_Click() 
53        '140930
54          Call FillQuarter(1) 
55       End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

cal_Q2_Click (5)

56      
57       Private Sub cal_Q2_Click() 
58        '140930
59          Call FillQuarter(2) 
60       End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

cal_Q3_Click (5)

61      
62       Private Sub cal_Q3_Click() 
63        '140930
64          Call FillQuarter(3) 
65       End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

cal_Q4_Click (5)

66      
67       Private Sub cal_Q4_Click() 
68        '140930
69          Call FillQuarter(4) 
70       End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

cal_Today_Click (5)

71      
72       Private Sub cal_Today_Click() 
73        '140930
74          Call FillDate(Date) 
75       End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

cal_Week_Click (5)

76      
77       Private Sub cal_Week_Click() 
78        '140930
79          Call FillOneWeek 
80       End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

cal_WorkWeek_Click (5)

81      
82       Private Sub cal_WorkWeek_Click() 
83        '140930
84          Call FillWorkWeek 
85       End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

cal_YrAdd_Click (5)

86      
87       Private Sub cal_YrAdd_Click() 
88        '140929
89          Call ASYear(1) 
90       End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

cal_YrSub_Click (5)

91      
92       Private Sub cal_YrSub_Click() 
93        '140929
94          Call ASYear(-1) 
95       End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

CalTitle_DblClick (5)

96      
97       Private Sub CalTitle_DblClick(Cancel As Integer) 
98        '140929
99          Call CorrectCase 
100      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

chkOpen_AfterUpdate (4)

101     
102      Private Sub chkOpen_AfterUpdate() 
103      Call BoldMe 
104      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Color3_AfterUpdate (5)

105     
106      Private Sub Color3_AfterUpdate() 
107       '140930
108         Call ColorMe 
109      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Color3B_AfterUpdate (5)

110     
111      Private Sub Color3B_AfterUpdate() 
112       '140930
113         Call ColorMe 
114      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

ColorMe (18)

115     
116      Private Sub ColorMe() 
117       '140930
118         Dim sColor As String 
119     
120     
121         With Me.ActiveControl 
122            If IsNull(.Value) Then 
123               sColor = "000000" 
124               Me.ActiveControl.Value = "000000" 
125            Else 
126               sColor = .Value 
127            End If 
128            .Controls(0).ForeColor = RGB(CLng("&H" & Left(sColor, 2)) _ 
129                                          , CLng("&H" & Mid(sColor, 3, 2)) _ 
130                                          , CLng("&H" & Right(sColor, 2))) 
131         End With 
132      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Date1_DblClick (5)

133     
134      Private Sub Date1_DblClick(Cancel As Integer) 
135       '140929
136         Call open_Form("f_PopupCalendar") 
137      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Date2_DblClick (5)

138     
139      Private Sub Date2_DblClick(Cancel As Integer) 
140       '140929
141         Call open_Form("f_PopupCalendar") 
142      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

EmailAddress_AfterUpdate (5)

143     
144      Private Sub EmailAddress_AfterUpdate() 
145       '140929
146         Call CheckEmailOptions 
147      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Examples1_DblClick (4)

148     
149      Private Sub Examples1_DblClick(Cancel As Integer) 
150      Call RequeryMe 
151      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Examples2_DblClick (4)

152     
153      Private Sub Examples2_DblClick(Cancel As Integer) 
154      Call RequeryMe 
155      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Examples3_DblClick (4)

156     
157      Private Sub Examples3_DblClick(Cancel As Integer) 
158      Call RequeryMe 
159      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Examples4_DblClick (4)

160     
161      Private Sub Examples4_DblClick(Cancel As Integer) 
162      Call RequeryMe 
163      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Field1_AfterUpdate (4)

164     
165      Private Sub Field1_AfterUpdate() 
166      Call SQL_Examples 
167      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Field2_AfterUpdate (4)

168     
169      Private Sub Field2_AfterUpdate() 
170      Call SQL_Examples 
171      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Field3_AfterUpdate (5)

172     
173      Private Sub Field3_AfterUpdate() 
174       'MsgBox Me.Field3.Column(0) ' ---------------- error
175         Call SQL_Examples 
176      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

btn1_Click (16)

177     
178     
179      Private Sub btn1_Click() 
180       '130814, 140929
181         On Error GoTo Proc_Err 
182     
183         Call Report_Calendar 
184      Proc_Exit: 
185         On Error Resume Next 
186         Exit Sub 
187     
188      Proc_Err: 
189         MsgBox Err.Description, , _ 
190              "ERROR " & Err.Number _ 
191              & "   btn1_Click : " & Me.Name 
192      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Field4_AfterUpdate (6)

193     
194     
195     
196      Private Sub Field4_AfterUpdate() 
197      Call SQL_Examples 
198      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Form_Load (27)

199     
200      Private Sub Form_Load() 
201         On Error GoTo Proc_Err 
202     
203         Call ResetData 
204         Me.fraOutput = 1 
205     
206         Dim nColor As Long _ 
207            , i As Integer 
208     
209         nColor = 8388608 
210         For i = 1 To gNUMREPORTS 
211            Me("btn" & i).BackColor = nColor 
212         Next i 
213         SQL_TQ 1 
214     
215      Proc_Exit: 
216         Exit Sub 
217     
218       'if there is an error, the following code will execute
219      Proc_Err: 
220         MsgBox Err.Description, , "ERROR " & Err.Number & "   SQL_TQ " 
221          'press F8 to step through code and debug
222          'remove next line after debugged
223         Stop:    Resume 
224         Resume Proc_Exit 
225      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

SQL_TQ (48)

226     
227     
228       '------------------------------------------------------ SQL_TQ
229     
230      Private Function SQL_TQ(pWhich As Integer) 
231         On Error GoTo Proc_Err 
232     
233         Dim s As String, i As Integer, mType As Long 
234         s = "" 
235     
236         Me.SQL_ListTQ.Visible = IIf(pWhich = 2, True, False) 
237     
238         Call ResetData 
239     
240         If pWhich = 2 Then 
241             'Queries
242            mType = 5 
243         Else 
244             'Tables
245            mType = 1 
246         End If 
247     
248         s = "SELECT M.Name, M.DateCreate, M.DateUpdate " _ 
249            & " FROM MSysObjects AS M " _ 
250            & " WHERE ((m.Type = " & mType _ 
251               & ") And (Left([Name], 1) <> '~') And (Left([Name], 4) <> 'msys')) " _ 
252            & " ORDER BY M.Name;" 
253     
254       '~~~CL
255         Me.btn1.SetFocus 
256     
257         Me.ListTQ = Null 
258         Me.ListTQ.RowSource = s 
259         Me.ListTQ.Requery 
260     
261         DoEvents 
262     
263      Proc_Exit: 
264         Exit Function 
265     
266       'if there is an error, the following code will execute
267      Proc_Err: 
268         MsgBox Err.Description, , "ERROR " & Err.Number & "   SQL_TQ " & pWhich 
269          'press F8 to step through code and debug
270          'remove next line after debugged
271         Stop:    Resume 
272         Resume Proc_Exit 
273      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

SQL_Fields (116)

274     
275       '------------------------------------------------------ SQL_Fields
276      Private Function SQL_Fields() 
277     
278         On Error GoTo Proc_Err 
279     
280         Dim i As Integer _ 
281            , iList As Integer _ 
282            , sName As String _ 
283            , sSQL As String _ 
284            , nType As Long _ 
285            , boo As Boolean _ 
286            , sListType As String 
287     
288         sSQL = "" 
289         If IsNull(Me.ListTQ) Then sName = "" 
290         sName = Me.ListTQ 
291         Me.SQL_ListTQ = "" 
292     
293         Me.label_FooterCalc1.Visible = False 
294         Me.label_FooterCalc2.Visible = False 
295         Me.prompt_FooterCalc1.Visible = False 
296         Me.prompt_FooterCalc2.Visible = False 
297     
298         Me.label_Footer1.Visible = False 
299         Me.prompt_Footer1.Visible = False 
300         Me.label_Footer2.Visible = False 
301         Me.prompt_Footer2.Visible = False 
302         Me.label_Footer3.Visible = False 
303         Me.prompt_Footer3.Visible = False 
304     
305         For iList = 1 To 4 
306            Select Case iList 
307               Case 1: sListType = "Date" 
308               Case 2: sListType = "Long" 
309               Case 3: sListType = "" 
310               Case 4: sListType = "Number" 
311            End Select 
312            sSQL = "" 
313            If Nz(Me.FraTQ, 1) = 2 Then 
314                'Queries
315               With CurrentDb.QueryDefs(sName) 
316                  For i = 0 To .Fields.Count - 1 
317                     nType = Nz(.Fields(i).Type) 
318                     boo = False 
319                     Select Case Trim(sListType) 
320                        Case "": boo = True 
321                        Case "Text": If nType = 10 Or nType = 12 Then boo = True 
322                        Case "Number": If nType >= 1 And nType <= 7 Then boo = True 
323                        Case "Date": If nType = 8 Then boo = True 
324                        Case "Long": If nType = 4 Then boo = True 
325                     End Select 
326                     If boo And Len(Trim(sName)) > 0 Then 
327                        sSQL = sSQL & """" & .Fields(i).Name & """;" 
328                        sSQL = sSQL & """" & GetDataType(nType) & """;" 
329                        sSQL = sSQL & nType & ";" 
330                        sSQL = sSQL & .Fields(i).SourceTable _ 
331                           & ("." + .Fields(i).SourceField) _ 
332                           & ";" 
333                     End If 
334                  Next i 
335               End With 
336            Else 
337                'Tables
338               With CurrentDb.TableDefs(sName) 
339                  For i = 0 To .Fields.Count - 1 
340                     nType = .Fields(i).Type 
341                     boo = False 
342                     Select Case Trim(sListType) 
343                        Case "": boo = True 
344                        Case "Text": If nType = 10 Or nType = 12 Then boo = True 
345                        Case "Number": If nType >= 1 And nType <= 7 Then boo = True 
346                        Case "Date": If nType = 8 Then boo = True 
347                        Case "Long": If nType = 4 Then boo = True 
348                     End Select 
349                     If boo And Len(Trim(sName)) > 0 Then 
350                        sSQL = sSQL & """" & .Fields(i).Name & """;" 
351                        sSQL = sSQL & """" & GetDataType(nType) & """;" 
352                        sSQL = sSQL & nType & ";" 
353                        sSQL = sSQL & .Fields(i).SourceTable _ 
354                           & "." & .Fields(i).SourceField _ 
355                           & ";" 
356                     End If 
357                  Next i 
358               End With   'CurrentDb.TableDefs(sName) 
359            End If 
360            Me("Field" & iList) = Null 
361            Me("Field" & iList).RowSource = sSQL 
362            Me("Field" & iList).Requery 
363     
364            Me("Examples" & iList) = Null 
365            Me("Examples" & iList).RowSource = "" 
366            Me("Examples" & iList).Requery 
367         Next iList 
368     
369         If Me.FraTQ = 2 Then 
370            Me.SQL_ListTQ = Nz(CurrentDb.QueryDefs(Me.[ListTQ]).SQL) 
371         Else 
372            Me.SQL_ListTQ = sName 
373         End If 
374     
375         Me.fraSumcount = 3 
376         Me.fraSumcount.Enabled = False 
377         Me.Label_fraSumcount.Visible = False 
378     
379      Proc_Exit: 
380     
381         Exit Function 
382     
383      Proc_Err: 
384         MsgBox Err.Description, , "ERROR " & Err.Number & "   SQL_Fields" 
385          'press F8 to step through code and fix problem
386         Stop:   Resume 
387         Resume Proc_Exit 
388     
389      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

SQL_Examples (255)

390     
391     
392       '------------------------------------------------------ SQL_Examples
393      Private Function SQL_Examples() 
394       'on AfterUpdate event of each Field List
395       '140930 counts to get better equation
396     
397         On Error GoTo Proc_Err 
398     
399     
400         Dim sSQL As String _ 
401            , sFld As String _ 
402            , sControlnameList As String _ 
403            , sSource As String _ 
404            , sDateField As String 
405     
406         Dim iListNum As Integer _ 
407            , boo As Boolean _ 
408            , sAlias As String 
409         Dim iNum3 As Integer _ 
410            , sFieldname As String 
411     
412         Dim iPos1 As Integer _ 
413            , iPos2 As Integer _ 
414            , i As Integer _ 
415            , sChar As String * 1 
416             ', booInDelimited As Boolean _
417     
418         Dim iCountBracket As Integer _ 
419            , iCountParenthesis As Integer _ 
420            , iCountSingleQuote As Integer _ 
421            , iCountDoubleQuote As Integer _ 
422            , iCount As Integer 
423     
424         Dim varItem As Variant 
425     
426         sControlnameList = Me.ActiveControl.Name 
427         iListNum = CInt(Right(sControlnameList, 1)) 
428         DoEvents 
429     
430         Me.btn1.SetFocus 
431     
432       '~CL
433         sFld = "" 
434         sAlias = "" 
435         sSQL = "" 
436     
437         iNum3 = 0 
438         sFieldname = "" 
439         sSource = "" 
440     
441         Select Case iListNum 
442     
443         Case 1, 2 
444     
445            boo = IsNull(Me.Field2.Column(0)) 
446     
447            Me.label_FooterCalc1.Visible = boo 
448            Me.prompt_FooterCalc1.Visible = boo 
449     
450            Me.label_Footer1.Visible = boo 
451            Me.prompt_Footer1.Visible = boo 
452            Me.label_Footer2.Visible = boo 
453            Me.prompt_Footer2.Visible = boo 
454     
455            boo = True 
456     
457            If IsNull(Me("Field" & iListNum)) Then 
458                GoTo Assign_RowSource 
459            End If 
460     
461            sFieldname = Me("Field" & iListNum) 
462            sFld = "[" & sFieldname & "]" 
463     
464         Case 3 
465             'multi-select listbox
466            With Me.Field3 
467               For Each varItem In .ItemsSelected 
468     
469                   sFld = sFld & "Trim([" _ 
470                     & .ItemData(varItem) & "]) & ' ' & " 
471     
472                   sFieldname = .ItemData(varItem) 
473     
474                   sSource = Trim(Nz(.Column(3, varItem))) 
475     
476                   sAlias = sAlias & Trim(.ItemData(varItem)) & "_" 
477     
478                   iNum3 = iNum3 + 1 
479               Next varItem 
480            End With   'Field3 
481     
482            If Len(sFld) = 0 Then 
483               Me.Field3eqn = Null 
484               Me.Field3Alias = Null 
485               GoTo Assign_RowSource 
486            End If 
487     
488            sFld = "(" & Left(sFld, Len(sFld) - 9) & ")" 
489            boo = True 
490     
491            If iNum3 = 1 Then   'if there is only one field, do it this way instead 
492               sFld = "[" & sFieldname & "]" 
493            End If 
494     
495            Me.Field3eqn = sFld 
496            Me.Field3Alias = IIf(Len(sAlias) = 0, Nz(Me.Source3, ""), sAlias) 
497     
498         Case 4 
499            boo = IIf(IsNull(Me.Field4), False, True) 
500     
501            Me.fraSumcount.Enabled = boo 
502            Me.Label_fraSumcount.Visible = boo 
503            Me.label_FooterCalc2.Visible = boo 
504            Me.label_Footer3.Visible = boo 
505            Me.prompt_Footer3.Visible = boo 
506            sFieldname = Me.Field4 
507            sFld = "[" & Me.Field4 & "]" 
508     
509         End Select 
510     
511         If sSource = "" Then sSource = Trim(Nz(Me(sControlnameList).Column(3))) 
512     
513         If Not boo Then GoTo Assign_RowSource 
514         If IsNull(Me.ListTQ) Then GoTo Assign_RowSource 
515     
516         sSQL = "SELECT DISTINCT " 
517     
518         If iListNum = 3 Then 
519            sSQL = sSQL & sFld & IIf(Len(sAlias) > 0, " as " & sAlias, "") & " " 
520         Else 
521            If Nz(Me(sControlnameList).Column(1)) <> "Memo" Then 
522               sSQL = sSQL & sFld 
523            Else 
524               sSQL = sSQL & "Trim(Left(" & sFld & " & space(50),50)) as [" & sFld & "_Left50] " 
525            End If 
526         End If 
527     
528         sSQL = sSQL _ 
529            & " FROM [" & Me.ListTQ & "]" _ 
530            & " WHERE ((" & sFld & ") Is Not Null)" 
531     
532         If Not IsNull(Me.Date1) Then 
533            If Not IsNull(Me.Field1.Column(0)) Then 
534               sDateField = Me.Field1.Column(0) 
535               sSQL = sSQL & " AND format([" & sDateField & "],""yymm"") =""" _ 
536                  & Format(Me.Date1, "yymm") & """" 
537     
538            End If 
539     
540         End If 
541     
542         If iListNum = 1 Or iListNum = 4 Then 
543            sSQL = sSQL & " ORDER BY " & sFld & " desc" 
544         End If 
545     
546         sSQL = sSQL & ";" 
547     
548      Assign_RowSource: 
549     
550      Debug.Print "--  Example " & iListNum & " -- " & Format(Now, "m-d-yy h:nn") 
551      Debug.Print sSQL 
552     
553         Me("Examples" & iListNum) = Null 
554         Me("Examples" & iListNum).RowSource = sSQL 
555         Me("Examples" & iListNum).Requery 
556     
557         Me("Source" & iListNum) = sSource 
558         If sSQL = "" Then GoTo Proc_Exit 
559     
560         If Me.FraTQ = 1 Then GoTo Proc_Exit 
561     
562          'if sourceField was not determined, this will be tablename.
563         If Right(sSource, 1) <> "." Then GoTo Proc_Exit 
564     
565         If iNum3 > 1 Then 
566            Me.Source3 = Null 
567            GoTo Proc_Exit 
568         End If 
569     
570          'search SQL string for equation
571     
572         sSQL = Me.SQL_ListTQ 
573     
574       '------------------------------------- HERE get equation '140930
575     
576     
577         iCountBracket = 0 
578         iCountParenthesis = 0 
579         iCountSingleQuote = 0 
580         iCountDoubleQuote = 0 
581         iCount = 0 
582     
583         iPos2 = InStr(sSQL, " as " & sFieldname) 
584     
585         If iPos2 = 0 Then 
586            iPos2 = InStr(sSQL, " as [" & sFieldname & "]") 
587         End If 
588     
589         If iPos2 = 0 Then 
590            iPos2 = InStr(sSQL, " as " & sFld) 
591            If iPos2 = 0 Then 
592                'this shouldn't happen
593               Me.Source1 = "" 
594               GoTo Proc_Exit 
595            End If 
596         End If 
597     
598       '   booInDelimited = False
599         For i = (iPos2 - 1) To 1 Step -1 
600            sChar = Mid(sSQL, i, 1) 
601            Select Case sChar 
602            Case "[": iCountBracket = iCountBracket - 1 
603            Case "]": iCountBracket = iCountBracket + 1 
604            Case "(": iCountParenthesis = iCountParenthesis - 1 
605            Case ")": iCountParenthesis = iCountParenthesis + 1 
606            Case "'": iCountSingleQuote = iCountSingleQuote + 1 
607            Case """": iCountDoubleQuote = iCountDoubleQuote + 1 
608            End Select 
609     
610            iCount = iCountBracket + iCountParenthesis _ 
611               + iCountSingleQuote Mod 2 _ 
612               + iCountDoubleQuote Mod 2 
613     
614            If iCount = 0 Then 
615               If sChar = "," Then 
616                  iPos1 = i + 1 
617                  Me("Source" & iListNum) = Trim(Mid(sSQL, iPos1, iPos2 - iPos1)) 
618                  Exit Function 
619               End If 
620            End If 
621       '      If InStr("""'", sChar) > 0 Then
622       '         booInDelimited = Not booInDelimited
623       '      Else
624       '         If sChar = "[" Then
625       '            booInDelimited = False
626       '         Else
627       '            If sChar = "]" Then booInDelimited = True
628       '         End If
629       '      End If
630         Next i 
631         iPos1 = 8 
632         Me("Source" & iListNum) = Trim(Mid(sSQL, iPos1, iPos2 - iPos1)) 
633     
634      Proc_Exit: 
635         Exit Function 
636     
637      Proc_Err: 
638         MsgBox Err.Description, , "ERROR " & Err.Number & "   SQL_TQ " & iListNum 
639          'press F8 to step through code and debug
640          'remove next line after debugged
641         Stop:    Resume 
642         Resume Proc_Exit 
643     
644      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

PopCalendarAndDoStuff (31)

645     
646     
647       '------------------------------------------------------ ProcessReport
648       'Private Function ProcessReport()
649       '   'not used -- serves as an example...
650       '   'initialize the variable
651       '   mvCrit = Null
652       '   msUserCriteria = ""
653       '   Dim mReport As String
654       '   mReport = "ReportName"
655       '
656       '   Me.crit = msUserCriteria
657       '   On Error Resume Next
658       '
659       '   If Len(mvCrit) > 0 Then
660       '      DoCmd.OpenReport mReport, acViewPreview, , mvCrit
661       '   Else
662       '      DoCmd.OpenReport mReport, acViewPreview
663       '   End If
664       '
665       'End Function
666     
667       '------------------------------------------------------ PopCalendarAndDoStuff
668      Private Function PopCalendarAndDoStuff() 
669          'double-click event of Date1 or Date2
670          'pop up the calendar and wait for user to close before continuing
671          'the acDialog parameter causes code to STOP
672          'until the user closes the specified form, PickDate
673         DoCmd.OpenForm "PickDate", , , , , acDialog 
674          'now you can do other things in your code
675      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

setCritDates (65)

676     
677       '------------------------------------------------------ setCritDates
678      Private Function setCritDates(psMethod As String, psDateField As String) As Boolean 
679     
680         setCritDates = False 
681     
682         Dim nDate As Date 
683         Select Case psMethod 
684     
685         Case "Month" 
686            If Not CheckDates("1") Then Exit Function 
687            nDate = Me.Date1 
688            Me.Date1 = DateSerial(Year(nDate), Month(nDate), 1) 
689            Me.Date2 = DateSerial(Year(nDate), Month(nDate) + 1, 0) 
690     
691         Case "Months" 
692            If Not CheckDates("1") Then Exit Function 
693            nDate = Me.Date1 
694            Me.Date1 = DateSerial(Year(nDate), Month(nDate), 1) 
695     
696            If Not IsNull(Me.Date2) Then nDate = Me.Date2 
697            Me.Date2 = DateSerial(Year(nDate), Month(nDate) + 1, 0) 
698     
699         Case "1" 
700            If Not CheckDates("1") Then Exit Function 
701     
702         Case "2" 
703            If Not CheckDates("2") Then Exit Function 
704     
705         Case "optional" 
706            If IsNull(Me.Date1) And IsNull(Me.Date2) Then Exit Function 
707     
708         End Select 
709     
710          '----------------------------------------------- Dates
711         Dim nDateField 
712         If IsMissing(psDateField) Then nDateField = "WorkDate" Else nDateField = psDateField 
713     
714     
715         Select Case True 
716         Case (Not IsNull(Me.Date1)) And (Not IsNull(Me.Date2)) 
717            mvCrit = (mvCrit + " AND ") _ 
718               & "(" & nDateField & " BETWEEN #" & Me.Date1 & "# AND #" & Me.Date2 & "#)" 
719            msUserCriteria = msUserCriteria & "  " _ 
720               & nDateField & ": " & Format(Me.Date1, "m-d-yy") & " to " & Format(Me.Date2, "m-d-yy") 
721     
722         Case Not IsNull(Me.Date1) 
723            mvCrit = (mvCrit + " AND ") 
724            mvCrit = "(" & nDateField & " >= #" & Me.Date1 & "#)" 
725            msUserCriteria = msUserCriteria & "  " _ 
726               & nDateField & " >= " & Format(Me.Date1, "m-d-yy") 
727     
728         Case Not IsNull(Me.Date2) 
729            mvCrit = (mvCrit + " AND ") 
730            mvCrit = "(" & nDateField & " <= #" & Me.Date2 & "#)" 
731            msUserCriteria = msUserCriteria & "  " _ 
732               & nDateField & " <= " & Format(Me.Date2, "m-d-yy") 
733     
734     
735     
736         End Select 
737     
738         setCritDates = True 
739     
740      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

CheckDates (40)

741     
742       '~~~~~~~~~~~~
743     
744      Private Function CheckDates(Optional ByVal pWhich As String) As Boolean 
745     
746         CheckDates = False 
747     
748         Dim mWhich As String 
749         If IsMissing(pWhich) Then mWhich = "All" Else mWhich = pWhich 
750     
751         If mWhich = "2" Then GoTo CheckDates_2 
752     
753         If IsNull(Me.Date1) Then 
754            Me.Date1.SetFocus 
755            MsgBox "You must fill out a beginning date", , "Cannot generate report" 
756            Exit Function 
757         Else 
758            If Not IsDate(Me.Date1) Then 
759               Me.Date1.SetFocus 
760               MsgBox Me.Date1 & " is not a valid date", , "Cannot generate report" 
761               Exit Function 
762            End If 
763         End If 
764     
765         If mWhich = "1" Then CheckDates = True: Exit Function 
766     
767      CheckDates_2: 
768         If IsNull(Me.Date2) Then 
769            Me.Date2.SetFocus 
770            MsgBox "You must fill out an ending date", , "Cannot generate report" 
771            Exit Function 
772         Else 
773            If Not IsDate(Me.Date2) Then 
774               Me.Date2.SetFocus 
775               MsgBox Me.Date2 & " is not a valid date", , "Cannot generate report" 
776               Exit Function 
777            End If 
778         End If 
779         CheckDates = True 
780      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

ASDay (14)

781     
782       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
783       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
784     
785     
786       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
787       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ change dates ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
788       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
789     
790      Private Function ASDay(pNum As Integer) 
791         On Error Resume Next 
792         Me.Date1 = DateSerial(Year(Me.Date1), Month(Me.Date1), Day(Me.Date1) + pNum) 
793         Me.Date2 = DateSerial(Year(Me.Date2), Month(Me.Date2), Day(Me.Date2) + pNum) 
794      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

ASMonth (6)

795     
796      Private Function ASMonth(pNum As Integer) 
797         On Error Resume Next 
798         Me.Date1 = DateSerial(Year(Me.Date1), Month(Me.Date1) + pNum, Day(Me.Date1)) 
799         Me.Date2 = DateSerial(Year(Me.Date2), Month(Me.Date2) + pNum, Day(Me.Date2)) 
800      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

ASYear (6)

801     
802      Private Function ASYear(pNum As Integer) 
803         On Error Resume Next 
804         Me.Date1 = DateSerial(Year(Me.Date1) + pNum, Month(Me.Date1), Day(Me.Date1)) 
805         Me.Date2 = DateSerial(Year(Me.Date2) + pNum, Month(Me.Date2), Day(Me.Date2)) 
806      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

FillOneYear (6)

807     
808      Private Function FillOneYear() 
809         On Error Resume Next 
810         Me.Date2 = Date - 1 
811         Me.Date1 = DateSerial(Year(Me.Date2) - 1, Month(Me.Date2), Day(Me.Date2)) + 1 
812      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

FillQuarter (9)

813     
814      Private Function FillQuarter(pQtr As Integer) 
815         Dim mMonth As Integer, mEndQ As Integer, mYear As Integer 
816         mMonth = Month(Date) 
817         mEndQ = pQtr * 3 
818         If mMonth > mEndQ Then mYear = Year(Date) Else mYear = Year(Date) - 1 
819         Me.Date1 = DateSerial(mYear, mEndQ - 2, 1) 
820         Me.Date2 = DateSerial(mYear, mEndQ + 1, 1) - 1 
821      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

FillDate (7)

822     
823      Private Function FillDate(Optional pDate) 
824         On Error Resume Next 
825         If IsMissing(pDate) Then pDate = Date 
826            Me.Date1 = pDate 
827            Me.Date2 = pDate 
828      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

FillMTD (6)

829     
830      Private Function FillMTD() 
831         On Error Resume Next 
832         Me.Date1 = DateSerial(Year(Date), Month(Date), 1) 
833         Me.Date2 = Date 
834      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

FillYTD (6)

835     
836      Private Function FillYTD() 
837         On Error Resume Next 
838         Me.Date1 = DateSerial(Year(Date), 1, 1) 
839         Me.Date2 = Date 
840      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

FillOneWeek (6)

841     
842      Private Function FillOneWeek() 
843         On Error Resume Next 
844         Me.Date1 = Date - 6 
845         Me.Date2 = Date 
846      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

FillMonth (6)

847     
848      Private Function FillMonth() 
849         On Error Resume Next 
850         Me.Date1 = DateSerial(Year(Date), Month(Date), 1) 
851         Me.Date2 = DateSerial(Year(Date), Month(Date) + 1, 1) - 1 
852      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

FillWorkWeek (7)

853     
854      Private Function FillWorkWeek() 
855         Dim mDOW As Integer 
856         mDOW = Weekday(Date) 
857         Me.Date1 = Date - mDOW + 1 
858         Me.Date2 = Me.Date1 + 6 
859      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

EmailTheReport (12)

860     
861       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
862       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
863     
864       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
865       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
866     
867      Private Sub EmailTheReport(pReportName As String, pTitle As String, pFrom As String) 
868         SetReportFilter pReportName, mvCrit 
869         EMailReport pReportName, Me.EmailAddress, pTitle, Me.chkEdit, pFrom 
870         MsgBox pTitle & " has been emailed to " & Me.EmailAddress, , "Done with " & pReportName 
871      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

RFTtheReport (33)

872     
873      Private Sub RFTtheReport(pReportName As String, pFilename As String) 
874         Dim sFilename As String 
875         On Error Resume Next 
876         sFilename = CurrentProject.Path & "\RTF" 
877         MkDir sFilename 
878         On Error GoTo Proc_Err 
879     
880         sFilename = CurrentProject.Path & "\RTF\" _ 
881            & Trim(pReportName & IIf(Len(msUserCriteria) > 0, CorrectFilename(msUserCriteria), "") _ 
882            & "_" & Format(Now(), "yymmdd_h_nn")) & ".RTF" 
883     
884         If Dir(sFilename) <> "" Then 
885            Kill sFilename 
886            DoEvents 
887         End If 
888         SetReportFilter pReportName, mvCrit 
889         DoCmd.OutputTo acOutputReport, pReportName, acFormatRTF, sFilename 
890          'clear the filter
891       '   SetReportFilter pReportName, ""
892         If Me.chkOpen Then Application.FollowHyperlink sFilename 
893     
894      Proc_Exit: 
895         Exit Sub 
896      Proc_Err: 
897         Select Case Err.Number 
898            Case 2501: Resume Proc_Exit 
899            Case Else 
900               MsgBox Err.Description, , "ERROR " & Err.Number & "   RFTtheReport" 
901               Resume Proc_Exit 
902               Resume 
903            End Select 
904      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

UnderConstruction (4)

905     
906      Private Function UnderConstruction() 
907         MsgBox "Under Construction", , "Under Construction" 
908      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

cmdAdd_eMail_Click (7)

909     
910     
911      Private Sub cmdAdd_eMail_Click() 
912          'created 10-22-05
913         DoCmd.OpenForm "Email", , , , , acDialog 
914         CheckEmailOptions 
915      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

CheckEmailOptions (14)

916     
917      Private Function CheckEmailOptions() 
918         Dim boo As Boolean 
919         boo = IIf(IsNull(Me.EmailAddress), False, True) 
920         If boo Then 
921            Me.fraOutput3.Enabled = True 
922            Me.fraOutput = 3 
923         Else 
924            If Me.fraOutput = 3 Then Me.fraOutput = 1 
925            Me.fraOutput3.Enabled = False 
926         End If 
927       '   BoldMe "fraOutput", 3
928         fraOutput_AfterUpdate 
929      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

btnClearEmail_Click (5)

930     
931      Private Sub btnClearEmail_Click() 
932         Me.EmailAddress = Null 
933         CheckEmailOptions 
934      End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

ClearList (7)

935     
936      Private Function ClearList(ByVal pControlname As String) 
937         Dim varItem As Variant 
938         For Each varItem In Me(pControlname).ItemsSelected 
939             Me(pControlname).Selected(varItem) = False 
940         Next varItem 
941      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

CloseMeMe (8)

942     
943       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
944       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
945     
946       '------------------------------------------------------ cmdClose_Click
947      Private Function CloseMeMe() 
948         DoCmd.Close acForm, Me.Name, acSaveNo 
949      End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

ResetData (59)

950     
951       '------------------------------------------------------ ResetData
952      Private Function ResetData() 
953          '5-15-06
954         Me.btn1.SetFocus 
955     
956         Me.ListTQ = Null 
957         Dim i As Integer, varItem As Variant 
958     
959         Me.CalTitle = "" 
960     
961         For i = 1 To 4 
962     
963            With Me("field" & i) 
964     
965               If i = 3 Then 
966                  ClearList "Field3" 
967               Else 
968                  .Value = Null 
969               End If 
970     
971               .RowSource = "" 
972               .Requery 
973     
974            End With 
975     
976            With Me("Examples" & i) 
977               .RowSource = "" 
978               .Requery 
979               .Value = Null 
980            End With 
981     
982            Me("Source" & i) = Null 
983     
984         Next i 
985     
986     
987         Me.FormatCodes = "" 
988     
989         Me.label_FooterCalc1.Visible = False 
990         Me.label_FooterCalc2.Visible = False 
991         Me.prompt_FooterCalc1.Visible = False 
992         Me.prompt_FooterCalc2.Visible = False 
993         Me.label_Footer1.Visible = False 
994         Me.prompt_Footer1.Visible = False 
995         Me.label_Footer2.Visible = False 
996         Me.prompt_Footer2.Visible = False 
997         Me.label_Footer3.Visible = False 
998         Me.prompt_Footer3.Visible = False 
999     
1,000       Me.Label_fraSumcount.Visible = False 
1,001       Me.fraSumcount.Enabled = False 
1,002       Me.fraSumcount = 3 
1,003   
1,004       Me.Field3eqn = Null 
1,005       Me.Field3Alias = Null 
1,006   
1,007   
1,008    End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

fraOutput_AfterUpdate (26)

1,009   
1,010     '------------------------------------------------------ fraOutput_AfterUpdate
1,011    Private Sub fraOutput_AfterUpdate() 
1,012       Dim nColor As Long _ 
1,013          , i As Integer _ 
1,014          , boo As Boolean 
1,015   
1,016       For i = 1 To 3 
1,017          If i = Me.fraOutput Then boo = True Else boo = False 
1,018          Me("label_fraOutput" & Format(i, "0")).FontBold = boo 
1,019       Next i 
1,020   
1,021       Select Case Me.fraOutput 
1,022       Case 1   'screen 
1,023          nColor = 8388608 
1,024       Case 2   'snap 
1,025          nColor = 128 
1,026       Case 3   ' email 
1,027          nColor = 13056 
1,028       End Select 
1,029   
1,030       For i = 1 To gNUMREPORTS 
1,031          Me("btn" & i).BackColor = nColor 
1,032       Next i 
1,033   
1,034    End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Edit_TQ (17)

1,035   
1,036   
1,037     '------------------------------------------------------ Edit_TQ
1,038    Private Function Edit_TQ() 
1,039        'on me.ListTQ double-click
1,040       If Me.FraTQ = 2 Then 
1,041          Debug.Print "--- SQL for " & Me.ListTQ & " --- " & Format(Now(), "ddd m-d-yy j:nn") 
1,042          Debug.Print Nz(CurrentDb.QueryDefs(Me.[ListTQ]).SQL) 
1,043       End If 
1,044   
1,045       On Error Resume Next 
1,046       If Me.FraTQ = 1 Then 
1,047          DoCmd.OpenTable Me.ListTQ 
1,048       Else 
1,049          DoCmd.OpenQuery Me.ListTQ, acViewDesign 
1,050       End If 
1,051    End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

NewFooterText (13)

1,052   
1,053     '------------------------------------------------------
1,054   
1,055   
1,056     '------------------------------------------------------ NewFooterText
1,057    Private Function NewFooterText(pWhich) 
1,058       Dim sText As String, sNewText As String 
1,059       sText = Trim(Nz(Me("label_Footer" & Format(pWhich, "0")).Caption)) 
1,060       sNewText = InputBox("Enter new caption:", "Change Report Footer Text", sText) 
1,061       If sNewText <> "" Then 
1,062          Me("label_Footer" & Format(pWhich, "0")).Caption = sNewText 
1,063       End If 
1,064    End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

FraTQ_AfterUpdate (4)

1,065   
1,066    Private Sub FraTQ_AfterUpdate() 
1,067    Call SQL_TQ(Me.FraTQ) 
1,068    End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

label_Footer1_DblClick (4)

1,069   
1,070    Private Sub label_Footer1_DblClick(Cancel As Integer) 
1,071    Call NewFooterText(1) 
1,072    End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

label_Footer2_DblClick (4)

1,073   
1,074    Private Sub label_Footer2_DblClick(Cancel As Integer) 
1,075    Call NewFooterText(2) 
1,076    End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

label_Footer3_DblClick (4)

1,077   
1,078    Private Sub label_Footer3_DblClick(Cancel As Integer) 
1,079    Call NewFooterText(3) 
1,080    End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

label_Footer4_DblClick (4)

1,081   
1,082    Private Sub label_Footer4_DblClick(Cancel As Integer) 
1,083    Call NewFooterText(4) 
1,084    End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Label_writtenBy_Click (6)

1,085   
1,086    Private Sub Label_writtenBy_Click() 
1,087     '140930
1,088       Application.FollowHyperlink _ 
1,089          "mailto: strive4peace2012@yahoo.com?subject= HTML Calendar comment" 
1,090    End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

ListTQ_AfterUpdate (5)

1,091   
1,092    Private Sub ListTQ_AfterUpdate() 
1,093     '140929
1,094       Call SQL_Fields 
1,095    End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

ListTQ_DblClick (5)

1,096   
1,097    Private Sub ListTQ_DblClick(Cancel As Integer) 
1,098     '140929
1,099       Call Edit_TQ 
1,100    End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Report_Calendar (136)

1,101   
1,102   
1,103     '------------------------------------------------------ Report_Calendar
1,104    Private Function Report_Calendar() 
1,105   
1,106       On Error GoTo Proc_Err 
1,107   
1,108        'crystal, strive4peace
1,109        ' 060516... 140929
1,110   
1,111        'CALLS
1,112        '  MkDir
1,113        '  Create_HTMLCalendar
1,114   
1,115       Dim varItem As Variant 
1,116       Dim nDate As Date _ 
1,117          , sFilename As String _ 
1,118          , sPath As String 
1,119   
1,120       If IsNull(Me.ListTQ) Then 
1,121          MsgBox "You must choose a TABLE or QUERY (data source)", , "Aborting Calendar" 
1,122          Exit Function 
1,123       End If 
1,124   
1,125       If IsNull(Me.Field1) Then 
1,126          MsgBox "You must choose a DATE FIELD for the calendar", , "Aborting Calendar..." 
1,127          Me.Field1.SetFocus 
1,128          Exit Function 
1,129       End If 
1,130   
1,131       Debug.Print Me.Field3.Value   '140929 
1,132   
1,133       If (IsNull(Me.Field2.Column(0)) And IsNull(Me.Field3.Column(0)) And IsNull(Me.Field4.Column(0))) Then   '140929 added outer (  ) 
1,134          MsgBox "You must select something to display on the calendar", , "Aborting Calendar..." 
1,135          Exit Function 
1,136       End If 
1,137   
1,138       If IsNull(Me.Date1) Then 
1,139          If IsNull(Me.Date2) Then 
1,140             MsgBox "You must select a DATE in the month for the calendar", , "Aborting Calendar..." 
1,141             Exit Function 
1,142          End If 
1,143          Me.Date1 = Me.Date2 
1,144       Else 
1,145          If IsNull(Me.Date2) Then Me.Date2 = Me.Date1 
1,146       End If 
1,147   
1,148       msUserCriteria = "" 
1,149       mvCrit = Null 
1,150   
1,151     '   If Not setCritDates("month", Me.Field1) Then
1,152     '      MsgBox "Cannot determine month to print calendar -- pick a date", , "Aborting Calendar..."
1,153     '      Exit Function
1,154     '   End If
1,155   
1,156     '   msUserCriteria = ""
1,157     '   mvCrit = null
1,158   
1,159        'create filename
1,160       sPath = CurrentProject.Path & "\web_Calendars" 
1,161       On Error Resume Next 
1,162       Call MkDir(sPath) 
1,163       DoEvents 
1,164       On Error GoTo Proc_Err 
1,165   
1,166       nDate = Me.Date1 
1,167   
1,168       Do 
1,169          sFilename = Trim(sPath & "\c_" _ 
1,170                      & Trim(Format(nDate, "yy-mm")) _ 
1,171                      & "_" & Trim(Me.CalTitle) _ 
1,172                      & IIf(IsNull(Me.Field3Alias), "", "_" & Me.Field3Alias)) & ".html" 
1,173   
1,174     'Debug.Print sFilename
1,175     'Stop
1,176     'IIf(IsNull(Me.Field4.Column(0)), 1, Me.fraSumcount)
1,177   
1,178          If Not Create_HTMLCalendar(sFilename, _ 
1,179           nDate, _ 
1,180           Nz(Me.CalTitle, IIf(IsNull(Me.Field3Alias), "", " " & Me.Field3Alias)), _ 
1,181           mvCrit, _ 
1,182           "crit", _ 
1,183           Me.ListTQ, _ 
1,184           Me.Field1.Column(0), _ 
1,185           Nz(Me.Field2.Column(0), ""), _ 
1,186           Nz(Me.Field3eqn, ""), _ 
1,187           Nz(Me.Field4.Column(0), ""), _ 
1,188           Nz(Me.Field4.Column(0), 0), _ 
1,189           Nz(Me.FormatCodes), _ 
1,190           IIf(Not Me.label_Footer1.Visible, "", Trim(Nz(Me.label_Footer1.Caption))), _ 
1,191           IIf(Not Me.label_Footer1.Visible, "", Trim(Nz(Me.label_Footer2.Caption))), _ 
1,192           Trim(Nz(Me.label_Footer3.Caption)), _ 
1,193           Trim(Nz(Me.label_Footer4.Caption)), _ 
1,194           IIf(IsNull(Me.Color3), "008080", Me.Color3), _ 
1,195           IIf(IsNull(Me.Color4), "008000", Me.Color4), _ 
1,196           IIf(IsNull(Me.Color3B), "FF6347", Me.Color3B) _ 
1,197           ) Then 
1,198             MsgBox "CALENDAR CREATION WAS NOT SUCCESSFUL " _ 
1,199                & " for " & Format(nDate, "mmm-yyyy"), , Format(nDate, "yymm") & " Not Successful" 
1,200             GoTo Cal_NextMonth 
1,201          End If 
1,202   
1,203   
1,204       If Me.fraOutput = 3 Then 
1,205           'email calendar
1,206          If IsNull(Me.EmailAddress) Then 
1,207             MsgBox "You must select an email address to email a calendar", , "Need email address" 
1,208          Else 
1,209             MsgBox "Email function is under construction", , "Email under construction" 
1,210              'add code
1,211          End If 
1,212   
1,213          GoTo Proc_Exit 
1,214   
1,215       Else 
1,216          If Nz(Me.chkOpenBrowser, False) = True Then 
1,217             Application.FollowHyperlink sFilename 
1,218             DoEvents 
1,219          End If 
1,220       End If 
1,221   
1,222    Cal_NextMonth: 
1,223           'go to next month
1,224          nDate = DateSerial(Year(nDate), Month(nDate) + 1, 1) 
1,225   
1,226       Loop Until Format(nDate, "yymm") > Format(Me.Date2, "yymm") 
1,227   
1,228    Proc_Exit: 
1,229       Exit Function 
1,230   
1,231    Proc_Err: 
1,232        MsgBox Err.Description, , "ERROR " & Err.Number & "    Report_Calendar" 
1,233        Stop 
1,234        Resume 
1,235   
1,236    End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Create_HTMLCalendar (533)

1,237   
1,238   
1,239     '==========================================================
1,240     ' below here could be in a general modules
1,241     '
1,242     'Crystal_GenerateHTML
1,243   
1,244     'crystal
1,245     'strive4peace2004@yahoo.ca
1,246     'modified 4-2-06
1,247     '5-16-06 calendar
1,248   
1,249     'NEEDS REFERENCES
1,250     'Microsoft DAO
1,251   
1,252   
1,253      'CALLS
1,254   
1,255        'html_StartTime
1,256        'MkDir (VBA.FileSystem)
1,257        'html_EndTime
1,258   
1,259        'WriteHTMLheader
1,260        'WriteHTMLfooter
1,261   
1,262   
1,263   
1,264     '------------------------------------------------- Create_HTMLCalendar
1,265    Function Create_HTMLCalendar( _ 
1,266       psPathFile As String, _ 
1,267       pnDate As Date, _ 
1,268       psCalTitle As String, _ 
1,269       pvCrit As Variant, _ 
1,270       psFriendlyCrit As String, _ 
1,271       psTableOrQueryName As String, _ 
1,272       psFldName_Date As String, _ 
1,273       psFldName_ID As String, _ 
1,274       psFldName_Text As String, _ 
1,275       psFldName_Calc As String, _ 
1,276       Optional psFldName_Calc_operation As Integer = 0, _ 
1,277       Optional psFormatCode As String, _ 
1,278       Optional psFooterAfterCountID As String, _ 
1,279       Optional psFooterBeforeCalc As String, _ 
1,280       Optional psFooterBeforeDays As String, _ 
1,281       Optional psFooterAfterDays As String, _ 
1,282       Optional psColor3 As String = "4682B4", _ 
1,283       Optional psColor4 As String = "008000", _ 
1,284       Optional psColor3B As String = "FF6347" _ 
1,285       ) As Boolean 
1,286   
1,287        'CALLS
1,288        'html_StartTime
1,289        'MkDir
1,290        'html_EndTime
1,291        'WriteHTMLheader
1,292        'WriteHTMLfooter
1,293        'Shell "C:\Program Files\Internet Explorer\iexplore.exe " & sFilename, vbMaximizedFocus
1,294   
1,295        'assume calendar was not successful
1,296       Create_HTMLCalendar = False 
1,297   
1,298        'time how long it takes to do thing
1,299       Call html_StartTime 
1,300   
1,301        'set up error handler
1,302       On Error GoTo Proc_Err 
1,303   
1,304        'dimension variables
1,305       Dim iDOW1 As Integer _ 
1,306          , iDOW2 As Integer _ 
1,307          , nDate1 As Date _ 
1,308          , nDate2 As Date _ 
1,309          , nDate As Date 
1,310       Dim nNumDaysWithData As Integer _ 
1,311          , mCalDate As Date _ 
1,312          , mDay As Integer 
1,313       Dim iColWidth _ 
1,314          , mTotalAmount As Currency _ 
1,315          , sColor As String 
1,316   
1,317       Dim nCountIDs As Long _ 
1,318          , nCountDays As Long _ 
1,319          , nCountID As Long _ 
1,320          , curSumAmount As Currency _ 
1,321          , nLastDate As Date 
1,322   
1,323       Dim iFileNumber As Integer _ 
1,324          , sSQL As String _ 
1,325          , mOperation As Integer 
1,326       Dim iCalDay As Integer _ 
1,327          , iCol As Integer _ 
1,328          , iRow As Integer 
1,329   
1,330       Dim db As DAO.Database _ 
1,331          , rs As DAO.Recordset 
1,332   
1,333       nDate1 = DateSerial(Year(pnDate), Month(pnDate), 1) 
1,334       nDate2 = DateSerial(Year(pnDate), Month(pnDate) + 1, 0) 
1,335   
1,336       iDOW1 = Weekday(nDate1) 
1,337       iDOW2 = Weekday(nDate2) 
1,338   
1,339     '   nNuiRowsSQL =  CInt((Day(nDate2) + iDOW1 - 1) / 7 - 0.5) + 1
1,340       nNumDaysWithData = 0 
1,341   
1,342       iColWidth = 130 
1,343       mTotalAmount = 0 
1,344   
1,345        'determine Sum/count/Each (1/2/3)
1,346       If Len(psFldName_Calc) = 0 Then 
1,347          mOperation = 0 
1,348       Else 
1,349          mOperation = psFldName_Calc_operation 
1,350       End If 
1,351   
1,352        '--------------------- construct SQL for calendar day values
1,353   
1,354       sSQL = "SELECT DateValue([" & psFldName_Date & "]) AS CalDate" 
1,355   
1,356       If Len(Trim(psFldName_ID)) > 0 And Len(Trim(psFldName_Text)) > 0 Then 
1,357          sSQL = sSQL & ", [" & psFldName_ID & "] as CalID" 
1,358       Else 
1,359          sSQL = sSQL & ", 0 as CalID" 
1,360       End If 
1,361   
1,362       If Len(Trim(psFldName_Text)) > 0 Then 
1,363           'if field3 does not have any brackets, enclose it in brackets
1,364           'field may be an equation...
1,365          If InStr(psFldName_Text, "[") > 0 Then 
1,366             sSQL = sSQL & ", " & psFldName_Text & " as CalText" 
1,367          Else 
1,368             sSQL = sSQL & ", [" & psFldName_Text & "] as CalText" 
1,369          End If 
1,370       Else 
1,371          sSQL = sSQL & ", """" as CalText" 
1,372       End If 
1,373   
1,374       Select Case mOperation 
1,375          Case 0 
1,376             sSQL = sSQL & ", cCur(0) as CalAmount" 
1,377          Case 1 
1,378             If InStr(psFldName_Calc, "nz") = 0 Then 
1,379                sSQL = sSQL & ", SUM(nz([" & psFldName_Calc & "])) as CalAmount" 
1,380             Else 
1,381                sSQL = sSQL & ", SUM(" & psFldName_Calc & ") as CalAmount" 
1,382             End If 
1,383          Case 2 
1,384             If InStr(psFldName_Calc, "nz") = 0 Then 
1,385                sSQL = sSQL & ", COUNT(nz([" & psFldName_Calc & "])) as CalAmount" 
1,386             Else 
1,387                sSQL = sSQL & ", COUNT(" & psFldName_Calc & ") as CalAmount" 
1,388             End If 
1,389          Case 3 
1,390             If InStr(psFldName_Calc, "[") = 0 Then 
1,391                sSQL = sSQL & ", [" & psFldName_Calc & "] as CalAmount" 
1,392             Else 
1,393                sSQL = sSQL & ", " & psFldName_Calc & " as CalAmount" 
1,394             End If 
1,395       End Select 
1,396   
1,397       sSQL = sSQL & " FROM [" & psTableOrQueryName & "] " 
1,398   
1,399       sSQL = sSQL & " WHERE format(nz([" & psFldName_Date & "]),""yymm"") = '" & Format(pnDate, "yymm") & "' " 
1,400       If Len(pvCrit) > 0 Then 
1,401          sSQL = sSQL & " AND " & pvCrit 
1,402       End If 
1,403   
1,404       Select Case mOperation 
1,405       Case 0, 1, 2 
1,406          sSQL = sSQL & " GROUP BY DateValue([" & psFldName_Date & "])" 
1,407          If Len(psFldName_ID) > 0 And Len(Trim(psFldName_Text)) > 0 Then 
1,408             sSQL = sSQL & ", [" & psFldName_ID & "]" 
1,409          End If 
1,410          If Len(psFldName_Text) > 0 Then 
1,411             If InStr(psFldName_Text, "[") > 0 Then 
1,412                sSQL = sSQL & ", " & psFldName_Text 
1,413             Else 
1,414                sSQL = sSQL & ", [" & psFldName_Text & "]" 
1,415             End If 
1,416          End If 
1,417       End Select 
1,418   
1,419       If InStr(sSQL, "GROUP BY") = 0 Then 
1,420          sSQL = sSQL & " ORDER BY [" & psFldName_Date & "]" 
1,421          If Len(Trim(psFldName_ID)) > 0 And Len(Trim(psFldName_Text)) > 0 Then _ 
1,422             sSQL = sSQL & ", [" & psFldName_ID & "]" 
1,423          If Len(Trim(psFldName_Text)) > 0 Then _ 
1,424             sSQL = sSQL & ", " & IIf(InStr(psFldName_Text, "[") > 0, psFldName_Text, "[" & psFldName_Text & "]") 
1,425   
1,426       End If 
1,427   
1,428       sSQL = sSQL & ";" 
1,429   
1,430    Debug.Print " ---CALENDAR---" & Now() 
1,431    Debug.Print sSQL 
1,432   
1,433       Set db = CurrentDb 
1,434       Set rs = db.OpenRecordset(sSQL, dbOpenDynaset) 
1,435   
1,436       With rs 
1,437          If .EOF Then 
1,438        '      MsgBox "No records matching specified criteria for " & Format(pnDate, "mmm-yy"), , "Aborting Calendar Report"
1,439             .Close 
1,440             Set rs = Nothing 
1,441             Call html_EndTime 
1,442             Exit Function 
1,443          End If 
1,444          .MoveFirst 
1,445   
1,446           '*************************************************************************************
1,447           '-------------------------------------------------------------------- create web page
1,448   
1,449          iFileNumber = FreeFile 
1,450   
1,451          On Error Resume Next 
1,452          Close #iFileNumber 
1,453          If Dir(psPathFile) <> "" Then 
1,454             Kill psPathFile 
1,455          '    DoEvents: DoCmd.Hourglass True
1,456          End If 
1,457   
1,458           '-------------------------------------------------------------------- ~header
1,459          On Error GoTo Proc_Err 
1,460          Open psPathFile For Output As #iFileNumber 
1,461          WriteHTMLheader iFileNumber, Format(!CalDate, "mmmm yyyy"), psCalTitle 
1,462   
1,463        '   DoEvents: DoCmd.Hourglass True
1,464   
1,465           'define table
1,466          Print #iFileNumber, "
"
1,467 Print #iFileNumber, "" 1,468 Print #iFileNumber, "" 1,469 1,470 'print days of week1,471 For iCol = 1 To 7 1,472 Print #iFileNumber, "" 1,477 Next iCol 1,478 1,479 Print #iFileNumber, " " 1,480 Print #iFileNumber, "" 1,481 1,482 iCalDay = 0 1,483 1,484 '-------------------------------------------------------------------- ~detail1,485 'print information on days1,486 1,487 'determine number of squares before the calendar starts1,488 If iDOW1 <> 1 Then 1,489 Print #iFileNumber, "" 1,491 End If 1,492 1,493 For nDate = nDate1 To nDate2 1,494 'see if we need to go to another row1,495 If Weekday(nDate) = 1 And Day(nDate) <> 1 Then 1,496 'go to another row1,497 Print #iFileNumber, "" 1,498 End If 1,499 '-------------- print day number1,500 Print #iFileNumber, "" 1,575 1,576 Next nDate 1,577 1,578 'determine number of squares after the calendar starts1,579 If iDOW2 <> 6 Then 1,580 Print #iFileNumber, "" 1,582 End If 1,583 1,584 Print #iFileNumber, "
" 1,473 Print #iFileNumber, "" 1,474 Print #iFileNumber, " " & Mid("SunMonTueWedThuFriSat", (iCol - 1) * 3 + 1, 3) 1,475 Print #iFileNumber, "" 1,476 Print #iFileNumber, "
" 1,490 Print #iFileNumber, "
" 1,501 Print #iFileNumber, "

" 1,502 Print #iFileNumber, " 1,503 1,504 'see if there is any data for this day 1,505 If Not .EOF() Then 1,506 If !CalDate = nDate Then 1,507 Print #iFileNumber, " color = blue" 1,508 nNumDaysWithData = nNumDaysWithData + 1 1,509 End If 1,510 End If 1,511 1,512 Print #iFileNumber, ">" 1,513 Print #iFileNumber, " " & CStr(Day(nDate)) & " " 1,514 If Not .EOF Then 1,515 If !CalDate = nDate Then 1,516 Print #iFileNumber, "" 1,517 End If 1,518 End If 1,519 1,520 Print #iFileNumber, "" 1,521 Print #iFileNumber, "

" 1,522 1,523 Print #iFileNumber, "

" 1,524 Print #iFileNumber, "" 1,525 1,526 If Not .EOF Then 1,527 If !CalDate = nDate Then 1,528 Do 1,529 If .EOF Then GoTo End_Of_Day 1,530 1,531 'switch between psColor3 and psColor3B 1,532 If sColor <> psColor3 Then 1,533 sColor = psColor3 1,534 Else 1,535 sColor = psColor3B 1,536 End If 1,537 1,538 If Len(psFldName_Text) > 0 Then 1,539 Print #iFileNumber, "" 1,540 Print #iFileNumber, " " & !CalText & " " 1,541 Print #iFileNumber, "" 1,542 End If 1,543 1,544 If Len(psFldName_Calc) > 0 Then 1,545 Print #iFileNumber, IIf(Len(Trim(psColor4)) > 0, "", "") 1,546 If Len(psFldName_Text) > 0 Then 1,547 Print #iFileNumber, "-- " 1,548 End If 1,549 If Len(Trim(psFormatCode)) > 0 Then 1,550 Print #iFileNumber, " " & Format(Nz(!CalAmount), psFormatCode) 1,551 Else 1,552 Print #iFileNumber, " " & Format(Nz(!CalAmount), "#,###.##;"""";""""") 1,553 End If 1,554 Print #iFileNumber, IIf(Len(Trim(psColor4)) > 0, "", "") 1,555 End If 1,556 1,557 Print #iFileNumber, "
"
1,558 mTotalAmount = mTotalAmount + Nz(!CalAmount) 1,559 1,560 If .EOF Then GoTo End_Of_Day 1,561 .MoveNext 1,562 If .EOF Then GoTo End_Of_Day 1,563 If !CalDate <> nDate Then GoTo End_Of_Day 1,564 1,565 Loop While !CalDate = nDate 1,566 End If 1,567 End If 1,568 End_Of_Day: 1,569 1,570 Print #iFileNumber, ""
1,571 Print #iFileNumber, "

" 1,572 sColor = psColor3B 'do this so color starts with the first one 1,573 nextCol: 1,574 Print #iFileNumber, "
" 1,581 Print #iFileNumber, "
" 1,585 ' Print #iFileNumber, "
"
1,586 1,587 .Close 1,588 End With 'rs 1,589 Set rs = Nothing 1,590 1,591 '-------------- construct SQL for summary below calendar 1,592 1,593 '+++++++++++++++++++++ count days 1,594 1,595 sSQL = "SELECT COUNT(nz([" & psFldName_Date & "])) as CountDays " _ 1,596 & " FROM [" & psTableOrQueryName & "] " _ 1,597 & " WHERE format(nz([" & psFldName_Date & "]),""yymm"") = '" _ 1,598 & Format(pnDate, "yymm") & "' " 1,599 If Len(pvCrit) > 0 Then 1,600 sSQL = sSQL & " AND " & pvCrit 1,601 End If 1,602 1,603 sSQL = sSQL & ";" 1,604 1,605 Debug.Print sSQL 1,606 1,607 Set rs = CurrentDb.OpenRecordset(sSQL, dbOpenDynaset) 1,608 nCountDays = 0 1,609 With rs 1,610 If Not .EOF Then 1,611 .MoveFirst 1,612 nCountDays = !CountDays 1,613 End If 1,614 .Close 1,615 End With 1,616 Set rs = Nothing 1,617 1,618 '+++++++++++++++++++++ count IDs 1,619 1,620 If Len(psFldName_ID) > 0 Then 1,621 sSQL = "SELECT DISTINCT nz([" & psFldName_ID & "]) as CountIDs" 1,622 sSQL = sSQL & " FROM [" & psTableOrQueryName & "] " _ 1,623 & " WHERE format(nz([" & psFldName_Date & "]),""yymm"") = '" _ 1,624 & Format(pnDate, "yymm") & "' " 1,625 If Len(pvCrit) > 0 Then 1,626 sSQL = sSQL & " AND " & pvCrit 1,627 End If 1,628 sSQL = sSQL & ";" 1,629 1,630 Debug.Print sSQL 1,631 1,632 Set rs = CurrentDb.OpenRecordset(sSQL, dbOpenDynaset) 1,633 nCountIDs = 0 1,634 With rs 1,635 If Not .EOF Then 1,636 .MoveLast 1,637 nCountIDs = .RecordCount 1,638 End If 1,639 .Close 1,640 End With 1,641 Set rs = Nothing 1,642 End If 1,643 1,644 '+++++++++++++++++++++ sum Amount 1,645 1,646 If Len(psFldName_Calc) > 0 Then 1,647 1,648 If InStr(psFldName_Calc, "nz") = 0 Then 1,649 sSQL = "SELECT SUM(nz([" & psFldName_Calc & "])) as SumAmount" 1,650 Else 1,651 sSQL = "SELECT SUM(" & psFldName_Calc & ") as SumAmount" 1,652 End If 1,653 1,654 sSQL = sSQL & " FROM [" & psTableOrQueryName & "] " _ 1,655 & " WHERE format(nz([" & psFldName_Date & "]),""yymm"") = '" _ 1,656 & Format(pnDate, "yymm") & "' " 1,657 1,658 If Len(pvCrit) > 0 Then 1,659 sSQL = sSQL & " AND " & pvCrit 1,660 End If 1,661 sSQL = sSQL & ";" 1,662 1,663 Debug.Print sSQL 1,664 1,665 Set rs = CurrentDb.OpenRecordset(sSQL, dbOpenDynaset) 1,666 curSumAmount = 0 1,667 With rs 1,668 If Not .EOF Then 1,669 .MoveFirst 1,670 curSumAmount = !SumAmount 1,671 End If 1,672 .Close 1,673 End With 1,674 Set rs = Nothing 1,675 End If 1,676 1,677 '+++++++++++++++++++++ 1,678 1,679 '--------------------------------------- detail below calendar 1,680 Print #iFileNumber, "" 1,681 1,682 If Len(psFriendlyCrit) > 0 Then 1,683 If psFriendlyCrit = "crit" Then 1,684 '--------------------------------------- criteria 1,685 Print #iFileNumber, "
"
1,686 Print #iFileNumber, "" 1,687 Print #iFileNumber, Nz(psTableOrQueryName) & " : " 1,688 Print #iFileNumber, Nz(psFldName_Date) & " : " 1,689 Print #iFileNumber, Nz(psFldName_ID) & " : " 1,690 Print #iFileNumber, Nz(psFldName_Text) & " : " 1,691 Print #iFileNumber, Nz(psFldName_Calc) 1,692 If Not psFldName_Calc_operation = 0 Then 1,693 If Nz(psFldName_Calc_operation, 3) <> 3 Then 1,694 Print #iFileNumber, " : " & IIf(psFldName_Calc_operation = 1, "Sum", "Count") 1,695 End If 1,696 End If 1,697 Print #iFileNumber, "" 1,698 Else 1,699 Print #iFileNumber, psFriendlyCrit 1,700 Print #iFileNumber, "  " 1,701 End If 1,702 Print #iFileNumber, "
"
1,703 End If 1,704 1,705 '--------------------------------------- number of days 1,706 1,707 Print #iFileNumber, "" 1,708 Print #iFileNumber, " " 1,709 If Len(psFooterAfterCountID) > 0 Or Len(psFooterBeforeCalc) > 0 Then 1,710 If Nz(nCountIDs) <> 0 Then 1,711 Print #iFileNumber, Format(nCountIDs, "#,##0") & " " & Nz(psFooterAfterCountID) _ 1,712 & " " & Nz(psFooterBeforeCalc) & " " 1,713 End If 1,714 End If 1,715 If Nz(mTotalAmount) <> 0 Then 1,716 If Len(psFormatCode) > 0 Then 1,717 Print #iFileNumber, Format(mTotalAmount, psFormatCode) 1,718 Else 1,719 Print #iFileNumber, Format(mTotalAmount, "#,###.##;"""";""""") 1,720 End If 1,721 Print #iFileNumber, " " & Nz(psFooterBeforeDays) & " " 1,722 End If 1,723 Print #iFileNumber, Format(nNumDaysWithData, "0") & " " & Nz(psFooterAfterDays) 1,724 1,725 Print #iFileNumber, "" 1,726 1,727 '--------------------------------------- date 1,728 Print #iFileNumber, "" 1,729 Print #iFileNumber, "    " 1,730 Print #iFileNumber, Format(Now, "ddd, mmm d, yyyy, h:mm am/pm") 1,731 Print #iFileNumber, "" 1,732 1,733 1,734 WriteHTMLfooter iFileNumber 1,735 Close #iFileNumber 1,736 DoEvents: DoCmd.Hourglass True 1,737 1,738 ' Shell "C:\Program Files\Internet Explorer\iexplore.exe " & psPathFile, vbMaximizedFocus 1,739 ' DoEvents 1,740 1,741 Create_HTMLCalendar_exit: 1,742 1,743 ' On Error Resume Next 1,744 1,745 Debug.Print "HTML code generator written by Crystal Long" & vbCrLf & vbCrLf _ 1,746 & "Done generating " & vbCrLf & vbCrLf _ 1,747 & psPathFile 1,748 1,749 html_EndTime 1,750 1,751 Create_HTMLCalendar = True 1,752 1,753 Proc_Exit: 1,754 On Error Resume Next 1,755 If Not rs Is Nothing Then 1,756 rs.Close 1,757 Set rs = Nothing 1,758 End If 1,759 Set db = Nothing 1,760 Exit Function 1,761 1,762 Proc_Err: 1,763 MsgBox Err.Description, , _ 1,764 "ERROR " & Err.Number _ 1,765 & " Create_HTMLCalendar" 1,766 Resume Proc_Exit 1,767 Resume 1,768 1,769 End Function
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

WriteHTMLheader (39)

1,770   
1,771     '------------------------------------------------- WriteHTMLheader
1,772    Function WriteHTMLheader(iFileNumber As Integer, _ 
1,773        pTitleMain As String, _ 
1,774        pTitleKicker As String _ 
1,775        ) 
1,776   
1,777       Print #iFileNumber, "" 
1,778       Print #iFileNumber, "" 
1,779       Print #iFileNumber, "" </font>
<a name="M78_1780"><font class="tBrownSmall">1,780</font>   </a><font class="tCode">    If Len(Trim(pTitleKicker)) <> 0 Then </font>
<a name="M78_1781"><font class="tBrownSmall">1,781</font>   </a><font class="tCode">       Print #iFileNumber, pTitleKicker </font>
<a name="M78_1782"><font class="tBrownSmall">1,782</font>   </a><font class="tCode">    End If </font>
<a name="M78_1783"><font class="tBrownSmall">1,783</font>   </a><font class="tCode">    If Len(Trim(pTitleMain)) <> 0 Then </font>
<a name="M78_1784"><font class="tBrownSmall">1,784</font>   </a><font class="tCode">       Print #iFileNumber, " " & pTitleMain </font>
<a name="M78_1785"><font class="tBrownSmall">1,785</font>   </a><font class="tCode">    End If </font>
<a name="M78_1786"><font class="tBrownSmall">1,786</font>   </a><font class="tCode">    Print #iFileNumber, "" 
1,787   
1,788       Print #iFileNumber, "" 
1,789       Print #iFileNumber, "" 
1,790       Print #iFileNumber, "" 
1,791       Print #iFileNumber, "
" 1,792 If Len(Trim(pTitleKicker)) <> 0 Then 1,793 Print #iFileNumber, "" 1,794 Print #iFileNumber, pTitleKicker 1,795 Print #iFileNumber, "" 1,796 Print #iFileNumber, "
"
1,797 End If 1,798 If Len(Trim(pTitleMain)) <> 0 Then 1,799 Print #iFileNumber, "" 1,800 Print #iFileNumber, "" 1,801 Print #iFileNumber, pTitleMain 1,802 Print #iFileNumber, "" 1,803 Print #iFileNumber, "" 1,804 End If 1,805 Print #iFileNumber, "
"
1,806 1,807 1,808 End Function
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

WriteHTMLfooter (26)

1,809   
1,810   
1,811     '------------------------------------------------- WriteHTMLfooter
1,812    Function WriteHTMLfooter( _ 
1,813       iFileNumber As Integer _ 
1,814       , Optional pBooPrintBy As Boolean) 
1,815   
1,816       Print #iFileNumber, "" 
1,817       Print #iFileNumber, "
" 1,818 Print #iFileNumber, 1,819 Print #iFileNumber, ""
1,820 If Nz(pBooPrintBy, False) Then 1,821 Print #iFileNumber, "
"
1,822 Print #iFileNumber, "" 1,823 Print #iFileNumber, "Generated " & Format(Now(), "ddd, m-d-yy h:nn am/pm") 1,824 Print #iFileNumber, "" 1,825 End If 1,826 1,827 Print #iFileNumber, "

" 1,828 Print #iFileNumber, "written by Crystal 5-16-06 ... Oct 2014
strive4peace
"
1,829 1,830 Print #iFileNumber, "" 1,831 Print #iFileNumber, "" 1,832 1,833 1,834 End Function

      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

createXLSfile (14)

1,835   
1,836   
1,837     '------------------------------------------------- createXLSfile
1,838     'not called by this module or calendar tool report menu
1,839    Function createXLSfile(pTable) 
1,840       On Error GoTo createXLSfile_error 
1,841       Dim mFile As String 
1,842       mFile = CurrentProject.Path & "\" & pTable & ".xls" 
1,843       DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, pTable, mFile, True 
1,844       MsgBox "Done creating " & pTable & ".xls", , "Done" 
1,845       Exit Function 
1,846    createXLSfile_error: 
1,847       MsgBox Err.Description, , "ERROR " & Err.Number 
1,848    End Function 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Generate_Index (128)

1,849   
1,850     '------------------------------------------------- Generate_Index
1,851    Function Generate_Index(pPath As String, pTitle As String, Optional pNumColumns As Integer) As Boolean 
1,852   
1,853        'CALLS
1,854        '  WriteHTMLheader
1,855        '  WriteHTMLfooter
1,856   
1,857        'don't need to re-load directories to print TOC
1,858       Generate_Index = False 
1,859   
1,860       On Error GoTo Proc_Err 
1,861   
1,862       Dim i As Integer, nNumPerColumn As Integer, mStr3 As String 
1,863       Dim iFileNumber As Integer, sFilenameHTML_Index As String 
1,864   
1,865       iFileNumber = FreeFile 
1,866       sFilenameHTML_Index = pPath & "\index.html" 
1,867   
1,868       On Error Resume Next 
1,869       Close #iFileNumber 
1,870       If Dir(sFilenameHTML_Index) <> "" Then 
1,871          Kill sFilenameHTML_Index 
1,872          DoEvents: DoCmd.Hourglass True 
1,873       End If 
1,874   
1,875       On Error GoTo Proc_Err 
1,876   
1,877        '------------------ read directory into an array
1,878       Dim arrFile() As String 
1,879       i = 1 
1,880       ReDim Preserve arrFile(1) 
1,881       arrFile(1) = Dir(pPath & "\*.html") 
1,882   
1,883       If arrFile(1) = "" Then 
1,884          Generate_Index = True 
1,885       Else 
1,886          Do While arrFile(i) <> "" 
1,887             i = i + 1 
1,888             ReDim Preserve arrFile(i) 
1,889             arrFile(i) = Dir() 
1,890          Loop 
1,891           'remove last blank entry
1,892          ReDim Preserve arrFile(i - 1) 
1,893   
1,894           '------------------ sort the array using WizHook
1,895          Access.WizHook.SortStringArray arrFile 
1,896       End If 
1,897   
1,898       Open sFilenameHTML_Index For Output As #iFileNumber 
1,899       Call WriteHTMLheader(iFileNumber, pTitle & " Index", "") 
1,900   
1,901       DoEvents: DoCmd.Hourglass True 
1,902   
1,903       Print #iFileNumber, "
"
1,904 1,905 If arrFile(1) <> "" Then 1,906 1,907 If Nz(pNumColumns, 0) > 0 Then 1,908 nNumPerColumn = CInt((UBound(arrFile) + pNumColumns - 1) \ pNumColumns) 1,909 Print #iFileNumber, "" 1,910 Print #iFileNumber, "" 1,911 For i = 1 To pNumColumns 1,912 Print #iFileNumber, "" 1,922 Next i 1,923 Print #iFileNumber, "
" 1,913 Print #iFileNumber, "" 1,914 'first EmpNum 1,915 1,916 Print #iFileNumber, Left(arrFile(1 + (i - 1) * nNumPerColumn), 6) _ 1,917 & " to " & Left(arrFile(IIf(i = pNumColumns, UBound(arrFile), _ 1,918 (i * nNumPerColumn))), 6) 1,919 1,920 Print #iFileNumber, "" 1,921 Print #iFileNumber, "
" 1,924 Else 1,925 nNumPerColumn = 0 1,926 End If 1,927 1,928 mStr3 = "" 1,929 For i = LBound(arrFile) To UBound(arrFile) 1,930 If arrFile(i) <> "index.html" And Len(arrFile(i)) > 0 Then 1,931 1,932 Print #iFileNumber, " 1,933 & """ target = e" & Format(i, "0") & ">" 1,934 'strip file extension 1,935 If mStr3 <> Left(arrFile(i), 3) Then 1,936 'color first 3 characters 1,937 Print #iFileNumber, " " & Left(arrFile(i), 3) & " " 1,938 Print #iFileNumber, Mid(arrFile(i), 4, Len(arrFile(i)) - 8) 1,939 mStr3 = Left(arrFile(i), 3) 1,940 Else 1,941 'print as is 1,942 Print #iFileNumber, Left(arrFile(i), Len(arrFile(i)) - 5) 1,943 End If 1,944 Print #iFileNumber, "" 1,945 1,946 'skip to next column? 1,947 If Nz(pNumColumns, 0) > 0 Then 1,948 If i Mod nNumPerColumn = 0 Then 1,949 If i <> UBound(arrFile) Then 1,950 Print #iFileNumber, "" 1,951 End If 1,952 Else 1,953 Print #iFileNumber, "
"
1,954 End If 1,955 Else 1,956 Print #iFileNumber, "
"
1,957 End If 1,958 End If 1,959 1,960 Next i 1,961 If Nz(pNumColumns, 0) > 0 Then 1,962 Print #iFileNumber, "
" 1,963 End If 1,964 End If 1,965 1,966 WriteHTMLfooter iFileNumber, True 1,967 Close #iFileNumber 1,968 DoEvents: DoCmd.Hourglass True 1,969 1,970 Proc_Exit: 1,971 Exit Function 1,972 Proc_Err: 1,973 MsgBox Err.Description, , "ERROR " & Err.Number & " Generate Index: " & pPath 1,974 Resume Proc_Exit 1,975 Resume 1,976 End Function
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Generate_Index_TOC (84)

1,977   
1,978     '------------------------------------------------- Generate_Index_TOC
1,979    Sub Generate_Index_TOC(pPath As String, pTitle As String) 
1,980        'CALLS
1,981        'WriteHTMLheader
1,982        'WriteHTMLfooter
1,983   
1,984       On Error GoTo Proc_Err 
1,985   
1,986       Dim i As Integer 
1,987       Dim iFileNumber As Integer, sFilenameHTML_Index As String 
1,988   
1,989       iFileNumber = FreeFile 
1,990       sFilenameHTML_Index = pPath & "\index.html" 
1,991   
1,992       On Error Resume Next 
1,993       Close #iFileNumber 
1,994       If Dir(sFilenameHTML_Index) <> "" Then 
1,995          Kill sFilenameHTML_Index 
1,996          DoEvents: DoCmd.Hourglass True 
1,997       End If 
1,998   
1,999       On Error GoTo Proc_Err 
2,000   
2,001        '------------------ set WizHook Key
2,002       Access.WizHook.Key = 51488399 
2,003   
2,004        '------------------ read directory into an array
2,005       Dim arrFile() As String 
2,006       i = 1 
2,007       ReDim arrFile(1) 
2,008       arrFile(1) = Dir(pPath & "\*.*", vbDirectory) 
2,009   
2,010       Do While arrFile(i) <> "" 
2,011         If arrFile(i) <> "." And arrFile(i) <> ".." Then 
2,012             If (GetAttr(pPath & "\" & arrFile(i)) And vbDirectory) = vbDirectory Then 
2,013                 'if there is no Index.html file in that directory, then do not include it
2,014                 '------------------ use FileExists in WizHook
2,015                If Access.WizHook.FileExists(pPath & "\" & arrFile(i) & "\Index.html") Then 
2,016                   i = i + 1 
2,017                   ReDim Preserve arrFile(i) 
2,018                End If 
2,019             End If 
2,020          End If 
2,021          arrFile(i) = Dir() 
2,022       Loop 
2,023        'remove blank entry
2,024       ReDim Preserve arrFile(i - 1) 
2,025   
2,026        '------------------ sort the array
2,027       Access.WizHook.SortStringArray arrFile 
2,028   
2,029        '----------------------- open file for output
2,030   
2,031       Open sFilenameHTML_Index For Output As #iFileNumber 
2,032       WriteHTMLheader iFileNumber, pTitle & " Index", "" 
2,033   
2,034       DoEvents: DoCmd.Hourglass True 
2,035   
2,036       Print #iFileNumber, "
"
2,037 2,038 2,039 Print #iFileNumber, "

" 2,040 2,041 For i = LBound(arrFile) To UBound(arrFile) 2,042 Print #iFileNumber, " 2,043 & """ target = e" & Format(i, "0") & ">" 2,044 Print #iFileNumber, arrFile(i) 2,045 Print #iFileNumber, "" 2,046 Print #iFileNumber, "

"
2,047 Next i 2,048 Print #iFileNumber, "

" 2,049 2,050 WriteHTMLfooter iFileNumber 2,051 Close #iFileNumber 2,052 DoEvents: DoCmd.Hourglass True 2,053 Proc_Exit: 2,054 On Error Resume Next 2,055 Exit Sub 2,056 Proc_Err: 2,057 MsgBox Err.Description, , "ERROR " & Err.Number & " Generate Index: " & pPath 2,058 Resume Proc_Exit 2,059 Resume 2,060 End Sub
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

html_EndTime (8)

2,061   
2,062     '------------------------------------------------- CreateSummaryHTML - LOCAL
2,063   
2,064     '---------------------------------------------------- Local copies of public functions
2,065    Sub html_EndTime() 
2,066       Debug.Print "--- END-------------" & DateDiff("s", gStartTime, Now()) & " seconds" 
2,067       DoCmd.Hourglass False 
2,068    End Sub 
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

html_StartTime (9)

2,069   
2,070    Sub html_StartTime(Optional pMsg) 
2,071       On Error Resume Next 
2,072       gStartTime = Now() 
2,073       DoCmd.Hourglass True 
2,074       If IsMissing(pMsg) Then Exit Sub 
2,075       Debug.Print "--- START-------------" & pMsg & " ----- " & CStr(gStartTime) 
2,076    End Sub 
2,077   
      Goto Top       Goto Form_f_MENU_HTMLCalendar       Goto Index

Form_f_Payments_sub (88)

PROCEDURES       Goto Top       Goto Form_f_Payments_sub       Goto Forms       Goto Index
  1. Declaration Lines (31)
  2. DtIDTran_DblClick (57)

Declaration Lines (31)

1        Option Compare Database 
2        Option Explicit 
3         '=======================================================
4         ' f_Payments_sub
5         '=======================================================
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, 140629
27        ' ~ Crystal
28        '              * have an awesome day :)
29        '                                                   www.AccessMVP.com/strive4peace
30        ' END LICENSE NOTICE
31        '============================================================
      Goto Top       Goto Form_f_Payments_sub       Goto Index

DtIDTran_DblClick (57)

32      
33       Private Sub DtIDTran_DblClick(Cancel As Integer) 
34        '130908
35           DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog 
36       End Sub 
37      
38      
39        'Private Sub SetMyRecordSource(Optional pBooAll As Boolean = False)
40        ''130908, 1002
41        '   On Error GoTo Proc_Err
42        '   Dim sSQL As String
43        '   sSQL = "SELECT Payments.* FROM Payments"
44        '   If Not pBooAll Then
45        '      sSQL = sSQL & " WHERE IsNull([InvoiceID]) "
46        '   End If
47        '   sSQL = sSQL & " ORDER BY Payments.DtIDTran;"
48        '   Me.RecordSource = sSQL
49        '
50        'Proc_Exit:
51        '   On Error Resume Next
52        '   Exit Sub
53        '
54        'Proc_Err:
55        '   MsgBox Err.Description, , _
56        '        "ERROR " & Err.Number _
57        '        & "   SetMyRecordSource : " & Me.Name
58        '
59        '   Resume Proc_Exit
60        '   Resume
61        'End Sub
62        '
63        'Private Sub Form_Open(Cancel As Integer)
64        ''130908, 1002, 03
65        '   On Error GoTo Proc_Err
66        '   Dim sSQL As String _
67        '      , booAll As Boolean
68        '   booAll = True
69        ''   If IsSubform(Me) Then
70        ''      If InStr(Me.Parent.Name, "Project") > 0 Then
71        ''         booAll = False
72        ''      End If
73        ''   End If
74        '   Call SetMyRecordSource(booAll)
75        '
76        'Proc_Exit:
77        '   On Error Resume Next
78        '   Exit Sub
79        '
80        'Proc_Err:
81        '   MsgBox Err.Description, , _
82        '        "ERROR " & Err.Number _
83        '        & "   Form_Open : " & Me.Name
84        '
85        '   Resume Proc_Exit
86        '   Resume
87        'End Sub
88      
      Goto Top       Goto Form_f_Payments_sub       Goto Index

Form_f_PleaseWait (48)

PROCEDURES       Goto Top       Goto Form_f_PleaseWait       Goto Forms       Goto Index
  1. CalculateProgress (35)
  2. Declaration Lines (2)
  3. lbl_Footer1_Click (6)
  4. lbl_Footer2_Click (5)

Declaration Lines (2)

1        Option Compare Database 
2        Option Explicit 
      Goto Top       Goto Form_f_PleaseWait       Goto Index

CalculateProgress (35)

3       
4         '
5         ' Crystal
6         ' strive4peace2012@yahoo.com
7         '============================================================ LICENSE NOTICE -- must not be modified
8         ' This software is licensed to you under CC BY-NC-SA 3.0
9         '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
10        ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
11        '
12        ' You are free to:
13        '    Share  copy and redistribute the material in any medium or format
14        '    Adapt  remix, transform, and build upon the material
15        ' The licensor cannot revoke these freedoms as long as you follow these terms:
16        '    Attribution  You must give appropriate credit, provide a link to the license,
17        '                   and indicate if changes were made.
18        '                   You may do so in any reasonable manner,
19        '                   but not in any way that suggests the licensor endorses you or your use.
20        '    NonCommercial  You may not use the material for commercial purposes.
21        '    ShareAlike  If you remix, transform, or build upon the material,
22        '                 you must distribute your contributions under the same license as the original.
23        '
24        ' many procedures and module names contain author or controbitor names that must be left intact
25        ' if you make changes, add your name, date, and descriptive information to the comments
26        '
27        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140630
28        ' END LICENSE NOTICE
29        '============================================================
30       Public Sub CalculateProgress(pPercentDone As Double) 
31        '120124
32           '1440 twips/inch
33          With Me.txtProgress 
34             .Value = pPercentDone 
35             .Width = pPercentDone * 3.5 * 1140 
36          End With 
37       End Sub 
      Goto Top       Goto Form_f_PleaseWait       Goto Index

lbl_Footer1_Click (6)

38      
39       Private Sub lbl_Footer1_Click() 
40        '120124
41          Application.FollowHyperlink _ 
42             "mailto: strive4peace2012@yahoo.com?subject=Please Wait Comment" 
43       End Sub 
      Goto Top       Goto Form_f_PleaseWait       Goto Index

lbl_Footer2_Click (5)

44      
45       Private Sub lbl_Footer2_Click() 
46        '120124
47          Call lbl_Footer1_Click 
48       End Sub 
      Goto Top       Goto Form_f_PleaseWait       Goto Index

Form_f_PopupCalendar (1571)

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

Declaration Lines (53)

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       Dim mActiveControl As Control   ' Open 
52       Dim mPickDate As Date   ' Open 
53       Dim gBooTime As Boolean   ' Load 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

Update_ExternalForms (34)

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

cmd_Cancel_Click (6)

88      
89       Private Sub cmd_Cancel_Click() 
90        '120626
91          On Error Resume Next 
92          DoCmd.Close acForm, Me.Name, acSaveNo 
93       End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_Close_Click (37)

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

UseTheTime (12)

131     
132      Private Function UseTheTime(pBoo As Boolean) 
133       '120626, 27
134         On Error Resume Next 
135         Me.chkUseTime = pBoo 
136         Me.Label_chkUseTime.FontBold = pBoo 
137     
138         If Me.txtAP.Visible <> pBoo Then 
139            cal_ShowHideControlsTag pBoo, "Time" 
140         End If 
141     
142      End Function 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_CurrentTime_Click (11)

143     
144      Private Sub cmd_CurrentTime_Click() 
145       '120626
146         On Error Resume Next 
147     
148         UseTheTime True 
149         Me.txtHr.Value = Hour(Now()) Mod 12 
150         Me.txtMin.Value = Minute(Now()) 
151         Me.txtAP = IIf(DatePart("h", Now()) >= 12, "pm", "am") 
152         Me.txtHr.SetFocus 
153      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmdMonth_Click (7)

154     
155      Private Sub cmdMonth_Click() 
156       '120627
157         On Error Resume Next 
158         MsgBox cal_GetBirthstone(Month(Me.txtCalendarDate)), , "Birthstone for " & Me.cmdMonth.Caption 
159     
160      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmdYr_Click (10)

161     
162      Private Sub cmdYr_Click() 
163       '120627
164         On Error Resume Next 
165          'year in roman numbers
166          'get Chinese zodiac animal?
167         Dim nYear As Integer 
168         nYear = CInt(Me.cmdYr.Caption) 
169         MsgBox cal_GetRoman(nYear), , nYear & " in Roman Numbers" 
170      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

Form_Open (84)

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

Form_Load (63)

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

DayClick (43)

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

cmd_Reset_Click (31)

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

cmd_AddDays_Click (27)

392     
393      Private Sub cmd_AddDays_Click() 
394       '120627
395         Dim nDays As Long 
396     
397         If IsNull(Me.txtDays) Then 
398            Me.txtDays.SetFocus 
399            MsgBox "Specify number of days to add or subtract", , "Can't add days, no number specified" 
400            Exit Sub 
401         End If 
402         nDays = Me.txtDays 
403         If nDays = 0 Then 
404            Me.txtDays.SetFocus 
405            MsgBox "Specify number of days to add or subtract", , "Can't add days, no number specified" 
406            Exit Sub 
407         End If 
408     
409         Dim nDate As Date 
410         nDate = Me.txtCalendarDate 
411     
412         nDate = DateSerial(Year(nDate), Month(nDate), Day(nDate) + nDays) 
413     
414         Set_Calendar nDate 
415         Update_ExternalForms nDate 
416     
417     
418      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_Now_Click (18)

419     
420     
421      Private Sub cmd_Now_Click() 
422       '120626, 27
423         On Error Resume Next 
424     
425         Dim nDate As Date 
426         nDate = Date 
427     
428         Me.txtCalendarDate = nDate 
429     
430         Set_Calendar nDate 
431         Update_ExternalForms nDate 
432     
433         UseTheTime True 
434         cmd_CurrentTime_Click 
435     
436      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmdMonthAdd_Click (19)

437     
438      Private Sub cmdMonthAdd_Click() 
439       '120512, 120622
440       ' CALLS
441          ' Add_SetCalendar
442          ' Update_ExternalForms
443     
444          On Error GoTo Proc_Err 
445          Dim nDate As Date 
446          nDate = Me.txtCalendarDate 
447          Add_SetCalendar nDate, 0, 1, 0 
448          Update_ExternalForms nDate 
449     
450      Proc_Exit: 
451         On Error Resume Next 
452         Exit Sub 
453      Proc_Err: 
454         Resume Proc_Exit 
455      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmdMonthSub_Click (16)

456     
457      Private Sub cmdMonthSub_Click() 
458       '120512 Crystal, 120622
459           'move calendar back one month
460       '
461       ' CALLS
462          ' Add_SetCalendar
463          ' Update_ExternalForms
464         On Error Resume Next 
465     
466         Dim nDate As Date 
467         nDate = Me.txtCalendarDate 
468         Add_SetCalendar nDate, 0, -1, 0 
469         Update_ExternalForms nDate 
470     
471      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmdYrAdd_Click (20)

472     
473     
474     
475      Private Sub cmdYrAdd_Click() 
476       '120512, 120622
477       ' CALLS
478          ' Add_SetCalendar
479          ' Update_ExternalForms
480     
481          Dim nDate As Date 
482          nDate = Me.txtCalendarDate 
483          Add_SetCalendar nDate, 1, 0, 0 
484          Update_ExternalForms nDate 
485     
486      Proc_Exit: 
487         On Error Resume Next 
488         Exit Sub 
489      Proc_Err: 
490         Resume Proc_Exit 
491      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmdYrSub_Click (18)

492     
493      Private Sub cmdYrSub_Click() 
494       '120512, 120622
495       ' CALLS
496          ' Add_SetCalendar
497          ' Update_ExternalForms
498     
499          Dim nDate As Date 
500          nDate = Me.txtCalendarDate 
501          Add_SetCalendar nDate, -1, 0, 0 
502          Update_ExternalForms nDate 
503     
504      Proc_Exit: 
505         On Error Resume Next 
506         Exit Sub 
507      Proc_Err: 
508         Resume Proc_Exit 
509      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_M6add_Click (20)

510     
511     
512      Private Sub cmd_M6add_Click() 
513       '120625
514       ' CALLS
515          ' Add_SetCalendar
516          ' Update_ExternalForms
517     
518          On Error GoTo Proc_Err 
519          Dim nDate As Date 
520          nDate = Me.txtCalendarDate 
521          Add_SetCalendar nDate, 0, 6, 0 
522          Update_ExternalForms nDate 
523     
524      Proc_Exit: 
525         On Error Resume Next 
526         Exit Sub 
527      Proc_Err: 
528         Resume Proc_Exit 
529      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_M6sub_Click (19)

530     
531      Private Sub cmd_M6sub_Click() 
532       '120625
533       ' CALLS
534          ' Add_SetCalendar
535          ' Update_ExternalForms
536     
537          On Error GoTo Proc_Err 
538          Dim nDate As Date 
539          nDate = Me.txtCalendarDate 
540          Add_SetCalendar nDate, 0, -6, 0 
541          Update_ExternalForms nDate 
542     
543      Proc_Exit: 
544         On Error Resume Next 
545         Exit Sub 
546      Proc_Err: 
547         Resume Proc_Exit 
548      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_Today_Click (17)

549     
550      Private Sub cmd_Today_Click() 
551       '120512, 120622
552       ' CALLS
553          ' Set_Calendar
554          ' Update_ExternalForms
555     
556          On Error GoTo Proc_Err 
557          Set_Calendar Date 
558          Update_ExternalForms Date 
559     
560      Proc_Exit: 
561         On Error Resume Next 
562         Exit Sub 
563      Proc_Err: 
564         Resume Proc_Exit 
565      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_W1add_Click (19)

566     
567      Private Sub cmd_W1add_Click() 
568       '120625
569       ' CALLS
570          ' Add_SetCalendar
571          ' Update_ExternalForms
572     
573          On Error GoTo Proc_Err 
574          Dim nDate As Date 
575          nDate = Me.txtCalendarDate 
576          Add_SetCalendar nDate, 0, 0, 7 
577          Update_ExternalForms nDate 
578     
579      Proc_Exit: 
580         On Error Resume Next 
581         Exit Sub 
582      Proc_Err: 
583         Resume Proc_Exit 
584      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_W1sub_Click (19)

585     
586      Private Sub cmd_W1sub_Click() 
587       '120625
588       ' CALLS
589          ' Add_SetCalendar
590          ' Update_ExternalForms
591     
592          On Error GoTo Proc_Err 
593          Dim nDate As Date 
594          nDate = Me.txtCalendarDate 
595          Add_SetCalendar nDate, 0, 0, -7 
596          Update_ExternalForms nDate 
597     
598      Proc_Exit: 
599         On Error Resume Next 
600         Exit Sub 
601      Proc_Err: 
602         Resume Proc_Exit 
603      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_Q1add_Click (14)

604     
605      Private Sub cmd_Q1add_Click() 
606       '120701
607          On Error GoTo Proc_Err 
608          Dim nDate As Date 
609          nDate = Me.txtCalendarDate 
610          Add_SetCalendar nDate, 0, 3, 0 
611          Update_ExternalForms nDate 
612      Proc_Exit: 
613         On Error Resume Next 
614         Exit Sub 
615      Proc_Err: 
616         Resume Proc_Exit 
617      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_Q1sub_Click (14)

618     
619      Private Sub cmd_Q1sub_Click() 
620       '120701
621          On Error GoTo Proc_Err 
622          Dim nDate As Date 
623          nDate = Me.txtCalendarDate 
624          Add_SetCalendar nDate, 0, -3, 0 
625          Update_ExternalForms nDate 
626      Proc_Exit: 
627         On Error Resume Next 
628         Exit Sub 
629      Proc_Err: 
630         Resume Proc_Exit 
631      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_Y10add_Click (14)

632     
633      Private Sub cmd_Y10add_Click() 
634       '120701
635          On Error GoTo Proc_Err 
636          Dim nDate As Date 
637          nDate = Me.txtCalendarDate 
638          Add_SetCalendar nDate, 10, 0, 0 
639          Update_ExternalForms nDate 
640      Proc_Exit: 
641         On Error Resume Next 
642         Exit Sub 
643      Proc_Err: 
644         Resume Proc_Exit 
645      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd_Y10sub_Click (14)

646     
647      Private Sub cmd_Y10sub_Click() 
648       '120701
649          On Error GoTo Proc_Err 
650          Dim nDate As Date 
651          nDate = Me.txtCalendarDate 
652          Add_SetCalendar nDate, -10, 0, 0 
653          Update_ExternalForms nDate 
654      Proc_Exit: 
655         On Error Resume Next 
656         Exit Sub 
657      Proc_Err: 
658         Resume Proc_Exit 
659      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

txtCalendarDate_AfterUpdate (14)

660     
661      Private Sub txtCalendarDate_AfterUpdate() 
662       '120701
663          Dim nDate As Date 
664          nDate = Me.txtCalendarDate 
665          Set_Calendar nDate 
666          Update_ExternalForms nDate 
667     
668      Proc_Exit: 
669         On Error Resume Next 
670         Exit Sub 
671      Proc_Err: 
672         Resume Proc_Exit 
673      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmdDayAdd_Click (18)

674     
675      Private Sub cmdDayAdd_Click() 
676       '120623
677       ' CALLS
678          ' Add_SetCalendar
679          ' Update_ExternalForms
680     
681          Dim nDate As Date 
682          nDate = Me.txtCalendarDate 
683          Add_SetCalendar nDate, 0, 0, 1 
684          Update_ExternalForms nDate 
685     
686      Proc_Exit: 
687         On Error Resume Next 
688         Exit Sub 
689      Proc_Err: 
690         Resume Proc_Exit 
691      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmdDaySub_Click (19)

692     
693      Private Sub cmdDaySub_Click() 
694       '120623
695       ' CALLS
696          ' Add_SetCalendar
697          ' Update_ExternalForms
698     
699          Dim nDate As Date 
700          nDate = Me.txtCalendarDate 
701          Add_SetCalendar nDate, 0, 0, -1 
702          Update_ExternalForms nDate 
703     
704      Proc_Exit: 
705         On Error Resume Next 
706         Exit Sub 
707      Proc_Err: 
708         Resume Proc_Exit 
709      End Sub 
710       '---------------------------------------------------------------------
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd11_Click (4)

711     
712      Private Sub cmd11_Click() 
713          DayClick 
714      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd12_Click (4)

715     
716      Private Sub cmd12_Click() 
717          DayClick 
718      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd13_Click (4)

719     
720      Private Sub cmd13_Click() 
721          DayClick 
722      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd14_Click (4)

723     
724      Private Sub cmd14_Click() 
725          DayClick 
726      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd15_Click (4)

727     
728      Private Sub cmd15_Click() 
729          DayClick 
730      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd16_Click (4)

731     
732      Private Sub cmd16_Click() 
733          DayClick 
734      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd17_Click (4)

735     
736      Private Sub cmd17_Click() 
737          DayClick 
738      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd21_Click (4)

739     
740      Private Sub cmd21_Click() 
741          DayClick 
742      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd22_Click (4)

743     
744      Private Sub cmd22_Click() 
745          DayClick 
746      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd23_Click (4)

747     
748      Private Sub cmd23_Click() 
749          DayClick 
750      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd24_Click (4)

751     
752      Private Sub cmd24_Click() 
753          DayClick 
754      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd25_Click (4)

755     
756      Private Sub cmd25_Click() 
757          DayClick 
758      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd26_Click (4)

759     
760      Private Sub cmd26_Click() 
761          DayClick 
762      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd27_Click (4)

763     
764      Private Sub cmd27_Click() 
765          DayClick 
766      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd31_Click (4)

767     
768      Private Sub cmd31_Click() 
769          DayClick 
770      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd32_Click (4)

771     
772      Private Sub cmd32_Click() 
773          DayClick 
774      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd33_Click (4)

775     
776      Private Sub cmd33_Click() 
777          DayClick 
778      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd34_Click (4)

<
779     
780      Private Sub cmd34_Click() 
781          DayClick 
782      End Sub