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

cmd35_Click (4)

783     
784      Private Sub cmd35_Click() 
785          DayClick 
786      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd36_Click (4)

787     
788      Private Sub cmd36_Click() 
789          DayClick 
790      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd37_Click (4)

791     
792      Private Sub cmd37_Click() 
793          DayClick 
794      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd41_Click (4)

795     
796      Private Sub cmd41_Click() 
797          DayClick 
798      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd42_Click (4)

799     
800      Private Sub cmd42_Click() 
801          DayClick 
802      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd43_Click (4)

803     
804      Private Sub cmd43_Click() 
805          DayClick 
806      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd44_Click (4)

807     
808      Private Sub cmd44_Click() 
809          DayClick 
810      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd45_Click (4)

811     
812      Private Sub cmd45_Click() 
813          DayClick 
814      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd46_Click (4)

815     
816      Private Sub cmd46_Click() 
817          DayClick 
818      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd47_Click (4)

819     
820      Private Sub cmd47_Click() 
821          DayClick 
822      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd51_Click (4)

823     
824      Private Sub cmd51_Click() 
825          DayClick 
826      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd52_Click (4)

827     
828      Private Sub cmd52_Click() 
829          DayClick 
830      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd53_Click (4)

831     
832      Private Sub cmd53_Click() 
833          DayClick 
834      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd54_Click (4)

835     
836      Private Sub cmd54_Click() 
837          DayClick 
838      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd55_Click (4)

839     
840      Private Sub cmd55_Click() 
841          DayClick 
842      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd56_Click (4)

843     
844      Private Sub cmd56_Click() 
845          DayClick 
846      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd57_Click (4)

847     
848      Private Sub cmd57_Click() 
849          DayClick 
850      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd61_Click (4)

851     
852      Private Sub cmd61_Click() 
853          DayClick 
854      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd62_Click (4)

855     
856      Private Sub cmd62_Click() 
857          DayClick 
858      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd63_Click (4)

859     
860      Private Sub cmd63_Click() 
861          DayClick 
862      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd64_Click (4)

863     
864      Private Sub cmd64_Click() 
865          DayClick 
866      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd65_Click (4)

867     
868      Private Sub cmd65_Click() 
869          DayClick 
870      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd66_Click (4)

871     
872      Private Sub cmd66_Click() 
873          DayClick 
874      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cmd67_Click (4)

875     
876      Private Sub cmd67_Click() 
877          DayClick 
878      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

hDn_Click (11)

879     
880       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Adjust Date
881      Private Sub hDn_Click() 
882         UseTheTime True 
883       'Mark Davis
884         If Nz(Me.txtHr.Value, 1) = 1 Then 
885             Me.txtHr.Value = 12 
886           Else 
887             Me.txtHr.Value = Me.txtHr.Value - 1 
888         End If 
889      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

hUp_Click (10)

890     
891      Private Sub hUp_Click() 
892         UseTheTime True 
893       'Mark Davis
894          If Nz(Me.txtHr.Value, 12) = 12 Then 
895              Me.txtHr.Value = 1 
896            Else 
897              Me.txtHr.Value = Me.txtHr.Value + 1 
898          End If 
899      End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

HrUpDn (39)

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

MinUpDn (21)

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

AmPm (9)

960     
961      Private Function AmPm() 
962       'Mark Davis
963          If Me.txtAP.Value = "am" Then 
964              Me.txtAP.Value = "pm" 
965          Else 
966              Me.txtAP.Value = "am" 
967          End If 
968      End Function 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

Add_SetCalendar (30)

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

Set_Calendar (169)

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

Set_DefaultFormat (26)

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

Mark_TodayAndDate (71)

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

ShowDatePickerMessage (13)

1,265   
1,266    Private Sub ShowDatePickerMessage() 
1,267     '120701
1,268       MsgBox "To use this popup calendar in a form," _ 
1,269          & " assign the DOUBLE-CLICK event " _ 
1,270          & " of date control on a form to" & vbCrLf & vbCrLf _ 
1,271          & "   DoCmd.OpenForm ""f_PopupCalendar""" & vbCrLf & vbCrLf _ 
1,272          & vbCrLf & vbCrLf _ 
1,273          & "To use this in another database, " _ 
1,274          & "import form f_PopupCalendar" _ 
1,275          , , "Popup Calendar by Crystal" 
1,276   
1,277    End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cal_GetCardinalNumber (28)

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

cal_GetCol4Calendar (5)

1,306   
1,307    Public Function cal_GetCol4Calendar(pDate As Date) As Integer 
1,308       cal_GetCol4Calendar = 0 
1,309       cal_GetCol4Calendar = Weekday(pDate, vbSunday) 
1,310    End Function 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

cal_GetRow4Calendar (38)

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

cal_GetDowN4Calendar (26)

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

cal_IsSubform (17)

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

cal_ShowHideControlsTag (34)

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

cal_GetRoman (51)

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

cal_GetBirthstone (19)

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

Label_strive4peace_Click (7)

1,496   
1,497    Private Sub Label_strive4peace_Click() 
1,498     '120627
1,499       On Error Resume Next 
1,500       Application.FollowHyperlink _ 
1,501         "mailto: strive4peace2012@yahoo.com?subject=Popup Calendar comment " 
1,502    End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

txtCalendarDate_BeforeUpdate (18)

1,503   
1,504   
1,505   
1,506    Private Sub txtCalendarDate_BeforeUpdate(Cancel As Integer) 
1,507     '120701
1,508       On Error Resume Next 
1,509       If IsNull(Me.ActiveControl) Then 
1,510          Me.ActiveControl.Undo 
1,511          Cancel = True 
1,512          Exit Sub 
1,513       End If 
1,514       If Not IsDate(Me.ActiveControl) Then 
1,515          MsgBox Me.ActiveControl & " is not a valid date", , "Cannot change" 
1,516          Me.ActiveControl.Undo 
1,517          Cancel = True 
1,518          Exit Sub 
1,519       End If 
1,520    End Sub 
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

txtDate_AfterUpdate (41)

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

txtDays_DblClick (10)

1,562   
1,563    Private Sub txtDays_DblClick(Cancel As Integer) 
1,564     '120627
1,565       On Error Resume Next 
1,566       If IsNull(Me.ActiveControl) Then Exit Sub 
1,567       Me.txtDays = -Me.txtDays 
1,568    End Sub 
1,569   
1,570   
1,571   
      Goto Top       Goto Form_f_PopupCalendar       Goto Index

Form_f_PRJECT (267)

PROCEDURES       Goto Top       Goto Form_f_PRJECT       Goto Forms       Goto Index
  1. cmd_MakeInvoice_Click (149)
  2. cmd_New_Click (8)
  3. cmd_Print_Click (6)
  4. Declaration Lines (29)
  5. fnd_Customer_AfterUpdate (5)
  6. fnd_Expens_AfterUpdate (5)
  7. fnd_Invoice_AfterUpdate (6)
  8. fnd_Payment_AfterUpdate (6)
  9. fnd_Project_AfterUpdate (6)
  10. Form_BeforeUpdate (5)
  11. Form_Current (15)
  12. PrjDate1_DblClick (4)
  13. PrjDate2_DblClick (4)
  14. RowSource_LstInvoices (19)

Declaration Lines (29)

1        Option Compare Database 
2        Option Explicit 
3         'SELECT prj.ProjectID, inv.InvoiceID, inv.dtInv, inv.dtPaid, inv.invNote FROM Projects AS prj INNER JOIN Invoices AS inv ON prj.ProjectID = inv.ProjectID ORDER BY inv.IsPaid DESC , inv.dtInv DESC;
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        '============================================================
      Goto Top       Goto Form_f_PRJECT       Goto Index

cmd_MakeInvoice_Click (149)

30      
31       Private Sub cmd_MakeInvoice_Click() 
32        '131002
33          On Error GoTo Proc_Err 
34      
35          If Me.Dirty Then 
36             DoCmd.RunCommand acCmdSaveRecord 
37          End If 
38      
39          If Me.NewRecord Then 
40             MsgBox "No Current Record" _ 
41             , , "Cannot create Invoice" 
42             Exit Sub 
43          End If 
44      
45          If IsNull(Me.CustomerID) Then 
46             MsgBox "Customer is not specified" _ 
47             , , "Cannot create Invoice" 
48             Exit Sub 
49          End If 
50      
51          Dim nNumExp As Long _ 
52             , nNumPmt As Long _ 
53             , nInvoiceID As Long _ 
54             , nProjectID As Long _ 
55             , nCustomerID As Long _ 
56             , nCID As Long _ 
57             , sAddress As String _ 
58             , sCSZC As String _ 
59             , sCustomer As String _ 
60             , sSQL As String _ 
61             , sMsg As String 
62      
63          Dim db As DAO.Database _ 
64             , rs As DAO.Recordset 
65      
66          nCustomerID = Me.CustomerID 
67          nProjectID = Me.ProjectID 
68          nCID = Me.CustomerID.Column(2) 
69      
70           'see if there are any items to invoice
71      
72          nNumExp = DCount("*" _ 
73             , "Expenses" _ 
74             , "ProjectID=" & nProjectID _ 
75             & " AND IsNull(InvoiceID)") 
76      
77          nNumPmt = DCount("*" _ 
78             , "Payments" _ 
79             , "ProjectID=" & nProjectID _ 
80             & " AND IsNull(InvoiceID)") 
81      
82          If Not (nNumExp + nNumPmt) > 0 Then 
83             MsgBox "There are not items to invoice" _ 
84             , , "Cannot create Invoice" 
85             Exit Sub 
86          End If 
87      
88           'get address
89          Set db = CurrentDb 
90      
91          sAddress = "" 
92          sCSZC = "" 
93          sCustomer = "" 
94      
95          sSQL = "SELECT usys_Contact_PrimaryAddress.* " _ 
96             & " FROM usys_Contact_PrimaryAddress " _ 
97             & " WHERE CID=" & nCID 
98          Set rs = db.OpenRecordset(sSQL, dbOpenSnapshot) 
99          With rs 
100            If Not .EOF Then 
101               If Not IsNull(!Addres) Then sAddress = !Addres 
102               If Not IsNull(!CSZC) Then sCSZC = !CSZC 
103               If Not IsNull(!LastFirst) Then sCustomer = !LastFirst 
104            End If 
105            .Close 
106         End With 
107         Set rs = Nothing 
108     
109          'create a new invoice
110         sSQL = "Invoices" 
111     
112         Set rs = db.OpenRecordset(sSQL, dbOpenDynaset, dbAppendOnly) 
113     
114         With rs 
115            .AddNew 
116               !ProjectID = nProjectID 
117               !CustomerID = nCustomerID 
118               If Len(sAddress) > 0 Then !iAddress = sAddress 
119               If Len(sCSZC) > 0 Then !iCSZC = sCSZC 
120               If Len(sCustomer) > 0 Then !iCustomer = sCustomer 
121            .Update 
122            .Bookmark = .LastModified 
123            nInvoiceID = !InvoiceID 
124            .Close 
125         End With   'rs 
126         Set rs = Nothing 
127         Set db = Nothing 
128         DoEvents 
129     
130          'assign Expenses to invoice
131     
132         sSQL = "UPDATE Expenses AS Exp SET Exp.InvoiceID = " & nInvoiceID _ 
133            & " WHERE IsNull(Exp.InvoiceID)" _ 
134            & " AND (Exp.ProjectID=" & nProjectID & ");" 
135         nNumExp = rSql(sSQL) 
136     
137          'assign Payments to invoice
138     
139         sSQL = "UPDATE Payments AS Pmt SET Pmt.InvoiceID =" & nInvoiceID _ 
140            & " WHERE IsNull(Pmt.InvoiceID)" _ 
141            & " AND (Pmt.ProjectID=" & nProjectID & ");" 
142         nNumPmt = rSql(sSQL) 
143     
144         DoEvents 
145         EndTime 
146     
147         sMsg = "NEW INVOICE # " & nInvoiceID _ 
148            & vbCrLf & vbCrLf & nNumExp & " Expense records" _ 
149            & vbCrLf & vbCrLf & nNumPmt & " Payment records" 
150     
151         Me.fnd_Invoice.Requery 
152         Me.fnd_Expens.Requery 
153         Me.fnd_Payment.Requery 
154         Call RowSource_LstInvoices 
155     
156       '   DoCmd.OpenReport "r_Invoice" _
157             , acViewReport, "", "InvoiceID=" & nInvoiceID
158     
159         MsgBox sMsg, , "New Invoice Created" 
160       '   DoCmd.RunCommand acCmdPrint
161     
162      Proc_Exit: 
163         On Error Resume Next 
164         If Not rs Is Nothing Then 
165            rs.Close 
166            Set rs = Nothing 
167         End If 
168         Set db = Nothing 
169         Exit Sub 
170     
171      Proc_Err: 
172         MsgBox Err.Description, , _ 
173              "ERROR " & Err.Number _ 
174              & "   cmd_MakeInvoice_Click : " & Me.Name 
175         Resume Proc_Exit 
176         Resume 
177     
178      End Sub 
      Goto Top       Goto Form_f_PRJECT       Goto Index

cmd_New_Click (8)

179     
180      Private Sub cmd_New_Click() 
181       '130930
182         If Me.Dirty Then Me.Dirty = False 
183         If Not Me.NewRecord Then 
184            DoCmd.RunCommand acCmdRecordsGoToNew 
185         End If 
186      End Sub 
      Goto Top       Goto Form_f_PRJECT       Goto Index

cmd_Print_Click (6)

187     
188      Private Sub cmd_Print_Click() 
189       '130930
190         MsgBox "Under construction", , "Print" 
191     
192      End Sub 
      Goto Top       Goto Form_f_PRJECT       Goto Index

fnd_Customer_AfterUpdate (5)

193     
194      Private Sub fnd_Customer_AfterUpdate() 
195       '131002
196         Call FindRecordN(Me, "ProjectID", "prjNote") 
197      End Sub 
      Goto Top       Goto Form_f_PRJECT       Goto Index

fnd_Expens_AfterUpdate (5)

198     
199      Private Sub fnd_Expens_AfterUpdate() 
200       '131002
201         Call FindRecordN(Me, "ProjectID", "prjNote") 
202      End Sub 
      Goto Top       Goto Form_f_PRJECT       Goto Index

fnd_Invoice_AfterUpdate (6)

203     
204     
205      Private Sub fnd_Invoice_AfterUpdate() 
206       '131002
207         Call FindRecordN(Me, "ProjectID", "prjNote") 
208      End Sub 
      Goto Top       Goto Form_f_PRJECT       Goto Index

fnd_Payment_AfterUpdate (6)

209     
210     
211      Private Sub fnd_Payment_AfterUpdate() 
212       '131002
213         Call FindRecordN(Me, "ProjectID", "prjNote") 
214      End Sub 
      Goto Top       Goto Form_f_PRJECT       Goto Index

fnd_Project_AfterUpdate (6)

215     
216     
217      Private Sub fnd_Project_AfterUpdate() 
218       '131002
219         Call FindRecordN(Me, "ProjectID", "prjNote") 
220      End Sub 
      Goto Top       Goto Form_f_PRJECT       Goto Index

Form_BeforeUpdate (5)

221     
222      Private Sub Form_BeforeUpdate(Cancel As Integer) 
223       '130930
224         Call FormBeforeUpdate(Me) 
225      End Sub 
      Goto Top       Goto Form_f_PRJECT       Goto Index

Form_Current (15)

226     
227      Private Sub Form_Current() 
228       '131002
229       '   Dim boo As Boolean
230       '   boo = False
231       '   With Me
232       '      If .f_Expenses_sub.Form.Recordset.RecordCount > 0 Then
233       '         boo = True
234       '      ElseIf .f_Payments_sub.Form.Recordset.RecordCount > 0 Then
235       '         boo = True
236       '      End If
237       '      .cmd_MakeInvoice.Visible = boo
238       '   End With
239       '   Call RowSource_LstInvoices
240      End Sub 
      Goto Top       Goto Form_f_PRJECT       Goto Index

RowSource_LstInvoices (19)

241     
242      Private Sub RowSource_LstInvoices() 
243       '131002
244       '   Dim sSQL As String _
245       '      , nProjectID As Long
246       '
247       '   With Me.lst_Invoices
248       '      If Me.NewRecord Then
249       '         sSQL = ""
250       '      Else
251       '         nProjectID = Me.ProjectID
252       '         sSQL = Replace(.Tag, "ORDER BY" _
253       '            , "WHERE inv.ProjectID=" & nProjectID & " ORDER BY")
254       '      End If
255       '      .RowSource = sSQL
256       '      .Requery
257       '   End With
258     
259      End Sub 
      Goto Top       Goto Form_f_PRJECT       Goto Index

PrjDate1_DblClick (4)

260     
261      Private Sub PrjDate1_DblClick(Cancel As Integer) 
262         DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog 
263      End Sub 
      Goto Top       Goto Form_f_PRJECT       Goto Index

PrjDate2_DblClick (4)

264     
265      Private Sub PrjDate2_DblClick(Cancel As Integer) 
266         DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog 
267      End Sub 
      Goto Top       Goto Form_f_PRJECT       Goto Index

Form_f_PROJECTs (264)

PROCEDURES       Goto Top       Goto Form_f_PROJECTs       Goto Forms       Goto Index
  1. AirlineID_NotInList (12)
  2. cmd_Add_Click (13)
  3. cmd_Delete_Click (12)
  4. CustomerID_NotInList (10)
  5. Declaration Lines (28)
  6. FleetID_GotFocus (13)
  7. FleetID_LostFocus (5)
  8. FleetID_NotInList (18)
  9. fnd_PO_AfterUpdate (12)
  10. fnd_Project_AfterUpdate (5)
  11. Form_AfterUpdate (6)
  12. Form_BeforeUpdate (23)
  13. Form_Current (20)
  14. Form_Load (10)
  15. MakeID_NotInList (9)
  16. ModelID_GotFocus (13)
  17. ModelID_LostFocus (7)
  18. ModelID_NotInList (17)
  19. OemID_NotInList (10)
  20. StatID_NotInList (10)
  21. SysID_NotInList (11)

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_PROJECTs       Goto Index

Form_AfterUpdate (6)

29      
30       Private Sub Form_AfterUpdate() 
31        '131209
32          Me.fnd_PO.Requery 
33          Me.fnd_Project.Requery 
34       End Sub 
      Goto Top       Goto Form_f_PROJECTs       Goto Index

Form_Load (10)

35      
36       Private Sub Form_Load() 
37        '131112
38          If Len(Trim(Me.Filter)) > 0 Then Exit Sub 
39          Dim nRecordID As Long 
40          nRecordID = Get_Property("local_lastProjectID") 
41          If nRecordID > 0 Then 
42             Call FindRecordN(Me, "ProjectID", , nRecordID, False) 
43          End If 
44       End Sub 
      Goto Top       Goto Form_f_PROJECTs       Goto Index

cmd_Add_Click (13)

45      
46       Private Sub cmd_Add_Click() 
47        '131017, 131103
48          Dim nProjectNo As Long 
49      
50          If Me.Dirty Then Me.Dirty = False 
51          If Not Me.NewRecord Then DoCmd.RunCommand acCmdRecordsGoToNew 
52          nProjectNo = Nz(DMax("ProjectNo", "Projectz"), 0) + 1 
53          With Me.ProjectNo 
54             .Value = nProjectNo 
55             .SetFocus 
56          End With 
57       End Sub 
      Goto Top       Goto Form_f_PROJECTs       Goto Index

Form_BeforeUpdate (23)

58      
59       Private Sub Form_BeforeUpdate(Cancel As Integer) 
60        '131007, 1112, 131209
61      
62          If Not Me.NewRecord Then 
63             Select Case MsgBox("Are you sure you want to change this record" _ 
64                   , vbYesNoCancel, "Change Record?") 
65      
66             Case vbNo 
67                Cancel = True 
68                Exit Sub 
69             Case vbCancel 
70                Me.Undo 
71                Cancel = True 
72                Exit Sub 
73             End Select 
74          End If 
75      
76      
77          Call FormBeforeUpdate(Me) 
78          Call Set_Property("local_lastProjectID", Me.ProjectID) 
79      
80       End Sub 
      Goto Top       Goto Form_f_PROJECTs       Goto Index

Form_Current (20)

81      
82       Private Sub Form_Current() 
83        '131014, 25, 131125
84      
85          Dim sSQL As String _ 
86             , nProjectID As Long 
87          nProjectID = Nz(Me.ProjectID, -999) 
88          With Me.lst_PoID 
89             sSQL = .Tag 
90             sSQL = Replace(sSQL, "GROUP BY " _ 
91                , " WHERE Po.ProjectID=" & nProjectID & " GROUP BY ") 
92             .RowSource = sSQL 
93       Debug.Print sSQL 
94             On Error Resume Next 
95             .Value = Null 
96             .Requery 
97          End With 
98      
99      
100      End Sub 
      Goto Top       Goto Form_f_PROJECTs       Goto Index

cmd_Delete_Click (12)

101     
102     
103      Private Sub cmd_Delete_Click() 
104       '131017, 1209
105         If MsgBox("Are you sure you want to delete this record" _ 
106            , vbYesNo, "Delete Record?") <> vbYes Then Exit Sub 
107         If Me.Dirty Then Me.Undo 
108         On Error Resume Next 
109         If Not Me.NewRecord Then DoCmd.RunCommand acCmdDeleteRecord 
110         Me.fnd_PO.Requery 
111         Me.fnd_Project.Requery 
112      End Sub 
      Goto Top       Goto Form_f_PROJECTs       Goto Index

fnd_PO_AfterUpdate (12)

113     
114     
115     
116     
117      Private Sub fnd_PO_AfterUpdate() 
118       '131024, 1029
119       '   If IsNull(Me.ActiveControl) Then Exit Sub
120       '   Dim nPoID As Long
121       '   nPoID = Me.ActiveControl.Column(1)
122         Call FindRecordN(Me, "ProjectID") 
123       '   Me.lst_PoID = nPoID
124      End Sub 
      Goto Top       Goto Form_f_PROJECTs       Goto Index

fnd_Project_AfterUpdate (5)

125     
126      Private Sub fnd_Project_AfterUpdate() 
127       '131007, 131014, 1029
128         Call FindRecordN(Me, "ProjectID", "prjNotes") 
129      End Sub 
      Goto Top       Goto Form_f_PROJECTs       Goto Index

AirlineID_NotInList (12)

130     
131     
132     
133      Private Sub AirlineID_NotInList(NewData As String, Response As Integer) 
134       '131029
135         If Not NotInList_general("Airlines", "Airline", NewData) Then 
136            Me.ActiveControl.Undo 
137            Response = acDataErrContinue 
138         Else 
139            Response = acDataErrAdded 
140         End If 
141      End Sub 
      Goto Top       Goto Form_f_PROJECTs       Goto Index

CustomerID_NotInList (10)

142     
143      Private Sub CustomerID_NotInList(NewData As String, Response As Integer) 
144       '131029
145         If Not NotInList_general("Customers", "Customer", NewData) Then 
146            Me.ActiveControl.Undo 
147            Response = acDataErrContinue 
148         Else 
149            Response = acDataErrAdded 
150         End If 
151      End Sub 
      Goto Top       Goto Form_f_PROJECTs       Goto Index

MakeID_NotInList (9)

152     
153      Private Sub MakeID_NotInList(NewData As String, Response As Integer) 
154         If Not NotInList_general("Makes", "Make", NewData) Then 
155            Me.ActiveControl.Undo 
156            Response = acDataErrContinue 
157         Else 
158            Response = acDataErrAdded 
159         End If 
160      End Sub 
      Goto Top       Goto Form_f_PROJECTs       Goto Index

ModelID_NotInList (17)

161     
162      Private Sub ModelID_NotInList(NewData As String, Response As Integer) 
163         If IsNull(Me.MakeID) Then 
164            MsgBox "Cannot add a new series unless Model is filled", , "Can't add new series" 
165            Me.ActiveControl.Undo 
166            Response = acDataErrContinue 
167            Exit Sub 
168         End If 
169         Dim nMakeID As Long 
170         nMakeID = Me.MakeID 
171         If Not NotInList_general("Models", "Model", NewData, , "U", "MakeID", nMakeID) Then 
172            Me.ActiveControl.Undo 
173            Response = acDataErrContinue 
174         Else 
175            Response = acDataErrAdded 
176         End If 
177      End Sub 
      Goto Top       Goto Form_f_PROJECTs       Goto Index

FleetID_NotInList (18)

178     
179      Private Sub FleetID_NotInList(NewData As String, Response As Integer) 
180       '131029
181         If IsNull(Me.ModelID) Then 
182            MsgBox "Cannot add a new series unless Model is filled", , "Can't add new series" 
183            Me.ActiveControl.Undo 
184            Response = acDataErrContinue 
185            Exit Sub 
186         End If 
187         Dim nModelID As Long 
188         nModelID = Me.ModelID 
189         If Not NotInList_general("Fleets", "Series", NewData, , "U", "ModelID", nModelID) Then 
190            Me.ActiveControl.Undo 
191            Response = acDataErrContinue 
192         Else 
193            Response = acDataErrAdded 
194         End If 
195      End Sub 
      Goto Top       Goto Form_f_PROJECTs       Goto Index

SysID_NotInList (11)

196     
197      Private Sub SysID_NotInList(NewData As String, Response As Integer) 
198       '131027
199         If Not NotInList_general("Systemz", "Systm", NewData) Then 
200            Me.ActiveControl.Undo 
201            Response = acDataErrContinue 
202         Else 
203            Response = acDataErrAdded 
204         End If 
205     
206      End Sub 
      Goto Top       Goto Form_f_PROJECTs       Goto Index

OemID_NotInList (10)

207     
208      Private Sub OemID_NotInList(NewData As String, Response As Integer) 
209       '131029
210         If Not NotInList_general("Manufacturers", "oem", NewData) Then 
211            Me.ActiveControl.Undo 
212            Response = acDataErrContinue 
213         Else 
214            Response = acDataErrAdded 
215         End If 
216      End Sub 
      Goto Top       Goto Form_f_PROJECTs       Goto Index

StatID_NotInList (10)

217     
218      Private Sub StatID_NotInList(NewData As String, Response As Integer) 
219       '131029 back color #FCE6D4
220         If Not NotInList_general("Status", "Status", NewData) Then 
221            Me.ActiveControl.Undo 
222            Response = acDataErrContinue 
223         Else 
224            Response = acDataErrAdded 
225         End If 
226      End Sub 
      Goto Top       Goto Form_f_PROJECTs       Goto Index

ModelID_GotFocus (13)

227     
228     
229      Private Sub ModelID_GotFocus() 
230         With Me.MakeID 
231            If Not IsNull(.Value) Then 
232               Call SetControl_RowSource(Me.ModelID, "mdl.MakeID=" & .Value, , True) 
233            End If 
234         End With 
235         With ActiveControl 
236            If IsNull(.Value) Then .Dropdown 
237         End With 
238     
239      End Sub 
      Goto Top       Goto Form_f_PROJECTs       Goto Index

FleetID_GotFocus (13)

240     
241      Private Sub FleetID_GotFocus() 
242       '131017
243         With Me.ModelID 
244            If Not IsNull(.Value) Then 
245               Call SetControl_RowSource(Me.FleetID, "fle.ModelID=" & .Value, , True) 
246            End If 
247         End With 
248     
249         With ActiveControl 
250            If IsNull(.Value) Then .Dropdown 
251         End With 
252      End Sub 
      Goto Top       Goto Form_f_PROJECTs       Goto Index

FleetID_LostFocus (5)

253     
254      Private Sub FleetID_LostFocus() 
255       '131018
256         Call SetControl_RowSource(Me.FleetID) 
257      End Sub 
      Goto Top       Goto Form_f_PROJECTs       Goto Index

ModelID_LostFocus (7)

258     
259      Private Sub ModelID_LostFocus() 
260       '131018
261         Call SetControl_RowSource(Me.ModelID) 
262      End Sub 
263     
264     
      Goto Top       Goto Form_f_PROJECTs       Goto Index

Form_f_PROSPECT (67)

PROCEDURES       Goto Top       Goto Form_f_PROSPECT       Goto Forms       Goto Index
  1. Declaration Lines (28)
  2. fnd_CID_AfterUpdate (7)
  3. fnd_CustomerContact_AfterUpdate (6)
  4. Form_BeforeUpdate (5)
  5. 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_PROSPECT       Goto Index

fnd_CID_AfterUpdate (7)

29      
30       Private Sub fnd_CID_AfterUpdate() 
31        '131002
32           'find record by contact
33          Call FindRecordN(Me, "ProspID", "CurPkg") 
34      
35       End Sub 
      Goto Top       Goto Form_f_PROSPECT       Goto Index

fnd_CustomerContact_AfterUpdate (6)

36      
37       Private Sub fnd_CustomerContact_AfterUpdate() 
38        '131002
39           'find record by customer contact
40          Call FindRecordN(Me, "ProspID", "CurPkg") 
41       End Sub 
      Goto Top       Goto Form_f_PROSPECT       Goto Index

Form_BeforeUpdate (5)

42      
43       Private Sub Form_BeforeUpdate(Cancel As Integer) 
44        '131002
45          Call FormBeforeUpdate(Me) 
46       End Sub 
      Goto Top       Goto Form_f_PROSPECT       Goto Index

Form_Current (21)

47      
48       Private Sub Form_Current() 
49        '131002
50          Dim sSQL As String 
51      
52          With Me.lst_CompanyContacts 
53             sSQL = Replace(.Tag, "ORDER BY" _ 
54                      , " WHERE  c.[cid_]=" & Nz(Me.CID, -99) & " ORDER BY ") 
55             If .RowSource <> sSQL Then 
56                .RowSource = sSQL 
57                .Requery 
58             End If 
59          End With   'Me.lst_CompanyContacts 
60      
61           'me.cid
62        '      If Me.NewRecord Then  'can't add records here -- filter CID for NOT ALREADY a CUSTOMER
63        '         sSQL = Replace(.Tag, "ORDER BY" _
64        '            , "WHERE (((DLookUp(""CustomerID"",""Customers"",""CID="" & [c].[cid])) Is Null)) ORDER BY")
65        '      End If
66      
67       End Sub 
      Goto Top       Goto Form_f_PROSPECT       Goto Index

Form_f_SplashScreen (40)

PROCEDURES       Goto Top       Goto Form_f_SplashScreen       Goto Forms       Goto Index
  1. Declaration Lines (2)
  2. Form_Open (8)
  3. Form_Timer (30)

Declaration Lines (2)

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

Form_Open (8)

3       
4        Private Sub Form_Open(Cancel As Integer) 
5         ' 140727 modified from code written by Wayne Phillips 140723 WP
6       
7           Me.lblTitle.Caption = "Contact Template for Microsoft Access" & vbCrLf & _ 
8                                   "... LOADING, PLEASE WAIT ..." 
9       
10       End Sub 
      Goto Top       Goto Form_f_SplashScreen       Goto Index

Form_Timer (30)

11      
12        ' For a more feature-rich splash screen, please see Allen Browne's excellent article here:
13        ' http://allenbrowne.com/ser-53.html
14      
15       Private Sub Form_Timer() 
16        ' 140723 WP
17        ' 140272 s4p modified by Crystal
18      
19          Dim iCancel As Integer 
20          iCancel = False 
21      
22        ' Using the timer event will ensure any time consuimg tasks are started after the splashscreen is displayed to the user
23          Me.TimerInterval = 0    ' To ensure we only get called once (which ). 
24      
25        ' Do any potennially time-consuming startup tasks here
26      
27        ' Now close the splash screen and open the Admin form to see if BE tables need relinking
28      
29          If Not IsBEok("c_Contact") Then ', True) Then   'open BE and keep table open 
30             DoCmd.OpenForm "f_ADMIN", acNormal 
31             Call Form_f_ADMIN.Form_Open(iCancel) 
32          Else 
33              'open Contacts form
34             DoCmd.OpenForm "fc_MENU_CONTACT" 
35          End If 
36          DoCmd.Close acForm, Me.Name 
37        '   DoCmd.Maximize
38      
39       End Sub 
40      
      Goto Top       Goto Form_f_SplashScreen       Goto Index

Form_f_UnderConstruction (3)

PROCEDURES       Goto Top       Goto Form_f_UnderConstruction       Goto Forms       Goto Index
  1. Declaration Lines (3)

Declaration Lines (3)

1        Option Compare Database 
2        Option Explicit 
3       
      Goto Top       Goto Form_f_UnderConstruction       Goto Index

Form_f_VENDOR (68)

PROCEDURES       Goto Top       Goto Form_f_VENDOR       Goto Forms       Goto Index
  1. Declaration Lines (28)
  2. fnd_CID_AfterUpdate (7)
  3. fnd_CustomerContact_AfterUpdate (6)
  4. Form_BeforeUpdate (6)
  5. 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_VENDOR       Goto Index

fnd_CID_AfterUpdate (7)

29      
30       Private Sub fnd_CID_AfterUpdate() 
31        '131002
32           'find record by customer
33          Call FindRecordN(Me, "VendorID") 
34      
35       End Sub 
      Goto Top       Goto Form_f_VENDOR       Goto Index

fnd_CustomerContact_AfterUpdate (6)

36      
37       Private Sub fnd_CustomerContact_AfterUpdate() 
38        '131002
39           'find record by customer contact
40          Call FindRecordN(Me, "VendorID") 
41       End Sub 
      Goto Top       Goto Form_f_VENDOR       Goto Index

Form_BeforeUpdate (6)

42      
43      
44       Private Sub Form_BeforeUpdate(Cancel As Integer) 
45        '131002
46          Call FormBeforeUpdate(Me) 
47       End Sub 
      Goto Top       Goto Form_f_VENDOR       Goto Index

Form_Current (21)

48      
49       Private Sub Form_Current() 
50        '131002
51          Dim sSQL As String 
52      
53          With Me.lst_CompanyContacts 
54             sSQL = Replace(.Tag, "ORDER BY" _ 
55                      , " WHERE  c.[cid_]=" & Nz(Me.CID, -99) & " ORDER BY ") 
56             If .RowSource <> sSQL Then 
57                .RowSource = sSQL 
58                .Requery 
59             End If 
60          End With   'Me.lst_CompanyContacts 
61      
62           'me.cid
63        '      If Me.NewRecord Then  'can't add records here -- filter CID for NOT ALREADY a CUSTOMER
64        '         sSQL = Replace(.Tag, "ORDER BY" _
65        '            , "WHERE (((DLookUp(""CustomerID"",""Customers"",""CID="" & [c].[cid])) Is Null)) ORDER BY")
66        '      End If
67      
68       End Sub 
      Goto Top       Goto Form_f_VENDOR       Goto Index

Form_fc_AddrDates_sub (79)

PROCEDURES       Goto Top       Goto Form_fc_AddrDates_sub       Goto Forms       Goto Index
  1. cmd_Add_Click (11)
  2. cmd_Del_Click (6)
  3. Declaration Lines (33)
  4. dtAdr2_DblClick (9)
  5. Form_BeforeUpdate (20)

Declaration Lines (33)

1        Option Compare Database 
2        Option Explicit 
3         '=======================================================
4         ' fc_AddrDates_Sub
5         ' CONTACT MANAGEMENT APPLET
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        'on double-click, dates have --> =PopCalendar(true)
      Goto Top       Goto Form_fc_AddrDates_sub       Goto Index

cmd_Add_Click (11)

34      
35        '=======================================================
36        '3-20-09
37        '
38        '=======================================================
39      
40       Private Sub cmd_Add_Click() 
41        '3-20-09 ' -107
42          On Error Resume Next 
43          RecordNew Me, "dtAdr1" 
44       End Sub 
      Goto Top       Goto Form_fc_AddrDates_sub       Goto Index

cmd_Del_Click (6)

45      
46       Private Sub cmd_Del_Click() 
47        '3-20-09 ' -107
48          On Error Resume Next 
49          RecordDelete Me, "dtAdr1" 
50       End Sub 
      Goto Top       Goto Form_fc_AddrDates_sub       Goto Index

dtAdr2_DblClick (9)

51      
52       Private Sub dtAdr2_DblClick(Cancel As Integer) 
53        '131224
54          If IsNull(Me.dtAdr2) And Not IsNull(Me.dtAdr1) Then 
55             Call PopCalendar(True, [dtAdr1]) 
56          Else 
57             Call PopCalendar(True) 
58          End If 
59       End Sub 
      Goto Top       Goto Form_fc_AddrDates_sub       Goto Index

Form_BeforeUpdate (20)

60      
61       Private Sub Form_BeforeUpdate(Cancel As Integer) 
62        '131224
63          Dim sMsg As String 
64      
65          sMsg = Me.dtAdr1 & " to " + Me.dtAdr2 & (", " + Me.RmNum) 
66      
67          Select Case AskSaveTheChanges( _ 
68                      "Travel Dates", sMsg) 
69             Case vbCancel 
70                Me.Undo 
71                Cancel = True 
72             Case vbNo 
73                Cancel = True 
74             Case Else   'vbYes 
75                 'update tracking fields
76                On Error Resume Next 
77                FormBeforeUpdate Me, True    'update parent too 
78          End Select 
79       End Sub 
      Goto Top       Goto Form_fc_AddrDates_sub       Goto Index

Form_fc_Addresses_sub (367)

PROCEDURES       Goto Top       Goto Form_fc_Addresses_sub       Goto Forms       Goto Index
  1. Addr1_AfterUpdate (18)
  2. Addr2_AfterUpdate (7)
  3. adrNote_AfterUpdate (7)
  4. adrNote_KeyDown (18)
  5. Area_AfterUpdate (8)
  6. City_AfterUpdate (7)
  7. cmd_Add_Click (6)
  8. cmd_Del_Click (25)
  9. cmd_Map2_Click (9)
  10. cmd_MapAddress_Click (9)
  11. cmdNext_Click (7)
  12. cmdPrev_Click (5)
  13. Declaration Lines (42)
  14. Form_AfterUpdate (61)
  15. Form_BeforeUpdate (31)
  16. Form_Current (19)
  17. TypeID_NotInList (14)
  18. TypIdAdr_NotInList (34)
  19. Zip_AfterUpdate (33)
  20. Zip_NotInList (7)

Declaration Lines (42)

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        '
31        '101010, 130813
32        '
33        ' CALLS
34        '   RecordNew
35        '   RecordDelete
36        '   FormBeforeUpdate
37        '   GetResponse_NIL
38        '
39        'combos have --> DropMe, DropMeIfNull
40        '---------------------------------------------------------- used?
41        'Dim mDoUpdateArea As Boolean
42        '111130
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

cmd_Map2_Click (9)

43      
44       Private Sub cmd_Map2_Click() 
45          Dim sAddress As String _ 
46             , sURL As String 
47          sAddress = GetAddressShort(Me) 
48          sURL = "http://bing.com/maps/default.aspx?where1=" & sAddress 
49          Application.FollowHyperlink sURL 
50      
51       End Sub 
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

cmd_MapAddress_Click (9)

52      
53       Private Sub cmd_MapAddress_Click() 
54        '141006
55          Dim sAddress As String _ 
56             , sURL As String 
57          sAddress = GetAddressFromForm(Me, ", ") 
58          sURL = "http://bing.com/maps/default.aspx?where1=" & sAddress 
59          Application.FollowHyperlink sURL 
60       End Sub 
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

Form_BeforeUpdate (31)

61      
62       Private Sub Form_BeforeUpdate(Cancel As Integer) 
63        '110118, 1209, 1224, 141006 booPri
64          On Error GoTo Proc_Err 
65      
66          Dim sMsg As String _ 
67             , iOrdr As Integer 
68      
69           'fill the address order to be last
70          With Me.OrdrAdr 
71             If IsNull(.Value) Then 
72                iOrdr = Nz(DMax("OrdrAdr", "c_Address", "CID=" & Me.CID), 0) + 1 
73                .Value = iOrdr 
74             End If 
75          End With 
76      
77          Call FormBeforeUpdate(Me, True)     'update parent too 
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_BeforeUpdate : " & Me.Name 
87      
88          Resume Proc_Exit 
89          Resume 
90      
91       End Sub 
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

Form_AfterUpdate (61)

92      
93       Private Sub Form_AfterUpdate() 
94        '131224, 141006 Primary
95      
96           'rebuild Find List
97        '   If IsSubform(Me) Then
98           'if this is a Primary address, clear other Primary designations
99      
100          'CALLS
101          '  rSql
102     
103         On Error GoTo Proc_Err 
104     
105         Dim nCID As Long _ 
106            , nAdrID As Long _ 
107            , nTypIdAdr As Long _ 
108            , sSQL As String _ 
109            , nNumOtherPrimary As Long 
110     
111         nCID = Me.CID 
112         nAdrID = Me.AdrID 
113         nTypIdAdr = Nz(Me.TypIdAdr, 99) 
114     
115         nNumOtherPrimary = DCount("*", "c_Address" _ 
116            , "CID=" & nCID _ 
117            & " AND TypIdAdr = 0" _ 
118            & " AND AdrID<>" & nAdrID _ 
119            ) 
120     
121         If nTypIdAdr <> 0 Then 
122             'if there are no primary addresses, mark this as Primary
123            If nNumOtherPrimary = 0 Then 
124               Me.TypIdAdr = 0 
125            End If 
126         Else 
127             'this is Primary -- clear others
128            If nNumOtherPrimary > 0 Then 
129               sSQL = "UPDATE c_Address A " _ 
130                  & " SET A.TypIdAdr=Null " _ 
131                  & " WHERE A.CID=" & nCID _ 
132                  & " AND A.AdrID<>" & nAdrID _ 
133                  & ";" 
134               Call rSql(sSQL) 
135            End If 
136         End If 
137     
138         With Me.Parent 
139            .fnd_AdrID.Requery 
140         End With 
141      Proc_Exit: 
142         On Error Resume Next 
143         Exit Sub 
144     
145      Proc_Err: 
146         MsgBox Err.Description, , _ 
147              "ERROR " & Err.Number _ 
148              & "   Form_AfterUpdate : " & Me.Name 
149     
150         Resume Proc_Exit 
151         Resume 
152      End Sub 
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

Form_Current (19)

153     
154       '101010
155       '   On Error Resume Next
156       '   If mDoUpdateArea Then
157       '      Me.Area.Requery
158       '      mDoUpdateArea = False
159       '   End If
160     
161     
162      Private Sub Form_Current() 
163       '131224, 140217
164         On Error Resume Next 
165         With Me.Parent 
166            If .fc_AddrDates_sub.Visible Then 
167               .AdrID.Requery 
168               .fc_AddrDates_sub.Form.Requery 
169            End If 
170         End With 
171      End Sub 
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

Addr1_AfterUpdate (18)

172     
173       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ convert what is entered to ProperCase
174       '3 = vbProperCase
175     
176     
177       'Private Sub Form_Open(Cancel As Integer)
178       ''101010
179       '   On Error Resume Next
180       '   mDoUpdateArea = False
181       'End Sub
182     
183     
184      Private Sub Addr1_AfterUpdate() 
185       '101007, 10
186         On Error Resume Next 
187         If IsNull(Me.ActiveControl) Then Exit Sub 
188         Me.ActiveControl = StrConv(Me.ActiveControl, 3) 
189      End Sub 
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

Addr2_AfterUpdate (7)

190     
191      Private Sub Addr2_AfterUpdate() 
192       '101007, 10
193         On Error Resume Next 
194         If IsNull(Me.ActiveControl) Then Exit Sub 
195         Me.ActiveControl = StrConv(Me.ActiveControl, 3) 
196      End Sub 
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

adrNote_AfterUpdate (7)

197     
198      Private Sub adrNote_AfterUpdate() 
199       '101007, 10
200         On Error Resume Next 
201         If IsNull(Me.ActiveControl) Then Exit Sub 
202         Me.ActiveControl = StrConv(Me.ActiveControl, 3) 
203      End Sub 
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

adrNote_KeyDown (18)

204     
205      Private Sub adrNote_KeyDown(KeyCode As Integer, Shift As Integer) 
206       '  On Error GoTo proc_err
207       '   If KeyCode = 9 Then
208       '      Me.Phones.SetFocus
209       '      Me.Phones.Form.Phone.SetFocus
210       '
211       '   End If
212       'proc_exit:
213       '   On Error Resume Next
214       '   Exit Sub
215       'proc_err:
216       '   DoCmd.CancelEvent
217       '   'Me.CatID.SetFocus
218       '   Resume proc_exit
219       '   Resume
220     
221      End Sub 
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

Area_AfterUpdate (8)

222     
223      Private Sub Area_AfterUpdate() 
224       '101007, 10
225         On Error Resume Next 
226       '   mDoUpdateArea = True
227         If IsNull(Me.ActiveControl) Then Exit Sub 
228         Me.ActiveControl = StrConv(Me.ActiveControl, 3) 
229      End Sub 
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

City_AfterUpdate (7)

230     
231      Private Sub City_AfterUpdate() 
232       '101007, 10
233         On Error Resume Next 
234         If IsNull(Me.ActiveControl) Then Exit Sub 
235         Me.ActiveControl = StrConv(Me.ActiveControl, 3) 
236      End Sub 
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

cmd_Add_Click (6)

237     
238      Private Sub cmd_Add_Click() 
239       '101010
240         On Error Resume Next 
241         RecordNew Me, "Addr1" 
242      End Sub 
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

cmd_Del_Click (25)

243     
244      Private Sub cmd_Del_Click() 
245       '101010, 131224
246         Dim sMsg As String 
247         With Me.TypIdAdr 
248            If Not IsNull(.Value) Then 
249               sMsg = .Column(1) & " Address" 
250            Else 
251               sMsg = " Address" 
252            End If 
253         End With 
254         sMsg = sMsg & _ 
255            (": " + _ 
256            ((Me.Addr1 + ", ") _ 
257               & (Me.City + ", ") _ 
258               & ("  " + Me.St) _ 
259               & ("  " + Me.Ctry) _ 
260            )) 
261     
262         On Error Resume Next 
263         RecordDelete Me, "Addr1", sMsg 
264     
265          'rebuild Find List
266         Me.Parent.fnd_AdrID.Requery 
267      End Sub 
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

cmdNext_Click (7)

268     
269     
270     
271      Private Sub cmdNext_Click() 
272       '130813
273         Call RecordNext(Me, "Addr1") 
274      End Sub 
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

cmdPrev_Click (5)

275     
276      Private Sub cmdPrev_Click() 
277       '130813
278         Call RecordPrev(Me, "Addr1") 
279      End Sub 
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

TypeID_NotInList (14)

280     
281     
282     
283     
284     
285     
286      Private Sub TypeID_NotInList( _ 
287         NewData As String, _ 
288         Response As Integer) 
289         MsgBox "TypeID_NotInList not defined for " & Me.Name _ 
290            , , "Write Code" 
291          ' TypeID_NIL NewData, Response, Me, 110, True
292     
293      End Sub 
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

TypIdAdr_NotInList (34)

294     
295     
296      Private Sub TypIdAdr_NotInList( _ 
297         NewData As String, _ 
298         Response As Integer) 
299       '101010
300         On Error GoTo Err_Proc 
301     
302          ' crystal (strive4peace)
303         Dim sTblNm As String _ 
304           , sFldNm As String _ 
305           , nTID As Long 
306     
307         sTblNm = "c_AdrType" 
308         sFldNm = "TypAdr" 
309         nTID = 0 
310     
311         Response = GetResponse_NIL(NewData, sTblNm, sFldNm, nTID, "Address Type") 
312     
313      Exit_Proc: 
314         On Error Resume Next 
315         Exit Sub 
316      Err_Proc: 
317         Select Case Err.Number 
318        '     Case 94
319        '        Resume Next
320        '    Case 1111
321        '       msgbox "special error message that has some meaning.",vbokonly
322        '        Resume Next
323            Case Else 
324               MsgBox Err.Number & "--" & Err.Description, vbOKOnly 
325               Resume Exit_Proc 
326         End Select 
327      End Sub 
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

Zip_AfterUpdate (33)

328     
329      Private Sub Zip_AfterUpdate() 
330       '101229, 110327, 140726
331          'zip code After Update
332         Dim booChange As Boolean _ 
333            , sCity As String _ 
334            , sState As String _ 
335            , sCtry As String 
336     
337         With Me.Zip 
338            If IsNull(.Column(0)) Then Exit Sub 
339            sCity = .Column(1) 
340            sState = .Column(2) 
341            sCtry = "US" 'default value 'future -- get from Zips table 
342         End With 
343     
344         booChange = True 
345     
346         With Me.City 
347            If Not IsNull(.Value) And Len(sCity) > 0 Then 
348               If MsgBox("Change City = " & .Value & " to " & sCity _ 
349                     , vbYesNo, "Change City?") = vbNo Then 
350                  booChange = False 
351               End If 
352            End If 
353            If booChange Then 
354               .Value = sCity 
355               Me.St = sState 
356               Me.Ctry = sCtry 
357            End If 
358         End With 
359     
360      End Sub 
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

Zip_NotInList (7)

361     
362     
363      Private Sub Zip_NotInList(NewData As String, Response As Integer) 
364         MsgBox "Zip_NotInList not defined for " & Me.Name _ 
365            , , "Write Code" 
366      End Sub 
367     
      Goto Top       Goto Form_fc_Addresses_sub       Goto Index

Form_fc_AnywhereAttachments (903)

PROCEDURES       Goto Top       Goto Form_fc_AnywhereAttachments       Goto Forms       Goto Index
  1. AddURL (78)
  2. BrowseToFile (136)
  3. cmd_Add_Click (52)
  4. cmd_AddURL_Click (56)
  5. cmd_Browse_Click (11)
  6. cmd_Close_Click (31)
  7. cmd_Delete_Click (55)
  8. cmd_OpenAttachment_Click (62)
  9. CorrectWebAddress (21)
  10. Declaration Lines (39)
  11. DoesWebAddressStartRight (50)
  12. fnd_Record_AfterUpdate (31)
  13. Form_AfterUpdate (24)
  14. Form_BeforeUpdate (49)
  15. Form_Current (35)
  16. Form_Open (40)
  17. RequeryMyParent (9)
  18. SynchronizeMyAttachments (124)

Declaration Lines (39)

1        Option Compare Database 
2        Option Explicit 
3         '=======================================================
4         '
5         ' code behind form: fc_AnywhereAttachments
6         '
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, 140629
28        ' ~ Crystal
29        '              * have an awesome day :)
30        '                                                   www.AccessMVP.com/strive4peace
31        ' END LICENSE NOTICE
32        '============================================================
33        '
34        'NEEDS PROPERTIES:
35        '   "local_TID"
36        '   "local_RecordID"
37        '   "local_RolliD"
38        '
39       Dim mPath As String 
      Goto Top       Goto Form_fc_AnywhereAttachments       Goto Index

Form_Open (40)

40      
41       Private Sub Form_Open(Cancel As Integer) 
42        '130921
43      
44           'CALLS
45           '  SynchronizeMyAttachments
46      
47          On Error GoTo Proc_Err 
48      
49          Dim bBoo As Boolean 
50      
51          bBoo = IsSubform(Me) 
52           'if this is a subform, hide the close button
53          Me.cmd_Close.Visible = Not bBoo 
54      
55           'if this is a subform, exit -- let Parent form trigger synchronizing
56          If bBoo = True Then 
57             Exit Sub 
58          End If 
59      
60           'AnywhereAttachments is being popped up
61      
62           'Call SynchronizeMyAttachments
63          If Not SynchronizeMyAttachments() Then 
64             Cancel = True 
65          End If 
66      
67          mPath = "" 
68      
69       Proc_Exit: 
70          On Error Resume Next 
71          Exit Sub 
72      
73       Proc_Err: 
74          MsgBox Err.Description _ 
75                 , , "ERROR: " & Err.Number _ 
76                     & "    form_Open " & ": " & Me.Name 
77          Resume Proc_Exit 
78          Resume 
79       End Sub 
      Goto Top       Goto Form_fc_AnywhereAttachments       Goto Index

Form_Current (35)

80      
81       Private Sub Form_Current() 
82        '130909, 141008
83          On Error GoTo Proc_Err 
84      
85      
86          Dim sPathFile As String 
87      
88          With Me 
89             If Not IsNull(.AttLinkID) Then 
90                sPathFile = GetWholePathFile(.AttLinkID.Column(1), True) 
91       Debug.Print sPathFile 
92                .ImageDocument.Picture = sPathFile '2220 - can't find file 
93                .AttLinkID_AttTypID.Requery 
94             End If 
95          End With 
96      
97          Me.fnd_Record.Requery 
98       Proc_Exit: 
99          On Error Resume Next 
100         Exit Sub 
101     
102      Proc_Err: 
103         If Err.Number = 2220 Then 'can't find file 
104            Me.ImageDocument.Picture = "" 
105            MsgBox "Can't find specified file", , "Missing file" 
106            Resume Proc_Exit 
107         End If 
108         MsgBox Err.Description, , _ 
109              "ERROR " & Err.Number _ 
110              & "   Form_Current : " & Me.Name 
111     
112         Resume Proc_Exit 
113         Resume 
114      End Sub 
      Goto Top       Goto Form_fc_AnywhereAttachments       Goto Index

Form_BeforeUpdate (49)

115     
116     
117      Private Sub Form_BeforeUpdate(Cancel As Integer) 
118       '110119, 130813
119     
120          'CALLS
121          '  FormBeforeUpdate
122     
123         Dim nRecordID As Long _ 
124            , nTID As Long _ 
125            , nCID As Long _ 
126            , sLink As String 
127     
128         On Error GoTo Proc_Err 
129     
130         If IsNull(Me.AttLinkID) Then 
131            If MsgBox("Cannot save record without a link" _ 
132               & vbCrLf & "Yes to fix this yourself" _ 
133               & vbCrLf & "No to discard changes" _ 
134               , vbYesNo, "Add link to this record?") = vbNo Then 
135                  Me.Undo 
136            Else 
137               With Me.AttLinkID 
138                  .SetFocus 
139                  .Dropdown 
140               End With 
141            End If 
142            Cancel = True 
143            Exit Sub 
144         End If 
145     
146         If IsNull(Me.AttName) Then 
147            Me.AttName = Me.AttLinkID.Column(2) 
148         End If 
149     
150          'update tracking fields
151         Call FormBeforeUpdate(Me) 
152     
153      Proc_Exit: 
154         On Error Resume Next 
155         Exit Sub 
156      Proc_Err: 
157         MsgBox Err.Description _ 
158                , , "ERROR: " & Err.Number _ 
159                    & "    Form_BeforeUpdate " & ": " & Me.Name 
160     
161         Resume Proc_Exit 
162         Resume 
163      End Sub 
      Goto Top       Goto Form_fc_AnywhereAttachments       Goto Index

Form_AfterUpdate (24)

164     
165     
166      Private Sub Form_AfterUpdate() 
167       '110119, 130916
168         On Error GoTo Proc_Err 
169     
170          'just saved the record -- update picture
171         Call Form_Current 
172     
173      Proc_Exit: 
174         On Error Resume Next 
175         Exit Sub 
176     
177      Proc_Err: 
178         If Err.Number = 2467 Then Resume Proc_Exit 'object closed -- closing form, can't requery 
179         MsgBox Err.Description, , _ 
180                "ERROR " & Err.Number _ 
181                & "   Form_AfterUpdate : " & Me.Name 
182     
183         Resume Proc_Exit 
184          'if you want to single-step code to find error, CTRL-Break at MsgBox
185          'then set this to be the next statement
186         Resume 
187      End Sub 
      Goto Top       Goto Form_fc_AnywhereAttachments       Goto Index

fnd_Record_AfterUpdate (31)

188     
189      Private Sub fnd_Record_AfterUpdate() 
190       '130813
191     
192          'CALLS
193          '  FindRecordN
194     
195         On Error GoTo Proc_Err 
196         If IsNull(Me.fnd_Record) Then Exit Sub 
197     
198         If Me.Dirty Then 
199            Me.Dirty = False 
200         End If 
201     
202          'find the record
203         Call FindRecordN(Me, "AttID", "AttName") 
204     
205      Proc_Exit: 
206         On Error Resume Next 
207         Exit Sub 
208     
209      Proc_Err: 
210         MsgBox Err.Description, , _ 
211                "ERROR " & Err.Number _ 
212                & "   fnd_Record_AfterUpdate : " & Me.Name 
213     
214         Resume Proc_Exit 
215          'if you want to single-step code to find error, CTRL-Break at MsgBox
216          'then set this to be the next statement
217         Resume 
218      End Sub 
      Goto Top       Goto Form_fc_AnywhereAttachments       Goto Index

cmd_Close_Click (31)

219     
220      Private Sub cmd_Close_Click() 
221       '100223,110101, 110119 exit sub if dirty is still dirty
222     
223          'CALLS
224          '  SetCmdButtons
225          '  UsersAndPermissions_800_DI
226     
227         On Error GoTo Proc_Err 
228     
229          'save record if necessary
230         If Me.Dirty Then 
231            Me.Dirty = False 
232         End If 
233     
234          'close form without saving
235         DoCmd.Close acForm, Me.Name, acSaveNo 
236     
237      Proc_Exit: 
238         Exit Sub 
239     
240      Proc_Err: 
241         MsgBox Err.Description, , _ 
242                "ERROR " & Err.Number _ 
243                & "   cmd_Close_Click : " & Me.Name 
244     
245         Resume Proc_Exit 
246          'if you want to single-step code to find error, CTRL-Break at MsgBox
247          'then set this to be the next statement
248         Resume 
249      End Sub 
      Goto Top       Goto Form_fc_AnywhereAttachments       Goto Index

cmd_OpenAttachment_Click (62)

250     
251     
252       'open the specified document or link that the user clicked on
253      Private Sub cmd_OpenAttachment_Click() 
254       '110105, 110119, 130908
255         On Error GoTo Proc_Err 
256     
257         Dim sPathFile As String 
258     
259         With Me 
260            If Me.Dirty Then Me.Dirty = False 
261     
262            If IsNull(.AttID) Then 
263               MsgBox "You are not on a current record", , "Can't Open Document" 
264               Exit Sub 
265            End If 
266            If IsNull(.AttLinkID) Then 
267               MsgBox "Document Link not specified" _ 
268                  , , "Can't Open Document" 
269               Exit Sub 
270            End If 
271     
272     
273             'note: no error checking can be done if web address is bad
274             'if this is a file:
275             '   If Not Len(Dir(Me.AttLinkID)) > 0 Then
276             '      MsgBox Me.AttLinkID _
277                    '         & vbCrLf & vbCrLf & " --> NOT FOUND", , "Cannot open link"
278             '      Exit Sub
279             '   End If
280             '
281     
282            sPathFile = Me.AttLinkID.Column(1) 
283         End With   'me 
284     
285     
286         If InStr(sPathFile, "\") = 0 And InStr(sPathFile, "/") = 0 Then 
287            sPathFile = GetWholePathFile(sPathFile) 
288         End If 
289     
290       'MsgBox sPathFile
291     
292         If Len(sPathFile) > 0 Then 
293            Application.FollowHyperlink sPathFile 
294         End If 
295     
296      Proc_Exit: 
297         On Error Resume Next 
298         Exit Sub 
299     
300      Proc_Err: 
301         MsgBox Me.AttLinkID _ 
302                & vbCrLf & vbCrLf & " --> NOT FOUND" _ 
303                , , "Error opening link" 
304     
305         Resume Proc_Exit 
306     
307         MsgBox Err.Description, , _ 
308                "ERROR " & Err.Number _ 
309                & "   cmd_OpenAttachment_Click : " & Me.Name 
310         Resume 
311      End Sub 
      Goto Top       Goto Form_fc_AnywhereAttachments       Goto Index

CorrectWebAddress (21)

312     
313      Private Function CorrectWebAddress(ByRef pURL As String) As Boolean 
314       '110119
315       'url is passed by reference.
316       'it may be changed.  routine returns True if an adjustment was made
317         On Error Resume Next 
318         On Error Resume Next 
319         CorrectWebAddress = False 
320     
321          ' if passed web address does not start with a valid web prefix,
322     
323          '--------- WRITE CODE
324     
325     
326          ' then add the default one and hope it works
327         If Left(pURL, 4) = "www." Then 
328            pURL = "http://" & pURL 
329            CorrectWebAddress = True 
330         End If 
331     
332      End Function 
      Goto Top       Goto Form_fc_AnywhereAttachments       Goto Index

DoesWebAddressStartRight (50)

333     
334      Private Function DoesWebAddressStartRight(pURL) As Boolean 
335       '110119
336       'check beginning characters of web address against WebPfx in WebPrefixes
337       'True if ok
338       'False if beginning of web address is not found in the acceptable prefix list
339     
340         On Error GoTo Proc_Err 
341     
342         DoesWebAddressStartRight = False 
343     
344         Dim db As DAO.Database _ 
345             , rs As DAO.Recordset 
346     
347         Dim sSQL As String 
348     
349       'If Left(pURL, 7) = "http://" Then
350       '   DoesWebAddressStartRight = True
351       '   Exit Function
352       'End If
353     
354         sSQL = "SELECT WebPfx FROM c_WebPfx WHERE Not IsNull(WebPfx) and len(WebPfx) > 1" 
355     
356         Set db = DBEngine(0)(0) 
357         Set rs = db.OpenRecordset(sSQL, dbOpenSnapshot) 
358     
359         With rs 
360            Do While Not .EOF 
361               If Left(pURL, Len(!WebPfx)) = !WebPfx Then 
362                   'found it
363                  DoesWebAddressStartRight = True 
364                  GoTo Proc_Exit 
365               End If 
366               .MoveNext 
367            Loop     'rs 
368         End With     'rs 
369     
370      Proc_Exit: 
371         On Error Resume Next 
372         If Not rs Is Nothing Then 
373            rs.Close 
374            Set rs = Nothing 
375         End If 
376         If Not db Is Nothing Then Set db = Nothing 
377         Exit Function 
378     
379      Proc_Err: 
380         Resume Proc_Exit 
381     
382      End Function 
      Goto Top       Goto Form_fc_AnywhereAttachments       Goto Index

cmd_Browse_Click (11)

383     
384      Private Sub cmd_Browse_Click() 
385       '110105
386          'CALL
387          '  BrowseToFile
388     
389         On Error Resume Next 
390         Call BrowseToFile 
391         If Me.Dirty Then Me.Dirty = False 
392     
393      End Sub 
      Goto Top       Goto Form_fc_AnywhereAttachments       Goto Index

BrowseToFile (136)

394     
395      Sub BrowseToFile() 
396       '110105, 130813
397     
398          'CALLS
399          '  GetFile_Browse
400     
401         On Error GoTo Proc_Err 
402     
403         Dim db As DAO.Database _ 
404            , rs As DAO.Recordset 
405     
406         Dim sFile As String _ 
407            , sPath As String _ 
408            , sPathAttachment As String _ 
409            , sPathDb As String _ 
410            , iPos As Integer _ 
411            , sName As String _ 
412            , sPathFile As String _ 
413            , sPathFileNew As String _ 
414            , sStr As String _ 
415            , sSQL As String _ 
416            , sAttExt As String _ 
417            , nAttLinkID As Long 
418     
419     
420         sFile = "" 
421     
422         sPathAttachment = GetAttachmentPath() 
423     
424         If Not IsNull(Me.AttLinkID) Then 
425            sFile = Me.AttLinkID.Column(1) 
426     
427            If Left(sFile, 1) = "\" Then 
428               sPathFile = sPathAttachment & Mid(sFile, 2) 
429                'strip \ from beginning of relative reference
430            Else 
431               sPath = sPathAttachment 
432            End If 
433         Else 
434            sPathFile = "" 
435            If Len(mPath) > 0 Then 
436               sPath = mPath 
437            Else 
438               sPath = sPathAttachment 
439            End If 
440         End If 
441     
442         sFile = "" 
443     
444         sStr = "Choose A File to associate with this record" 
445          'CALL GetFile_Browse
446         If Len(sPathFile) > 0 Then 
447            sFile = GetFile_Browse(sStr, , sPathFile) 
448         Else 
449            sFile = GetFile_Browse(sStr, , , sPath) 
450         End If 
451     
452          'get path for the file picked
453         iPos = InStrRev(sFile, "\") 
454         mPath = Left(sFile, iPos)   'save directory for next time 
455     
456         If Len(Trim(sFile)) > 0 Then 
457            If Left(sFile, Len(sPathAttachment)) <> sPathAttachment Then 
458     
459               sPathFileNew = sPathAttachment & Mid(sFile, iPos + 1) 
460     
461                'add nAttLinkID to filename? haven't calculated it yet ...
462     
463                'copy file to attachments directory
464               FileCopy sFile, sPathFileNew 
465     
466            Else 
467               sPathFileNew = sFile 
468            End If 
469     
470            iPos = InStrRev(sFile, "\") 
471     
472             'turn into relative reference
473            sPathFileNew = Mid(sPathFileNew, Len(sPathAttachment) + 1) 
474            iPos = InStrRev(sPathFileNew, "\") 
475            sFile = Mid(sPathFileNew, iPos + 1) 
476     
477            sSQL = "SELECT AttL.AttLinkID, AttL.AttLink, AttL.AttTypID, AttL.AttExt" _ 
478               & " FROM c_AttLinks AS AttL;" 
479     
480            Set db = CurrentDb 
481            Set rs = db.OpenRecordset(sSQL, dbOpenDynaset, dbAppendOnly) 
482     
483            With rs 
484               .AddNew 
485               !AttLink = sPathFileNew 
486               iPos = InStrRev(sFile, ".") 
487               If iPos > 1 Then 
488                  sAttExt = Mid(sPathFileNew, iPos) 
489                  !AttExt = sAttExt 
490               End If 
491               Select Case sAttExt 
492               Case ".jpg", ".bmp", "png" 
493                  !AttTypID = 2 
494               Case Else 
495                  !AttTypID = 1 
496               End Select 
497               .Update 
498               .Bookmark = .LastModified 
499               nAttLinkID = !AttLinkID 
500               .Close 
501            End With 
502            Set rs = Nothing 
503     
504            With Me.AttLinkID 
505               .Requery 
506               .Value = nAttLinkID 
507            End With 
508            Me.AttName = sFile 
509         End If 
510     
511      Proc_Exit: 
512         On Error Resume Next 
513         If Not rs Is Nothing Then 
514            rs.Close 
515            Set rs = Nothing 
516         End If 
517         Set db = Nothing 
518         Exit Sub 
519     
520      Proc_Err: 
521         MsgBox Err.Description, , _ 
522                "ERROR " & Err.Number _ 
523                & "   BrowseToFile : " & Me.Name 
524     
525         Resume Proc_Exit 
526          'if you want to single-step code to find error, CTRL-Break at MsgBox
527          'then set this to be the next statement
528         Resume 
529      End Sub 
      Goto Top       Goto Form_fc_AnywhereAttachments       Goto Index

AddURL (78)

530     
531      Private Function AddURL(psURL As String, psName As String) As Long 
532       '130916 Crystal ... 17
533     
534          'RETURN
535          '  AttLinkID
536          '  psName --> Name of Link
537     
538         AddURL = -99 
539     
540         Dim db As DAO.Database _ 
541            , rs As DAO.Recordset 
542     
543         Dim sSQL As String _ 
544            , nAttLinkID As Long _ 
545            , iPos As Integer _ 
546            , sExtension As String 
547     
548         Call CorrectWebAddress(psURL) 
549         If Not DoesWebAddressStartRight(psURL) Then 
550            If MsgBox("Web address doesn't seem right ... use it anyway?" _ 
551                  & vbCrLf & vbCrLf & psURL _ 
552                  , vbYesNo, "Is Web Address OK?") <> vbYes Then 
553               Exit Function 
554            End If 
555         End If 
556     
557         sExtension = "" 
558         psName = "" 
559         psName = GetNameFromURL(psURL, sExtension) 
560     
561         sSQL = "SELECT AttL.AttLinkID, AttL.AttLink, AttL.AttTypID, AttL.AttExt" _ 
562            & " FROM c_AttLinks AS AttL;" 
563     
564         Set db = CurrentDb 
565         Set rs = db.OpenRecordset(sSQL, dbOpenDynaset, dbAppendOnly) 
566     
567         With rs 
568            .AddNew 
569            !AttLink = psURL 
570            iPos = InStrRev(psURL, "/") 
571            If iPos > 1 Then 
572               psName = Mid(psURL, iPos) 
573            End If 
574     
575            !AttTypID = 3 
576     
577            If Len(sExtension) > 0 Then 
578               !AttExt = sExtension 
579            End If 
580     
581            .Update 
582            .Bookmark = .LastModified 
583            nAttLinkID = !AttLinkID 
584            .Close 
585         End With 
586         Set rs = Nothing 
587     
588         AddURL = nAttLinkID 
589      Proc_Exit: 
590         On Error Resume Next 
591         If Not rs Is Nothing Then 
592            rs.Close 
593            Set rs = Nothing 
594         End If 
595         Set db = Nothing 
596         Exit Function 
597     
598      Proc_Err: 
599         MsgBox Err.Description, , _ 
600                "ERROR " & Err.Number _ 
601                & "   AddURL : " & Me.Name 
602     
603         Resume Proc_Exit 
604          'if you want to single-step code to find error, CTRL-Break at MsgBox
605          'then set this to be the next statement
606         Resume 
607      End Function 
      Goto Top       Goto Form_fc_AnywhereAttachments       Goto Index

cmd_Add_Click (52)

608     
609      Private Sub cmd_Add_Click() 
610       '100223,110101, 130908
611     
612          'CALLS
613          '  RecordNew
614          '  cmd_Browse_Click
615          '  Form_Current
616     
617          'set up error handler
618         On Error GoTo Proc_Err 
619     
620         Dim sWhich As String 
621     
622         sWhich = InputBox("Add File or Web address or Pick from list (F/W/P)" _ 
623                     , "What kind of link do you want to add?" _ 
624                     , "F") 
625         If sWhich = "" Then Exit Sub 
626     
627         On Error Resume Next 
628         With Me 
629       '      If .Recordset.RecordCount > 0 Then
630               If .Dirty Then .Dirty = False 
631       '      End If
632            On Error GoTo Proc_Err 
633     
634            If Not Me.NewRecord Then 
635               DoCmd.RunCommand acCmdRecordsGoToNew 
636            End If 
637     
638            If sWhich = "W" Then 
639               .txtURL.SetFocus 
640            ElseIf sWhich = "P" Then 
641               .AttLinkID.SetFocus 
642               .AttLinkID.Dropdown 
643            Else 
644               Call BrowseToFile 
645               .AttName.SetFocus 
646            End If 
647     
648         End With 
649     
650      Proc_Exit: 
651         On Error Resume Next 
652         Exit Sub 
653      Proc_Err: 
654         MsgBox Err.Description _ 
655                , , "ERROR: " & Err.Number _ 
656                    & "    cmd_Add_Click " & ": " & Me.Name 
657         Resume Proc_Exit 
658         Resume 
659      End Sub 
      Goto Top       Goto Form_fc_AnywhereAttachments       Goto Index

cmd_Delete_Click (55)

660     
661     
662      Private Sub cmd_Delete_Click() 
663       '100204,8, 130813
664     
665         On Error GoTo Proc_Err 
666     
667         Dim sPathFile As String _ 
668            , sPathFileNew As String _ 
669            , iPos As Integer _ 
670            , nAttTypID As Long 
671     
672         If Me.Dirty Then Me.Undo 
673         If Me.NewRecord Then Exit Sub 
674     
675         If MsgBox( _ 
676            "Warning: If you continue record will be permanently deleted. " _ 
677            & " Do you want to continue and delete this record?" _ 
678            , vbYesNo + vbDefaultButton2 _ 
679              , "Permanently Delete Record?") <> vbYes Then 
680             'user changed their mind
681            Exit Sub 
682         End If 
683     
684         If Not IsNull(Me.AttLinkID) Then 
685            nAttTypID = Me.AttLinkID_AttTypID 
686     
687             'rename file starting with "x"
688            Select Case nAttTypID 
689            Case 1, 2 
690               sPathFile = GetWholePathFile(Me.AttLinkID.Column(1)) 
691     
692               iPos = InStrRev(sPathFile, "\") 
693               If iPos > 0 Then 
694                  sPathFileNew = Left(sPathFile, iPos) & "x_" & Mid(sPathFile, iPos + 1) 
695                  Name sPathFile As sPathFileNew 
696               End If 
697            End Select 
698         End If 
699     
700         DoCmd.RunCommand acCmdDeleteRecord 
701     
702         Call Form_Current 
703     
704     
705      Proc_Exit: 
706         On Error Resume Next 
707         Exit Sub 
708      Proc_Err: 
709         MsgBox Err.Description _ 
710                , , "ERROR: " & Err.Number _ 
711                    & "    cmd_Delete_Click " & ": " & Me.Name 
712         Resume Proc_Exit 
713         Resume 
714      End Sub 
      Goto Top       Goto Form_fc_AnywhereAttachments       Goto Index

cmd_AddURL_Click (56)

715     
716     
717     
718     
719     
720      Private Sub cmd_AddURL_Click() 
721       '130916, 918
722       'CheckWebAddress
723          'CALLS
724          '  AddURL
725          '  GetMin
726     
727         Dim sLink As String _ 
728            , sName As String _ 
729            , sExtension As String _ 
730            , nAttLinkID As Long 
731     
732         If IsNull(Me.txtURL) Then 
733            MsgBox "No URL to add", , "Box is empty" 
734            Exit Sub 
735         End If 
736     
737         sName = "" 
738         sExtension = "" 
739     
740         sLink = Me.txtURL 
741     
742         nAttLinkID = AddURL(sLink, sName) 
743     
744         If nAttLinkID < -1 Then 
745             'link is not valid
746            Exit Sub 
747         End If 
748     
749         If Not IsNull(Me.AttLinkID) Then 
750            If MsgBox("Replace current link with this one: " _ 
751                  & vbCrLf & vbCrLf & sLink _ 
752                  & vbCrLf & vbCrLf & "?" _ 
753                  , vbYesNo, "Replace current data?") = vbNo Then 
754               Exit Sub 
755            End If 
756         End If 
757     
758         Me.txtURL = Null 
759     
760         Me.AttLinkID = nAttLinkID 
761     
762         If Len(sName) > 0 Then 
763            Me.AttName = sName 
764         End If 
765     
766         Me.Dirty = False 
767     
768         Me.AttLinkID.Requery 
769         Me.AttLinkID_AttTypID.Requery 
770      End Sub 
      Goto Top       Goto Form_fc_AnywhereAttachments       Goto Index

SynchronizeMyAttachments (124)

771     
772     
773     
774      Public Function SynchronizeMyAttachments( _ 
775         Optional pnTID As Long = -99 _ 
776         , Optional pnRecordID As Long = -99 _ 
777         ) As Boolean 
778       '...131002
779          'CALLS
780          '  Get_Property
781     
782         On Error GoTo Proc_Err 
783         SynchronizeMyAttachments = False 
784     
785         Dim db As DAO.Database _ 
786            , rs As DAO.Recordset 
787     
788         Dim nTID As Long _ 
789            , nRecordID As Long 
790     
791         Dim sSQL As String _ 
792            , sTablename As String _ 
793            , sFriendlyTable As String _ 
794            , sIDFieldname As String _ 
795            , sEquation As String 
796     
797         nTID = Get_Property("local_TID") 
798         If pnTID <> -99 Then 
799            If nTID <> pnTID Then 
800                'may want to SET-PROPERTY and/or return new value
801               nTID = pnTID 
802            End If 
803         End If 
804         If nTID = -99 Then 
805            MsgBox "Table is not specified for Anywhere Notes" _ 
806               , , "Error -- cannot open Anywhere Attachments" 
807            GoTo Proc_Exit 
808         End If 
809     
810         nRecordID = Get_Property("local_RecordID") 
811         If pnRecordID <> -99 Then 
812            If nRecordID <> pnRecordID Then 
813                'may want to SET-PROPERTY and/or return new value
814               nRecordID = pnRecordID 
815            End If 
816         End If 
817         If nRecordID = -99 Then 
818            MsgBox "Record ID is not specified for Anywhere Notes" _ 
819               , , "Error -- cannot open Anywhere Attachments" 
820            GoTo Proc_Exit 
821         End If 
822     
823     
824         sSQL = "SELECT c_Attachments.* FROM c_Attachments " _ 
825            & " WHERE TID = " & nTID _ 
826            & " AND Recordid =" & nRecordID _ 
827            & ";" 
828     
829         With Me 
830            .RecordSource = sSQL   '------------- Form.RecordSource 
831            .TID.DefaultValue = nTID 
832            .RecordID.DefaultValue = nRecordID 
833         End With 
834     
835         sSQL = "SELECT Tbl, FriendlyT, FldAuto, EqnTxt " _ 
836            & " FROM c_Tables " _ 
837            & " WHERE TID=" & nTID _ 
838            & ";" 
839     
840         Set db = CurrentDb 
841         Set rs = db.OpenRecordset(sSQL, dbOpenSnapshot) 
842         With rs 
843            If .EOF Then 
844               MsgBox "Error with definition table c_Tables for TID=" & nTID _ 
845                  , , "Can't attach attachment" 
846               GoTo Proc_Exit 
847            End If 
848     
849            sTablename = !Tbl 
850            sFriendlyTable = !FriendlyT 
851            sIDFieldname = !FldAuto 
852            sEquation = !EqnTxt 
853     
854            .Close 
855         End With   'rs 
856         Set rs = Nothing 
857     
858         Me.Label_Title.Caption = sFriendlyTable & " Attachments"   '------------- Form Title 
859     
860         sSQL = "SELECT tbl.[" & sIDFieldname & "] AS ID" _ 
861            & ", " & sEquation & " AS Record " _ 
862            & " FROM [" & sTablename & "] AS tbl " _ 
863            & " ORDER BY " & sEquation & ";" 
864     
865         Me.RecordID_Equation.RowSource = sSQL   '------------- Equation.RowSource 
866     
867         With Me 
868            sSQL = .fnd_Record.Tag 
869            sSQL = Replace(Replace(sSQL, "99", nTID), "88", nRecordID) 
870            .fnd_Record.RowSource = sSQL   '------------- fnd_Record.RowSource 
871            On Error Resume Next 
872            .fnd_Record.Requery 
873         End With 
874     
875         SynchronizeMyAttachments = True 
876     
877      Proc_Exit: 
878         On Error Resume Next 
879         If Not rs Is Nothing Then 
880            rs.Close 
881            Set rs = Nothing 
882         End If 
883         Set db = Nothing 
884         Exit Function 
885     
886      Proc_Err: 
887         MsgBox Err.Description, , _ 
888              "ERROR " & Err.Number _ 
889              & "   SynchronizeMyAttachments : " & Me.Name 
890     
891         Resume Proc_Exit 
892         Resume 
893     
894      End Function 
      Goto Top       Goto Form_fc_AnywhereAttachments       Goto Index

RequeryMyParent (9)

895     
896      Private Sub RequeryMyParent()   '---- currently not used 
897         If IsSubform(Me) Then 
898            Me.Parent.RequeryMyControls 
899         End If 
900      End Sub 
901     
902     
903     
      Goto Top       Goto Form_fc_AnywhereAttachments       Goto Index

Form_fc_AnywhereNotes (385)

PROCEDURES       Goto Top       Goto Form_fc_AnywhereNotes       Goto Forms       Goto Index
  1. cmd_Close_Click (5)
  2. cmd_SetAppt_Click (5)
  3. Declaration Lines (36)
  4. dtmDun_DblClick (5)
  5. dtmNote_DblClick (5)
  6. dtmToDo_DblClick (5)
  7. fnd_Record_AfterUpdate (33)
  8. Form_AfterUpdate (11)
  9. Form_BeforeInsert (8)
  10. Form_BeforeUpdate (23)
  11. Form_Current (4)
  12. Form_Open (49)
  13. NoteDate_DblClick (5)
  14. Subject_AfterUpdate (6)
  15. SynchronizeMyNotes (180)
  16. TypIDnote_NotInList (5)

Declaration Lines (36)

1        Option Compare Database 
2        Option Explicit 
3         '=======================================================
4         '
5         ' code behind form: fc_AnywhereNotes
6         '
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, 140629
28        ' ~ Crystal
29        '              * have an awesome day :)
30        '                                                   www.AccessMVP.com/strive4peace
31        ' END LICENSE NOTICE
32        '============================================================
33        '
34        'NEEDS PROPERTIES:
35        '   "local_TID"
36        '   "local_RecordID"
      Goto Top       Goto Form_fc_AnywhereNotes       Goto Index

Form_AfterUpdate (11)

37      
38      
39      
40       Private Sub Form_AfterUpdate() 
41        '130921
42          On Error Resume Next 
43          With Me.fnd_Record 
44             .Value = Null 
45             .Requery 
46          End With 
47       End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes       Goto Index

Form_BeforeInsert (8)

48      
49       Private Sub Form_BeforeInsert(Cancel As Integer) 
50        '130921
51        '   With Me
52        '      .TID = .TID.DefaultValue
53        '      .RecordID = .RecordID.DefaultValue
54        '   End With
55       End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes       Goto Index

Form_Open (49)

56      
57       Private Sub Form_Open(Cancel As Integer) 
58        '130813, 0921
59      
60           'CALLS
61           '  SynchronizeMyNotes
62      
63          On Error GoTo Proc_Err 
64      
65          Dim bBoo As Boolean 
66      
67        '   With Me
68        '      .TID.DefaultValue = nTID
69        '      .RecordID.DefaultValue = nRecordID
70        '      If nRolliD > 0 Then
71        '         .RollID.DefaultValue = nRolliD
72        '      Else
73        '         .RollID.DefaultValue = Null
74        '      End If
75        '
76        '   End With
77      
78          bBoo = IsSubform(Me) 
79           'if this is a subform, hide the close button
80          Me.cmd_Close.Visible = Not bBoo 
81      
82           'if this is a subform, exit -- let Parent form trigger synchronizing
83          If bBoo = True Then 
84             Exit Sub 
85          End If 
86      
87           'Call SynchronizeMyNotes
88          If Not SynchronizeMyNotes() Then 
89             Cancel = True 
90          End If 
91      
92       Proc_Exit: 
93          On Error Resume Next 
94          Exit Sub 
95      
96       Proc_Err: 
97          MsgBox Err.Description, , _ 
98               "ERROR " & Err.Number _ 
99               & "   Form_Open : " & Me.Name 
100     
101         Resume Proc_Exit 
102         Resume 
103     
104      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes       Goto Index

Form_Current (4)

105     
106      Private Sub Form_Current() 
107       '130921
108      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes       Goto Index

Form_BeforeUpdate (23)

109     
110      Private Sub Form_BeforeUpdate(Cancel As Integer) 
111       '101220 ... 130921
112     
113         Dim nTID As Long _ 
114            , nRecordID As Long _ 
115            , nRolliD As Long 
116     
117          'update tracking fields
118         FormBeforeUpdate Me, True 
119     
120       '   If Not IsSubform(Me) Then
121       '
122       '      nTID = Get_Property("local_TID")
123       '      nRecordID = Get_Property("local_RecordID")
124       '      nRolliD = Get_Property("local_RolliD")
125       '
126       '      Me.TID = nTID
127       '      Me.RecordID = nRecordID
128       '      If Not nRolliD = -99 Then Me.RolliD = nRolliD
129       '   End If
130     
131      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes       Goto Index

fnd_Record_AfterUpdate (33)

132     
133     
134     
135     
136      Private Sub fnd_Record_AfterUpdate() 
137       '101222
138     
139          'CALLS
140          '  FindRecordN
141     
142         On Error GoTo Proc_Err 
143         If IsNull(Me.fnd_Record) Then Exit Sub 
144     
145         If Me.Dirty Then 
146            Me.Dirty = False 
147         End If 
148     
149          'find the record
150         Call FindRecordN(Me, "NoteID", "Mem") 
151      Proc_Exit: 
152         On Error Resume Next 
153         Exit Sub 
154     
155      Proc_Err: 
156         MsgBox Err.Description, , _ 
157                "ERROR " & Err.Number _ 
158                & "   fnd_Record_AfterUpdate : " & Me.Name 
159     
160         Resume Proc_Exit 
161          'if you want to single-step code to find error, CTRL-Break at MsgBox
162          'then set this to be the next statement
163         Resume 
164      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes       Goto Index

cmd_Close_Click (5)

165     
166      Private Sub cmd_Close_Click() 
167       '130813
168         DoCmd.Close acForm, Me.Name, acSaveNo 
169      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes       Goto Index

cmd_SetAppt_Click (5)

170     
171      Private Sub cmd_SetAppt_Click() 
172       '140618
173         DoCmd.OpenForm "fc_pop_Appointment", , , , , acDialog 
174      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes       Goto Index

dtmDun_DblClick (5)

175     
176      Private Sub dtmDun_DblClick(Cancel As Integer) 
177       '130921
178         DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog 
179      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes       Goto Index

dtmToDo_DblClick (5)

180     
181      Private Sub dtmToDo_DblClick(Cancel As Integer) 
182       '130921
183         DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog 
184      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes       Goto Index

NoteDate_DblClick (5)

185     
186      Private Sub NoteDate_DblClick(Cancel As Integer) 
187       '110418
188         Me.dtmNote = Date 
189      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes       Goto Index

Subject_AfterUpdate (6)

190     
191      Private Sub Subject_AfterUpdate() 
192       '101222
193         If IsNull(Me.Subject) Then Exit Sub 
194         Me.Subject = StrConv(Me.Subject, vbProperCase) 
195      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes       Goto Index

TypIDnote_NotInList (5)

196     
197      Private Sub TypIDnote_NotInList(NewData As String, Response As Integer) 
198         MsgBox "TypIDnote_NotInList not defined for " & Me.Name _ 
199            , , "Write Code" 
200      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes       Goto Index

dtmNote_DblClick (5)

201     
202      Private Sub dtmNote_DblClick(Cancel As Integer) 
203       '130908
204         DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog 
205      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes       Goto Index

SynchronizeMyNotes (180)

206     
207      Public Function SynchronizeMyNotes( _ 
208         Optional pnTID As Long = -99 _ 
209         , Optional pnRecordID As Long = -99 _ 
210         , Optional pnRolliD As Long = -99 _ 
211         , Optional booRoll As Boolean = False _ 
212         ) As Boolean 
213       '130921
214     
215          'CALLS
216          '  Get_Property
217     
218         On Error GoTo Proc_Err 
219         SynchronizeMyNotes = False 
220     
221         Dim db As DAO.Database _ 
222            , rs As DAO.Recordset 
223     
224         Dim nTID As Long _ 
225            , nRecordID As Long _ 
226            , nRolliD As Long 
227     
228         nTID = Get_Property("local_TID") 
229         nRecordID = Get_Property("local_RecordID") 
230         nRolliD = Get_Property("local_RolliD") 
231     
232         Dim sSQL As String _ 
233            , sWhere As String _ 
234            , iPos1 As Integer _ 
235            , iPos2 As Integer _ 
236            , sTablename As String _ 
237            , sFriendlyTable As String _ 
238            , sIDFieldname As String _ 
239            , sEquation As String 
240     
241         If pnTID <> -99 Then 
242            If nTID <> pnTID Then 
243                'may want to SET-PROPERTY and/or return new value
244               nTID = pnTID 
245            End If 
246         End If 
247         If nTID = -99 Then 
248            MsgBox "Table is not specified for Anywhere Notes" _ 
249               , , "Error -- cannot open Anywhere Notes" 
250            GoTo Proc_Exit 
251         End If 
252     
253         If pnRecordID <> -99 Then 
254            If nRecordID <> pnRecordID Then 
255               nRecordID = pnRecordID 
256            End If 
257         End If 
258         If nRecordID = -99 Then 
259            MsgBox "Record ID is not specified for Anywhere Notes" _ 
260               , , "Error -- cannot open Anywhere Notes" 
261            GoTo Proc_Exit 
262         End If 
263     
264         If pnRolliD <> -99 Then 
265            If nRolliD <> pnRolliD Then 
266               nRolliD = pnRolliD 
267            End If 
268         End If 
269     
270       '   If booRoll And nRolliD = -99 Then
271       '      booRoll = False
272       '   End If
273          '-------------------------------------------------- TODO: parameter to show roll-up notes
274       '   sSQL = "SELECT c_Notes.* FROM c_Notes " _
275       '      & " WHERE TID = " & nTID _
276       '      & " AND Recordid =" & nRecordID _
277       '      & ";"
278     
279     
280     
281         With Me 
282            sSQL = Me.Tag 
283            sSQL = Replace(Replace(sSQL, 99, nTID), 88, nRecordID) 
284     
285       '      If booRoll Then
286       '         sWhere = " (N.Rollid=" & nRolliD & ")"
287       '         iPos1 = InStr(sSQL, " WHERE ") + 7
288       '         iPos2 = InStr(sSQL, " ORDER BY ")
289       '         sSQL = Left(sSQL, iPos1) & sWhere & Mid(sSQL, iPos2)
290       '      End If
291      Debug.Print sSQL 
292            .RecordSource = sSQL   '------------- Form.RecordSource 
293            .TID.DefaultValue = nTID 
294     
295            If nRecordID <> -99 Then 
296               .RecordID.DefaultValue = nRecordID 
297            Else 
298               .RecordID.DefaultValue = "" 
299            End If 
300     
301            If nRolliD <> -99 Then 
302               .RollID.DefaultValue = nRolliD 
303            Else 
304               .RollID.DefaultValue = Null 
305            End If 
306     
307         End With 
308     
309         sSQL = "SELECT Tbl, FriendlyT, FldAuto, EqnTxt " _ 
310            & " FROM c_Tables " _ 
311            & " WHERE TID=" & nTID _ 
312            & ";" 
313     
314         Set db = CurrentDb 
315         Set rs = db.OpenRecordset(sSQL, dbOpenSnapshot) 
316         With rs 
317            If .EOF Then 
318               MsgBox "Error with definition table c_Tables for TID=" & nTID _ 
319                  , , "Can't attach note" 
320               GoTo Proc_Exit 
321            End If 
322     
323            sTablename = !Tbl 
324            sFriendlyTable = !FriendlyT 
325            sIDFieldname = !FldAuto 
326            sEquation = !EqnTxt 
327     
328            .Close 
329         End With   'rs 
330         Set rs = Nothing 
331     
332       '   Me.RecordID_Equation.Visible = Not booRoll
333       '
334       '   If booRoll Then
335       '      Me.Label_Title.Caption = sFriendlyTable & " Notes" _
336       '      & vbCrLf & Get_Property("local_Contact")      '------------- Form Title
337       '
338       '   Else
339            Me.Label_Title.Caption = sFriendlyTable & " Notes"   '------------- Form Title 
340            sSQL = "SELECT tbl.[" & sIDFieldname & "] AS ID" _ 
341               & ", " & sEquation & " AS Record " _ 
342               & " FROM [" & sTablename & "] AS tbl " _ 
343               & " ORDER BY " & sEquation & ";" 
344     
345            Me.RecordID_Equation.RowSource = sSQL   '------------- Equation.RowSource 
346     
347       '   End If
348     
349     
350         With Me 
351            sSQL = .fnd_Record.Tag 
352            sSQL = Replace(Replace(sSQL, "99", nTID), "88", nRecordID) 
353     
354            If booRoll Then 
355               sWhere = " (N.Rollid=" & nRolliD & ")" 
356               iPos1 = InStr(sSQL, " WHERE ") + 7 
357               iPos2 = InStr(sSQL, " ORDER BY ") 
358               sSQL = Left(sSQL, iPos1) & sWhere & Mid(sSQL, iPos2) 
359            End If 
360     
361      Debug.Print sSQL 
362            .fnd_Record.RowSource = sSQL   '------------- fnd_Record.RowSource 
363         End With 
364     
365         SynchronizeMyNotes = True 
366     
367      Proc_Exit: 
368         On Error Resume Next 
369         If Not rs Is Nothing Then 
370            rs.Close 
371            Set rs = Nothing 
372         End If 
373         Set db = Nothing 
374         Exit Function 
375     
376      Proc_Err: 
377         MsgBox Err.Description, , _ 
378              "ERROR " & Err.Number _ 
379              & "   SynchronizeMyNotes : " & Me.Name 
380     
381         Resume Proc_Exit 
382         Resume 
383      End Function 
384     
385     
      Goto Top       Goto Form_fc_AnywhereNotes       Goto Index

Form_fc_AnywhereNotes_sub (366)

PROCEDURES       Goto Top       Goto Form_fc_AnywhereNotes_sub       Goto Forms       Goto Index
  1. cmd_Close_Click (5)
  2. Declaration Lines (36)
  3. dtmDun_DblClick (5)
  4. dtmNote_DblClick (5)
  5. dtmToDo_DblClick (5)
  6. fnd_Record_AfterUpdate (33)
  7. Form_AfterUpdate (10)
  8. Form_BeforeInsert (8)
  9. Form_BeforeUpdate (23)
  10. Form_Current (4)
  11. Form_Open (41)
  12. NoteDate_DblClick (5)
  13. Subject_AfterUpdate (6)
  14. SynchronizeMyNotes (175)
  15. TypIDnote_NotInList (5)

Declaration Lines (36)

1        Option Compare Database 
2        Option Explicit 
3         '=======================================================
4         '
5         ' code behind form: fc_AnywhereNotes
6         '
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, 140629
28        ' ~ Crystal
29        '              * have an awesome day :)
30        '                                                   www.AccessMVP.com/strive4peace
31        ' END LICENSE NOTICE
32        '============================================================
33        '
34        'NEEDS PROPERTIES:
35        '   "local_TID"
36        '   "local_RecordID"
      Goto Top       Goto Form_fc_AnywhereNotes_sub       Goto Index

dtmDun_DblClick (5)

37      
38       Private Sub dtmDun_DblClick(Cancel As Integer) 
39        '130921
40          DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog 
41       End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes_sub       Goto Index

dtmToDo_DblClick (5)

42      
43       Private Sub dtmToDo_DblClick(Cancel As Integer) 
44        '130921
45          DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog 
46       End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes_sub       Goto Index

Form_AfterUpdate (10)

47      
48       Private Sub Form_AfterUpdate() 
49        '130921
50          On Error Resume Next 
51          With Me.fnd_Record 
52             .Value = Null 
53             .Requery 
54          End With 
55          Me.ToDo.Requery 
56       End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes_sub       Goto Index

Form_BeforeInsert (8)

57      
58       Private Sub Form_BeforeInsert(Cancel As Integer) 
59        '130921
60          With Me 
61             .TID = .TID.DefaultValue 
62             .RecordID = .RecordID.DefaultValue 
63          End With 
64       End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes_sub       Goto Index

Form_Open (41)

65      
66       Private Sub Form_Open(Cancel As Integer) 
67        '130813, 0921
68      
69           'CALLS
70           '  SynchronizeMyNotes
71      
72          On Error GoTo Proc_Err 
73      
74          Dim bBoo As Boolean 
75      
76          bBoo = IsSubform(Me) 
77           'if this is a subform, hide the close button
78          Me.cmd_Close.Visible = Not bBoo 
79      
80           'if this is a subform, exit -- let Parent form trigger synchronizing
81          If bBoo = True Then 
82             Exit Sub 
83          End If 
84      
85           'AnywhereNotes is being popped up
86      
87        '   'Call SynchronizeMyNotes
88          Call SynchronizeMyNotes 
89        '   If Not SynchronizeMyNotes() Then
90        '      Cancel = True
91        '   End If
92        '
93       Proc_Exit: 
94          On Error Resume Next 
95          Exit Sub 
96      
97       Proc_Err: 
98          MsgBox Err.Description, , _ 
99               "ERROR " & Err.Number _ 
100              & "   Form_Open : " & Me.Name 
101     
102         Resume Proc_Exit 
103         Resume 
104     
105      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes_sub       Goto Index

Form_Current (4)

106     
107      Private Sub Form_Current() 
108       '130921
109      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes_sub       Goto Index

Form_BeforeUpdate (23)

110     
111      Private Sub Form_BeforeUpdate(Cancel As Integer) 
112       '101220 ... 130921
113     
114         Dim nTID As Long _ 
115            , nRecordID As Long _ 
116            , nRolliD As Long 
117     
118          'update tracking fields
119         FormBeforeUpdate Me, True 
120     
121       '   If Not IsSubform(Me) Then
122       '
123       '      nTID = Get_Property("local_TID")
124       '      nRecordID = Get_Property("local_RecordID")
125       '      nRolliD = Get_Property("local_RolliD")
126       '
127       '      Me.TID = nTID
128       '      Me.RecordID = nRecordID
129       '      If Not nRolliD = -99 Then Me.RolliD = nRolliD
130       '   End If
131     
132      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes_sub       Goto Index

fnd_Record_AfterUpdate (33)

133     
134     
135     
136     
137      Private Sub fnd_Record_AfterUpdate() 
138       '101222
139     
140          'CALLS
141          '  FindRecordN
142     
143         On Error GoTo Proc_Err 
144         If IsNull(Me.fnd_Record) Then Exit Sub 
145     
146         If Me.Dirty Then 
147            Me.Dirty = False 
148         End If 
149     
150          'find the record
151         Call FindRecordN(Me, "NoteID", "Mem") 
152      Proc_Exit: 
153         On Error Resume Next 
154         Exit Sub 
155     
156      Proc_Err: 
157         MsgBox Err.Description, , _ 
158                "ERROR " & Err.Number _ 
159                & "   fnd_Record_AfterUpdate : " & Me.Name 
160     
161         Resume Proc_Exit 
162          'if you want to single-step code to find error, CTRL-Break at MsgBox
163          'then set this to be the next statement
164         Resume 
165      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes_sub       Goto Index

cmd_Close_Click (5)

166     
167      Private Sub cmd_Close_Click() 
168       '130813
169         DoCmd.Close acForm, Me.Name, acSaveNo 
170      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes_sub       Goto Index

NoteDate_DblClick (5)

171     
172      Private Sub NoteDate_DblClick(Cancel As Integer) 
173       '110418
174         Me.dtmNote = Date 
175      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes_sub       Goto Index

Subject_AfterUpdate (6)

176     
177      Private Sub Subject_AfterUpdate() 
178       '101222
179         If IsNull(Me.Subject) Then Exit Sub 
180         Me.Subject = StrConv(Me.Subject, vbProperCase) 
181      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes_sub       Goto Index

TypIDnote_NotInList (5)

182     
183      Private Sub TypIDnote_NotInList(NewData As String, Response As Integer) 
184         MsgBox "TypIDnote_NotInList not defined for " & Me.Name _ 
185            , , "Write Code" 
186      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes_sub       Goto Index

dtmNote_DblClick (5)

187     
188      Private Sub dtmNote_DblClick(Cancel As Integer) 
189       '130908
190         DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog 
191      End Sub 
      Goto Top       Goto Form_fc_AnywhereNotes_sub       Goto Index

SynchronizeMyNotes (175)

192     
193      Public Function SynchronizeMyNotes( _ 
194         Optional pnTID As Long = -99 _ 
195         , Optional pnRecordID As Long = -99 _ 
196         , Optional pnRolliD As Long = -99 _ 
197         , Optional booRoll As Boolean = False _ 
198         ) As Boolean 
199       '130921
200     
201       '
202       '
203       '   'CALLS
204       '   '  Get_Property
205       '
206       '   On Error GoTo Proc_Err
207       '   SynchronizeMyNotes = False
208       '
209       '   Dim db As DAO.Database _
210       '      , rs As DAO.Recordset
211       '
212       '   Dim nTID As Long _
213       '      , nRecordID As Long _
214       '      , nRolliD As Long
215       '
216       '   Dim sSQL As String _
217       '      , sWhere As String _
218       '      , iPos1 As Integer _
219       '      , iPos2 As Integer _
220       '      , sTablename As String _
221       '      , sFriendlyTable As String _
222       '      , sIDFieldname As String _
223       '      , sEquation As String
224       '
225       '   nTID = 100  'subform for Contacts -- Get_Property("local_TID")
226       ''   If pnTID <> -99 Then
227       ''      If nTID <> pnTID Then
228       ''         'may want to SET-PROPERTY and/or return new value
229       ''         nTID = pnTID
230       ''      End If
231       ''   End If
232       ''   If nTID = -99 Then
233       ''      MsgBox "Table is not specified for Anywhere Notes" _
234       ''         , , "Error -- cannot open Anywhere Notes"
235       ''      GoTo Proc_Exit
236       ''   End If
237       ''
238       '   nRecordID = Get_Property("local_RecordID")
239       '   If pnRecordID <> -99 Then
240       '      If nRecordID <> pnRecordID Then
241       '         nRecordID = pnRecordID
242       '      End If
243       '   End If
244       '   If nRecordID = -99 Then
245       '      MsgBox "Record ID is not specified for Anywhere Notes" _
246       '         , , "Error -- cannot open Anywhere Notes"
247       '      GoTo Proc_Exit
248       '   End If
249       '
250       '   nRolliD = Get_Property("local_RolliD")
251       '   If pnRolliD <> -99 Then
252       '      If nRolliD <> pnRolliD Then
253       '         nRolliD = pnRolliD
254       '      End If
255       '   End If
256       '
257       '   If booRoll And nRolliD = -99 Then
258       '      booRoll = False
259       '   End If
260       '   '-------------------------------------------------- TODO: parameter to show roll-up notes
261       ''   sSQL = "SELECT c_Notes.* FROM c_Notes " _
262       ''      & " WHERE TID = " & nTID _
263       ''      & " AND Recordid =" & nRecordID _
264       ''      & ";"
265       '
266       '   With Me
267       '      sSQL = Me.Tag
268       '      sSQL = Replace(Replace(sSQL, 99, nTID), 88, nRecordID)
269       '
270       '      If booRoll Then
271       '         sWhere = " (N.Rollid=" & nRolliD & ")"
272       '         iPos1 = InStr(sSQL, " WHERE ") + 7
273       '         iPos2 = InStr(sSQL, " ORDER BY ")
274       '         sSQL = Left(sSQL, iPos1) & sWhere & Mid(sSQL, iPos2)
275       '      End If
276       'Debug.Print sSQL
277       '      .RecordSource = sSQL '------------- Form.RecordSource
278       '      .TID.DefaultValue = nTID
279       '
280       '      If nRolliD <> -99 Then
281       '         .RollID.DefaultValue = nRolliD
282       '      Else
283       '         .RollID.DefaultValue = ""
284       '      End If
285       '
286       '      .RecordID.DefaultValue = nRecordID
287       '
288       '   End With
289       '
290       '   sSQL = "SELECT Tbl, FriendlyT, FldAuto, EqnTxt " _
291       '      & " FROM c_Tables " _
292       '      & " WHERE TID=" & nTID _
293       '      & ";"
294       '
295       '   Set db = CurrentDb
296       '   Set rs = db.OpenRecordset(sSQL, dbOpenSnapshot)
297       '   With rs
298       '      If .EOF Then
299       '         MsgBox "Error with definition table c_Tables for TID=" & nTID _
300       '            , , "Can't attach note"
301       '         GoTo Proc_Exit
302       '      End If
303       '
304       '      sTablename = !Tbl
305       '      sFriendlyTable = !FriendlyT
306       '      sIDFieldname = !FldAuto
307       '      sEquation = !EqnTxt
308       '
309       '      .Close
310       '   End With 'rs
311       '   Set rs = Nothing
312       '
313       '   Me.RecordID_Equation.Visible = Not booRoll
314       '
315       '   If booRoll Then
316       '      Me.Label_Title.Caption = sFriendlyTable & " Notes" _
317       '      & vbCrLf & Get_Property("local_Contact")      '------------- Form Title
318       '
319       '   Else
320       '      Me.Label_Title.Caption = sFriendlyTable & " Notes" '------------- Form Title
321       '      sSQL = "SELECT tbl.[" & sIDFieldname & "] AS ID" _
322       '         & ", " & sEquation & " AS Record " _
323       '         & " FROM [" & sTablename & "] AS tbl " _
324       '         & " ORDER BY " & sEquation & ";"
325       '
326       '      Me.RecordID_Equation.RowSource = sSQL '------------- Equation.RowSource
327       '
328       '   End If
329       '
330       '
331       '   With Me
332       '      sSQL = .fnd_Record.Tag
333       '      sSQL = Replace(Replace(sSQL, "99", nTID), "88", nRecordID)
334       '
335       '      If booRoll Then
336       '         sWhere = " (N.Rollid=" & nRolliD & ")"
337       '         iPos1 = InStr(sSQL, " WHERE ") + 7
338       '         iPos2 = InStr(sSQL, " ORDER BY ")
339       '         sSQL = Left(sSQL, iPos1) & sWhere & Mid(sSQL, iPos2)
340       '      End If
341       '
342       'Debug.Print sSQL
343       '      .fnd_Record.RowSource = sSQL '------------- fnd_Record.RowSource
344       '   End With
345       '
346       '   SynchronizeMyNotes = True
347       '
348       'Proc_Exit:
349       '   On Error Resume Next
350       '   If Not rs Is Nothing Then
351       '      rs.Close
352       '      Set rs = Nothing
353       '   End If
354       '   Set db = Nothing
355       '   Exit Function
356       '
357       'Proc_Err:
358       '   MsgBox Err.Description, , _
359       '        "ERROR " & Err.Number _
360       '        & "   SynchronizeMyNotes : " & Me.Name
361       '
362       '   Resume Proc_Exit
363       '   Resume
364      End Function 
365     
366     
      Goto Top       Goto Form_fc_AnywhereNotes_sub       Goto Index

Form_fc_Contact_Categories_sub (193)

PROCEDURES       Goto Top       Goto Form_fc_Contact_Categories_sub       Goto Forms       Goto Index
  1. cmd_Del_Click (51)
  2. cmd_Edit_Click (9)
  3. cmd_Mark_Click (27)
  4. Declaration Lines (28)
  5. DeleteCategory (44)
  6. MarkCategory (34)

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_fc_Contact_Categories_sub       Goto Index

cmd_Del_Click (51)

29      
30       Private Sub cmd_Del_Click() 
31        '130918, 921
32          On Error GoTo Proc_Err 
33      
34          Dim sTablename As String _ 
35          , nCID As Long _ 
36          , ncCatID As Long _ 
37          , sFriendlyTable As String _ 
38          , sContact As String 
39      
40      
41          With Me 
42             If IsNull(.cCatID) Then 
43                MsgBox "Category is not marked", , "Cannot Delete Category" 
44                GoTo Proc_Exit 
45             End If 
46             sTablename = .Tbl 
47             sFriendlyTable = .FriendlyT 
48             nCID = .CID 
49             ncCatID = .cCatID 
50          End With 
51          sContact = Get_Property("local_Contact") 
52      
53          If MsgBox( _ 
54          "Delete " & sFriendlyTable & " for " & sContact & "?" _ 
55          , vbYesNo _ 
56          , "DELETE?") <> vbYes Then Exit Sub 
57      
58          If Not DeleteCategory(sTablename, nCID, ncCatID) > 0 Then 
59        '      MsgBox "Category cannot be removed until related records are deleted" _
60        '         , , "Can't delete"
61             Exit Sub 
62          End If 
63      
64          Me.Refresh 
65      
66          MsgBox sFriendlyTable & " removed for " & sContact, , "Done" 
67      
68       Proc_Exit: 
69          On Error Resume Next 
70          Exit Sub 
71      
72       Proc_Err: 
73          MsgBox Err.Description, , _ 
74               "ERROR " & Err.Number _ 
75               & "   cmd_Del_Click : " & Me.Name 
76      
77          Resume Proc_Exit 
78          Resume 
79       End Sub 
      Goto Top       Goto Form_fc_Contact_Categories_sub       Goto Index

cmd_Edit_Click (9)

80      
81       Private Sub cmd_Edit_Click() 
82        '130930, 1002
83          If IsNull(Me.frmEdit) Then Exit Sub 
84          With Me.CID 
85             If IsNull(.Value) Then Exit Sub 
86             DoCmd.OpenForm Me.frmEdit, , , "CID=" & .Value 
87          End With 
88       End Sub 
      Goto Top       Goto Form_fc_Contact_Categories_sub       Goto Index

cmd_Mark_Click (27)

89      
90       Private Sub cmd_Mark_Click() 
91        '130918
92          Dim sTablename As String _ 
93          , nCID As Long _ 
94          , sFriendlyTable As String _ 
95          , sContact As String 
96      
97          With Me 
98             sTablename = .Tbl 
99             sFriendlyTable = .FriendlyT 
100            nCID = .CID 
101         End With 
102         sContact = Get_Property("local_Contact") 
103     
104         If Not IsNull(Me.ctcCatID) Then 
105            MsgBox sFriendlyTable & " is already a category for " & sContact _ 
106               , , "Note" 
107            Exit Sub 
108         End If 
109     
110         Call MarkCategory(sTablename, nCID) 
111         Me.Refresh 
112     
113         MsgBox sFriendlyTable & " added for " & sContact, , "Done" 
114     
115      End Sub 
      Goto Top       Goto Form_fc_Contact_Categories_sub       Goto Index

MarkCategory (34)

116     
117      Private Sub MarkCategory(psTablename As String _ 
118         , pnCID As Long _ 
119         ) 
120       '101229, 130916
121         On Error GoTo Proc_Err 
122         Dim sSQL As String 
123     
124         sSQL = "INSERT INTO " & psTablename & " (CID, " & Me.fld & ")" _ 
125            & " SELECT " & pnCID _ 
126                  & ", """ & Replace(Me.Parent.ContactName, """", """""") & """" _ 
127                  & ";" 
128         Call rSql(sSQL) 
129         DoEvents 
130         sSQL = "INSERT INTO c_ctcCat (CID, cCatID) " _ 
131            & " SELECT " & pnCID _ 
132            & ", " & Me.cCatID _ 
133            & ";" 
134         Call rSql(sSQL) 
135         Call EndTime 
136         DoEvents 
137         Me.Requery 
138      Proc_Exit: 
139         On Error Resume Next 
140         Exit Sub 
141     
142      Proc_Err: 
143         MsgBox Err.Description, , _ 
144              "ERROR " & Err.Number _ 
145              & "   MarkCategory : " & Me.Name 
146     
147         Resume Proc_Exit 
148         Resume 
149      End Sub 
      Goto Top       Goto Form_fc_Contact_Categories_sub       Goto Index

DeleteCategory (44)

150     
151      Private Function DeleteCategory(psTablename As String _ 
152         , pnCID As Long _ 
153         , ncCatID As Long _ 
154         ) As Boolean 
155       '101229, 130916, 921
156         On Error GoTo Proc_Err 
157     
158         Dim sSQL 
159         DeleteCategory = False 
160         sSQL = "DELETE [" & psTablename & "].* FROM [" & psTablename & "]" _ 
161            & " WHERE CID= " & pnCID & ";" 
162         If rSql(sSQL) > 0 Then 
163            DeleteCategory = True   'if not true -- has related records 
164         Else 
165            GoTo Proc_Exit 
166         End If 
167         DoEvents 
168         sSQL = "DELETE c_ctcCat.* FROM c_ctcCat  " _ 
169            & " WHERE CID= " & pnCID _ 
170            & " AND cCatID=" & ncCatID _ 
171            & ";" 
172         If rSql(sSQL) > 0 Then 
173       '      DeleteCategory = True
174         End If 
175         Call EndTime 
176         DoEvents 
177         Me.Requery 
178      Proc_Exit: 
179         On Error Resume Next 
180         Exit Function 
181     
182      Proc_Err: 
183         MsgBox Err.Description, , _ 
184              "ERROR " & Err.Number _ 
185              & "   DeleteCategory : " & Me.Name 
186     
187         Resume Proc_Exit 
188         Resume 
189      End Function 
190     
191     
192     
193     
      Goto Top       Goto Form_fc_Contact_Categories_sub       Goto Index

Form_fc_eAdr_sub (124)

PROCEDURES       Goto Top       Goto Form_fc_eAdr_sub       Goto Forms       Goto Index
  1. cmd_Add_Click (7)
  2. cmd_Del_Click (6)
  3. Declaration Lines (46)
  4. eAdr_BeforeUpdate (4)
  5. eAdr_DblClick (11)
  6. emaNote_AfterUpdate (7)
  7. Form_BeforeUpdate (20)
  8. TypIDead_NotInList (23)

Declaration Lines (46)

1        Option Compare Database 
2        Option Explicit 
3         '=======================================================
4         ' fc_eAdr_Sub
5         ' CONTACT MANAGEMENT APPLET
6         '=======================================================
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, 140629
28        ' ~ Crystal
29        '              * have an awesome day :)
30        '                                                   www.AccessMVP.com/strive4peace
31        ' END LICENSE NOTICE
32        '============================================================
33        ' CALLS
34        '   RecordNew
35        '   RecordDelete
36        '   FormBeforeUpdate
37        '   FormNoAdditions
38        '   ' ' TypeID_NIL
39        '
40        '   ' AttachNote
41        '3-20-09
42        '
43        '=======================================================
44        '
45        ' -107 code checked 101007
46        ' TypeID_NIL -- find code for TypID Not In List
      Goto Top       Goto Form_fc_eAdr_sub       Goto Index

cmd_Add_Click (7)

47      
48      
49       Private Sub cmd_Add_Click() 
50        '3-20-09 -107
51          On Error Resume Next 
52          RecordNew Me, "eAdr" 
53       End Sub 
      Goto Top       Goto Form_fc_eAdr_sub       Goto Index

cmd_Del_Click (6)

54      
55       Private Sub cmd_Del_Click() 
56        '3-20-09 -107
57          On Error Resume Next 
58          RecordDelete Me, "eAdr" 
59       End Sub 
      Goto Top       Goto Form_fc_eAdr_sub       Goto Index

eAdr_BeforeUpdate (4)

60      
61       Private Sub eAdr_BeforeUpdate(Cancel As Integer) 
62        'Is Null Or ((Like "*?@?*.?*") And (Not Like "*[ ,;]*"))
63       End Sub 
      Goto Top       Goto Form_fc_eAdr_sub       Goto Index

eAdr_DblClick (11)

64      
65       Private Sub eAdr_DblClick(Cancel As Integer) 
66        '3-20-09 -107
67          On Error Resume Next 
68          If IsNull(Me.eAdr) Then 
69             MsgBox "Email Address is not filled out" _ 
70             , , "Cannot send email" 
71             Exit Sub 
72          End If 
73          Application.FollowHyperlink "mailto:" & Me.eAdr & "?subject=Message from my Contact Database" 
74       End Sub 
      Goto Top       Goto Form_fc_eAdr_sub       Goto Index

emaNote_AfterUpdate (7)

75      
76      
77       Private Sub emaNote_AfterUpdate() 
78        '101007
79          If IsNull(Me.ActiveControl) Then Exit Sub 
80          Me.ActiveControl = StrConv(Me.ActiveControl, 3)   'vbProperCase 
81       End Sub 
      Goto Top       Goto Form_fc_eAdr_sub       Goto Index

Form_BeforeUpdate (20)

82      
83       Private Sub Form_BeforeUpdate(Cancel As Integer) 
84        '110101 TONY
85      
86          Select Case AskSaveTheChanges("eAdr" _ 
87             , Nz(Me.eAdr, "")) 
88      
89             Case vbCancel 
90                Me.Undo 
91                Cancel = True 
92             Case vbNo 
93                Cancel = True 
94             Case vbYes 
95                 'update tracking fields
96                On Error Resume Next 
97                FormBeforeUpdate Me, True 
98             Case Else 
99        '         MsgBox mAnswer
100         End Select 
101      End Sub 
      Goto Top       Goto Form_fc_eAdr_sub       Goto Index

TypIDead_NotInList (23)

102     
103     
104      Private Sub TypIDead_NotInList( _ 
105         NewData As String, _ 
106         Response As Integer) 
107       '101010, 130815
108         On Error Resume Next 
109     
110          ' crystal (strive4peace)
111         Dim sTblNm As String _ 
112           , sFldNm As String _ 
113           , nTID As Long 
114     
115         sTblNm = "c_EadType" 
116         sFldNm = "TypEad" 
117         nTID = 0 
118     
119         Response = GetResponse_NIL(NewData, sTblNm, sFldNm, nTID, "Email Address Type") 
120     
121     
122      End Sub 
123     
124     
      Goto Top       Goto Form_fc_eAdr_sub       Goto Index

Form_fc_List_sub (76)

PROCEDURES       Goto Top       Goto Form_fc_List_sub       Goto Forms       Goto Index
  1. CID_NotInList (5)
  2. Declaration Lines (36)
  3. fnd_List_AfterUpdate (7)
  4. Form_AfterDelConfirm (8)
  5. Form_BeforeUpdate (7)
  6. ListName_AfterUpdate (5)
  7. listNote_AfterUpdate (8)

Declaration Lines (36)

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

CID_NotInList (5)

37      
38       Private Sub CID_NotInList(NewData As String, Response As Integer) 
39          MsgBox "CID_NotInList not defined", , "Write Code" 
40        '   Response = acDataErrContinue
41       End Sub 
      Goto Top       Goto Form_fc_List_sub       Goto Index

fnd_List_AfterUpdate (7)

42      
43      
44      
45       Private Sub fnd_List_AfterUpdate() 
46        '130831
47          Call FindRecordN(Me, "ListID", "ListName") 
48       End Sub 
      Goto Top       Goto Form_fc_List_sub       Goto Index

Form_AfterDelConfirm (8)

49      
50       Private Sub Form_AfterDelConfirm(Status As Integer) 
51           'if this form is being used as a subform, then do stuff
52           'if it was opened on its own, then don't
53           'If IsSubform(Me) Then
54              'Requery anything that needs it -- combos that collect ListID on other forms
55           'End If
56       End Sub 
      Goto Top       Goto Form_fc_List_sub       Goto Index

Form_BeforeUpdate (7)

57      
58      
59       Private Sub Form_BeforeUpdate(Cancel As Integer) 
60        '110327
61      
62          Me.dtmEdit = Now 
63       End Sub 
      Goto Top       Goto Form_fc_List_sub       Goto Index

ListName_AfterUpdate (5)

64      
65       Private Sub ListName_AfterUpdate() 
66       If IsNull(Me.ActiveControl) Then Exit Sub 
67          Me.ActiveControl = StrConv(Me.ActiveControl, 3)   'vbProperCase 
68       End Sub 
      Goto Top       Goto Form_fc_List_sub       Goto Index

listNote_AfterUpdate (8)

69      
70       Private Sub listNote_AfterUpdate() 
71       If IsNull(Me.ActiveControl) Then Exit Sub 
72          Me.ActiveControl = StrConv(Me.ActiveControl, 3)   'vbProperCase 
73       End Sub 
74      
75      
76      
      Goto Top       Goto Form_fc_List_sub       Goto Index

Form_fc_LISTS (87)

PROCEDURES       Goto Top       Goto Form_fc_LISTS       Goto Forms       Goto Index
  1. cmd_Add_Click (7)
  2. cmd_Del_Click (9)
  3. Declaration Lines (37)
  4. FindList_AfterUpdate (4)
  5. Form_AfterDelConfirm (5)
  6. Form_AfterUpdate (25)

Declaration Lines (37)

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

cmd_Add_Click (7)

38      
39       Private Sub cmd_Add_Click() 
40        '141001
41          If Not Me.NewRecord Then 
42             DoCmd.RunCommand acCmdRecordsGoToNew 
43          End If 
44       End Sub 
      Goto Top       Goto Form_fc_LISTS       Goto Index

cmd_Del_Click (9)

45      
46       Private Sub cmd_Del_Click() 
47        '141001
48          If MsgBox("Do you want to delete this record?", vbYesNo, "Delete Record?") = vbNo Then Exit Sub 
49          If Me.Dirty Then Me.Undo 
50          If Not Me.NewRecord Then 
51             DoCmd.RunCommand acCmdDeleteRecord 
52          End If 
53       End Sub 
      Goto Top       Goto Form_fc_LISTS       Goto Index

FindList_AfterUpdate (4)

54      
55       Private Sub FindList_AfterUpdate() 
56       Call FindRecordN(Me, "ListID") 
57       End Sub 
      Goto Top       Goto Form_fc_LISTS       Goto Index

Form_AfterDelConfirm (5)

58      
59       Private Sub Form_AfterDelConfirm(Status As Integer) 
60        '141004
61          Me.FindList.Requery 
62       End Sub 
      Goto Top       Goto Form_fc_LISTS       Goto Index

Form_AfterUpdate (25)

63      
64       Private Sub Form_AfterUpdate() 
65          Me.FindList.Requery 
66       End Sub 
67      
68        'Private Sub TypeID_NotInList( _
69        '   NewData As String, _
70        '   Response As Integer)
71        ''101010, 130815
72        '   On Error Resume Next
73        '
74        '   ' crystal (strive4peace)
75        '   Dim sTblNm As String _
76        '     , sFldNm As String _
77        '     , nTID As Long
78        '
79        '   sTblNm = "c_ListType"
80        '   sFldNm = "TypList"
81        '   nTID = 0
82        '
83        '   Response = GetResponse_NIL(NewData, sTblNm, sFldNm, nTID, "Email Address Type")
84        '
85        '
86        'End Sub
87      
      Goto Top       Goto Form_fc_LISTS       Goto Index

Form_fc_Lists_Members_sub (58)

PROCEDURES       Goto Top       Goto Form_fc_Lists_Members_sub       Goto Forms       Goto Index
  1. Declaration Lines (38)
  2. Form_BeforeUpdate (8)
  3. TyCID_NotInList (12)

Declaration Lines (38)

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

Form_BeforeUpdate (8)

39      
40      
41      
42      
43       Private Sub Form_BeforeUpdate(Cancel As Integer) 
44        '100928
45          Me.dtmEdit = Now 
46       End Sub 
      Goto Top       Goto Form_fc_Lists_Members_sub       Goto Index

TyCID_NotInList (12)

47      
48       Private Sub TyCID_NotInList(NewData As String, Response As Integer) 
49          MsgBox "TyCID_NotInList not defined for " & Me.Name _ 
50             , , "Write Code" 
51           ' ' TypeID_NIL NewData, Response, Me, Me.TID
52       End Sub 
53      
54        'Private Function SortMe()
55        '   Me.OrderBy = "nTtl"
56        '   Me.OrderByOn = True
57        'End Function
58      
      Goto Top       Goto Form_fc_Lists_Members_sub       Goto Index

Form_fc_Lists_PickMembers_sub (106)

PROCEDURES       Goto Top       Goto Form_fc_Lists_PickMembers_sub       Goto Forms       Goto Index
  1. Declaration Lines (35)
  2. Form_BeforeUpdate (5)
  3. HighlightBox_Click (4)
  4. PickMember (58)
  5. Used_MouseUp (4)

Declaration Lines (35)

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

PickMember (58)

36      
37       Private Function PickMember() 
38      
39          On Error GoTo Proc_Err 
40      
41          Dim s As String _ 
42             , nCID As Long _ 
43             , mListID As Long 
44      
45          nCID = Me.CID 
46          mListID = Me.ListID 
47      
48          If Me.Used Then 
49             s = "DELETE * FROM c_ListMbr WHERE MbrID = " & Nz(Me.MbrID, 0) 
50          Else 
51        '      s = "INSERT INTO c_ListMbr " _
52        '         & "( ListID, CID, IDadd )" _
53        '         & " SELECT " & Me.ListID _
54        '         & "," & Me.CID _
55        '         & "," & DBEngine(0)(0).Properties("DefaultUserID")
56             s = "INSERT INTO c_ListMbr " _ 
57                & "( ListID, CID )" _ 
58                & " SELECT " & Me.ListID _ 
59                & "," & Me.CID & ";" 
60          End If 
61      
62          rSql s 
63          DBEngine(0)(0).TableDefs.Refresh 
64          DoEvents 
65      
66          Me.Requery 
67      
68          Me.RecordsetClone.FindFirst "CID=" & nCID & " AND ListID=" & mListID 
69          Me.Bookmark = Me.RecordsetClone.Bookmark 
70      
71        'On Error Resume Next
72          With Me.Parent.f_List_Members_sub 
73             .Requery 
74             If Me.Used Then 
75                .Form.RecordsetClone.FindFirst _ 
76                   "CID=" & nCID & " AND ListID=" & mListID 
77                .Form.Bookmark = .Form.RecordsetClone.Bookmark 
78             End If 
79          End With 
80      
81          Me.Nam.SetFocus 
82       Proc_Exit: 
83          Exit Function 
84      
85       Proc_Err: 
86          MsgBox Err.Description, , _ 
87               "ERROR " & Err.Number _ 
88               & "   Used_Click" 
89      
90          Resume Proc_Exit 
91          Resume 
92      
93       End Function 
      Goto Top       Goto Form_fc_Lists_PickMembers_sub       Goto Index

Form_BeforeUpdate (5)

94      
95       Private Sub Form_BeforeUpdate(Cancel As Integer) 
96        '141005
97          Call FormBeforeUpdate(Me) 
98       End Sub 
      Goto Top       Goto Form_fc_Lists_PickMembers_sub       Goto Index

HighlightBox_Click (4)

99      
100      Private Sub HighlightBox_Click() 
101         Call PickMember 
102      End Sub 
      Goto Top       Goto Form_fc_Lists_PickMembers_sub       Goto Index

Used_MouseUp (4)

103     
104      Private Sub Used_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
105         Call PickMember 
106      End Sub 
      Goto Top       Goto Form_fc_Lists_PickMembers_sub       Goto Index

Form_fc_MbrLists_sub (154)

PROCEDURES       Goto Top       Goto Form_fc_MbrLists_sub       Goto Forms       Goto Index
  1. cmd_Add_Click (6)
  2. cmd_Del_Click (7)
  3. Declaration Lines (47)
  4. Form_BeforeUpdate (18)
  5. Initialize_ListID (5)
  6. ListID_BeforeUpdate (9)
  7. ListID_NotInList (50)
  8. MbrNote_AfterUpdate (5)
  9. TypIDmbr_NotInList (7)

Declaration Lines (47)

1        Option Compare Database 
2        Option Explicit 
3       
4         '=======================================================
5         ' fc_MbrLists_sub
6         ' CONTACT MANAGEMENT APPLET
7         '=======================================================
8         '=============================================
9         ' LICENSE NOTICE:
10        ' This code was originally written by Crystal Long (strive4peace)
11        ' strive4peace2010@yahoo.com
12        ' 130923
13        ' It is not to be altered or distributed,
14        ' except as part of a NON-COMMERCIAL application without written permission from Crystal Long
15        ' This License Notice must not be deleted.
16        '
17        ' Licensed under Creative Commons
18        ' License name: Attribution-NonCommercial-ShareAlike 3.0 Unported (CC BY-NC-SA 3.0)
19        ' This license lets you remix, tweak, and build upon your work non-commercially,
20        ' as long as I am credited and you license your new creations under the identical terms.
21        ' You can download and redistribute my work, translate, make remixes,
22        ' and create new applications based on my work.
23        ' All new work based on my work must carry the same license,
24        ' so any derivatives will also be non-commercial in nature.
25        ' legal code: http://creativecommons.org/licenses/by-nc-sa/3.0/legalcode
26        ' human-readable summary: http://creativecommons.org/licenses/by-nc-sa/3.0/
27        ' ~ Crystal
28        ' www.AccessMVP.com/strive4peace
29        ' ~ have an awesome day :)
30        '=============================================
31        '=======================================================
32        '
33        '101010
34        '
35        ' CALLS
36        '   RecordNew
37        '   RecordDelete
38        '   FormBeforeUpdate
39        '   GetResponse_NIL
40        '
41        'combos have --> DropMe, DropMeIfNull
42      
43       Dim mvar_ListID_old As Variant 
44        '111130
45       Dim mDirty As Boolean _ 
46          , mDirtyCustomer As Boolean _ 
47          , nUsrCatID As Long 
      Goto Top       Goto Form_fc_MbrLists_sub       Goto Index

Initialize_ListID (5)

48      
49       Public Sub Initialize_ListID() 
50          On Error Resume Next 
51          mvar_ListID_old = Null 
52       End Sub 
      Goto Top       Goto Form_fc_MbrLists_sub       Goto Index

cmd_Add_Click (6)

53      
54       Private Sub cmd_Add_Click() 
55        '101010
56          On Error Resume Next 
57          RecordNew Me, "ListID" 
58       End Sub 
      Goto Top       Goto Form_fc_MbrLists_sub       Goto Index

cmd_Del_Click (7)

59      
60       Private Sub cmd_Del_Click() 
61        '101010
62          On Error Resume Next 
63          RecordDelete Me, "MbrNote" 
64      
65       End Sub 
      Goto Top       Goto Form_fc_MbrLists_sub       Goto Index

Form_BeforeUpdate (18)

66      
67      
68      
69      
70       Private Sub Form_BeforeUpdate(Cancel As Integer) 
71           '--------------------- Form_BeforeUpdate TEMPLATE CODE
72            Dim mAnswer As Long 
73          If IsNull(Me.ListID) Then 
74             Me.Undo 
75             Cancel = True 
76             MsgBox "List is required.", vbOKOnly, "Undoing saves to the record" 
77             Me.ListID.SetFocus 
78             Exit Sub 
79          End If 
80      
81       Me.dtmEdit = Now 
82        '---------------------
83       End Sub 
      Goto Top       Goto Form_fc_MbrLists_sub       Goto Index

ListID_BeforeUpdate (9)

84      
85       Private Sub ListID_BeforeUpdate(Cancel As Integer) 
86          'store old ListID so that it can be changed if necessary
87        '   If IsNull(Me.ListID.OldValue) Then
88        '      mvar_ListID_old = Null
89        '   Else
90        '      mvar_ListID_old = Me.ListID.OldValue
91        '   End If
92       End Sub 
      Goto Top       Goto Form_fc_MbrLists_sub       Goto Index

ListID_NotInList (50)

93      
94       Private Sub ListID_NotInList( _ 
95          NewData As String, _ 
96          Response As Integer) 
97        '141004
98            ' crystal (strive4peace)
99      
100          'set up Error Handler
101         On Error GoTo Proc_Err 
102     
103          Dim s As String _ 
104            , mRecordID As Long _ 
105            , mText As String 
106     
107           ' Display message box asking if user wants to add a new item
108          s = "'" & NewData & "' is not in the current list. " _ 
109            & vbCrLf & vbCrLf _ 
110            & "Do you want to add it? " _ 
111            & vbCrLf _ 
112            & "(Check to ensure new entry is correct before proceeding)"   'Tony 
113     
114          Select Case MsgBox(s, vbYesNo + vbDefaultButton2 _ 
115            , "Add New Data") 
116     
117          Case vbYes 
118     
119            s = "INSERT INTO c_List (ListName) " _ 
120               & " SELECT '" & NewData & "';" 
121     
122             rSql s 
123     
124              'assume SQL to add was ok
125              Response = acDataErrAdded 
126     
127          Case Else 
128              Response = acDataErrContinue 
129          End Select 
130     
131      Proc_Exit: 
132         Exit Sub 
133     
134      Proc_Err: 
135         MsgBox Err.Description, , _ 
136              "ERROR " & Err.Number _ 
137              & "   ListID_NotInList : " & Me.Name 
138     
139         Resume Proc_Exit 
140         Resume 
141     
142      End Sub 
      Goto Top       Goto Form_fc_MbrLists_sub       Goto Index

MbrNote_AfterUpdate (5)

143     
144      Private Sub MbrNote_AfterUpdate() 
145      If IsNull(Me.ActiveControl) Then Exit Sub 
146         Me.ActiveControl = StrConv(Me.ActiveControl, 3)   'vbProperCase 
147      End Sub 
      Goto Top       Goto Form_fc_MbrLists_sub       Goto Index

TypIDmbr_NotInList (7)

148     
149      Private Sub TypIDmbr_NotInList(NewData As String, Response As Integer) 
150         MsgBox "TypIDmbr_NotInList not defined for " & Me.Name _ 
151            , , "Write Code" 
152     
153      End Sub 
154     
      Goto Top       Goto Form_fc_MbrLists_sub       Goto Index

Form_fc_MENU_CONTACT (1679)

PROCEDURES       Goto Top       Goto Form_fc_MENU_CONTACT       Goto Forms       Goto Index
  1. CatIDc_KeyDown (21)
  2. CatIDc_NotInList (50)
  3. chkProperCase_AfterUpdate (12)
  4. CID__AfterUpdate (5)
  5. CID__DblClick (16)
  6. CID__NotInList (8)
  7. cmd_Add_Click (34)
  8. cmd_Address_Click (4)
  9. cmd_Address_GotFocus (5)
  10. cmd_Admin_Click (5)
  11. cmd_Binoculars_Click (21)
  12. cmd_Clear_fltr_cCatID_Click (9)
  13. cmd_Close_Click (7)
  14. cmd_ContactCategories_Click (10)
  15. cmd_Del_Click (107)
  16. cmd_eMail_Click (8)
  17. cmd_Items_Click (5)
  18. cmd_Lists_Click (6)
  19. cmd_Next_Click (4)
  20. cmd_Phone_Click (11)
  21. cmd_Previous_Click (7)
  22. cmd_Rpt_Addresses_Click (5)
  23. cmd_Rpt_Avery5160_Click (5)
  24. cmd_Rpt_Birthdays_Click (5)
  25. cmd_Rpt_ClearCriteria_Click (17)
  26. cmd_Rpt_CompanyContacts_Click (5)
  27. cmd_Rpt_Contacts_Click (5)
  28. cmd_Rpt_MyCompanyInformation_Click (5)
  29. cmd_Rpt_Notes_Click (6)
  30. cmd_Rpt_Phone_2col_Click (5)
  31. cmdSwitch_Click (13)
  32. Declaration Lines (42)
  33. fc_eAdr_sub_Enter (5)
  34. fc_eAdr_sub_Exit (33)
  35. FilterMyFind (140)
  36. FindMyContact (95)
  37. fltr_cCatID_AfterUpdate (5)
  38. fnd_AdrID_AfterUpdate (90)
  39. fnd_Name_DblClick (6)
  40. Form_AfterDelConfirm (4)
  41. Form_AfterUpdate (11)
  42. Form_BeforeUpdate (68)
  43. Form_Current (47)
  44. Form_Load (67)
  45. Form_Open (53)
  46. Form_Unload (20)
  47. GotToAddress (9)
  48. ImageCalendar_Click (8)
  49. IsHuman_AfterUpdate (5)
  50. Label_emailCrystal_Click (7)
  51. Label_thanks_Click (7)
  52. Label_Tips_Click (6)
  53. lst_CompanyContacts_AfterUpdate (38)
  54. MainName_AfterUpdate (6)
  55. MoveToRecord (72)
  56. NameA_AfterUpdate (6)
  57. NameB_AfterUpdate (11)
  58. NickName_AfterUpdate (6)
  59. OpenFindPeople (11)
  60. OpenTheReport (210)
  61. RequeryMyStuff (20)
  62. runFindMyContact (77)
  63. SetCurrentStuff (37)
  64. ShowHuman (13)
  65. SynchronizeOtherForms (18)

Declaration Lines (42)

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

Form_Open (53)

43      
44      
45        '~~~~~~~~~~~~~~~~~~~~~~~~~~ Form_Open
46       Private Sub Form_Open(Cancel As Integer) 
47        '...141009
48           'CALLS
49           '  Custom_SetDefaultProperties
50           '  FoundBackEnd
51           '  Set_Property
52           '  FindMyContact
53           '
54          On Error GoTo Proc_Err 
55      
56          Dim nRecordID As Long 
57      
58          DoCmd.Maximize 
59          Call PlayWelcome 
60      
61           'make sure custom properties are defined
62          Call Custom_SetDefaultProperties("db") 
63      
64          If Not FoundBackEnd("c_KeepOpen") Then 
65             Cancel = True 
66             Exit Sub 
67          End If 
68      
69          mPassword = "invalid" 
70          Set_Property "local_Password", "invalid" 
71      
72           'set the form recordsource
73          With Me 
74             If Len(Trim(.OpenArgs)) > 0 And IsNumeric(.OpenArgs) Then 
75                 'CID got sent in the Open Arguments
76                nRecordID = CLng(.OpenArgs) 
77                Call FindMyContact("", CLng(.OpenArgs)) 
78             Else 
79                Call FindMyContact   'get last record looked at 
80             End If 
81          End With   'me 
82      
83       Proc_Exit: 
84          On Error Resume Next 
85          Exit Sub 
86      
87       Proc_Err: 
88          MsgBox Err.Description, , _ 
89               "ERROR " & Err.Number _ 
90               & "   Form_Open : " & Me.Name 
91      
92          Resume Proc_Exit 
93          Resume 
94      
95       End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

Form_Unload (20)

96      
97        '~~~~~~~~~~~~~~~~~~~~~~~~~~ Form_Unload
98       Private Sub Form_Unload(Cancel As Integer) 
99        '8-17-08
100         On Error GoTo Proc_Err 
101     
102         If Me.Dirty Then Me.Dirty = False 
103     
104      Proc_Exit: 
105         On Error Resume Next 
106         Exit Sub 
107     
108      Proc_Err: 
109       '   MsgBox Err.Description, , _
110               "ERROR " & Err.Number _
111               & "   people unload"
112     
113         Resume Proc_Exit 
114         Resume 
115      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

Form_Load (67)

116     
117     
118       '~~~~~~~~~~~~~~~~~~~~~~~~~~ Form_Load
119       '110327
120     
121     
122      Private Sub Form_Load() 
123       'modified 130831, 141008 FilterMyFind
124     
125          'CALLS
126          '  FilterMyFind
127     
128         On Error GoTo Proc_Err 
129     
130         Dim booConvert2Proper As Boolean 
131         Dim nUsrCatID As Long _ 
132            , sUserName As String   ' _ 
133            , nCID As Long 
134     
135         booConvert2Proper = Nz(Get_Property("local_ConvertToProper"), False) 
136     
137         With Me 
138            .chkProperCase = booConvert2Proper 
139            .Label_chkProperCase.FontBold = booConvert2Proper 
140         End With   'me 
141     
142         sUserName = Get_Property("local_UserName") 
143         Me.Label_UserName.Caption = sUserName 
144     
145          '----------------- NEW RECORD?
146          'nUsrCatID: 1=Admin, 2=Data -- get last modified record, 3=Report
147     
148          'nCID = Get_Property("local_CID") 'last modified record
149         nUsrCatID = Get_Property("local_UsrCatID") 
150     
151         Call FindMyContact      ' (, nCID) 
152     
153         If nUsrCatID = 3 Then       'report 
154            With Me.fnd_Name 
155               .SetFocus 
156               .Dropdown 
157            End With 
158         End If 
159     
160          'reset FIND combo and listbox rowsources
161         Call FilterMyFind 
162     
163          '141015
164         Me.WebBrowser2.Navigate "http://www.youtube.com/v/wVYnIM2oYkg&hl=en&fs=1&ap=%2526fmt%3D18" 
165     
166       '   Me.fraFind = 1
167       '   BoldMe Me, "fraFind", 5, 1
168       '   RowSourceFindVariable 1
169       '   SetFindFilters -1, 1, True
170     
171     
172      Proc_Exit: 
173         On Error Resume Next 
174         Exit Sub 
175     
176      Proc_Err: 
177         MsgBox Err.Description, , _ 
178              "ERROR " & Err.Number _ 
179              & "   Form_Load" 
180         Resume Proc_Exit 
181         Resume 
182      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

Form_Current (47)

183     
184     
185       '~~~~~~~~~~~~~~~~~~~~~~~~~~ Form_Current
186      Private Sub Form_Current() 
187       '6-2-07, 8-6-07, 101229, 130831, 141006 Notes
188         On Error GoTo Proc_Err 
189     
190         Dim nCID As Long _ 
191            , nTID As Long 
192     
193         nTID = 100 
194     
195         With Me 
196            If .NewRecord Then 
197               Call ShowHuman(True) 
198            Else 
199               Call ShowHuman(Nz(.IsHuman, True)) 
200            End If 
201     
202            nCID = Nz(.CID, -99) 
203     
204            If Not .NewRecord Then 
205               Call Set_Property("local_CID", nCID) 
206               Call Set_Property("local_Contact", .ContactName & " ") 
207            End If 
208     
209             '-- Notes page
210            .txtCountNotesAll.Requery 
211            .txtCountNotesDirect.Requery 
212            .fc_Notes_sub.Form.Requery 
213     
214         End With   'me 
215         Call SetCurrentStuff(nTID, nCID) 
216     
217     
218      Proc_Exit: 
219         On Error Resume Next 
220         Exit Sub 
221     
222      Proc_Err: 
223         MsgBox Err.Description, , _ 
224              "ERROR " & Err.Number _ 
225              & "   Form_Current : " & Me.Name 
226     
227         Resume Proc_Exit 
228         Resume 
229      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

SetCurrentStuff (37)

230     
231     
232      Private Sub SetCurrentStuff( _ 
233         pnTID As Long _ 
234         , pnCID As Long) 
235       '...130920, 140416
236     
237          'CALLS
238          '  SetControl_RowSource
239     
240         On Error GoTo Proc_Err 
241     
242         Dim sWhere As String 
243     
244         sWhere = "c.[CID_] = " & pnCID 
245     
246          'company contacts
247         Call SetControl_RowSource(Me.lst_CompanyContacts, sWhere, True) 
248     
249         sWhere = "qCart.CID = " & pnCID 
250          'addresses
251         Call SetControl_RowSource(Me.fnd_AdrID, sWhere, True) 
252     
253     
254     
255      Proc_Exit: 
256         On Error Resume Next 
257         Exit Sub 
258     
259      Proc_Err: 
260         MsgBox Err.Description, , _ 
261              "ERROR " & Err.Number _ 
262              & "   SetCurrentStuff : " & Me.Name 
263     
264         Resume Proc_Exit 
265         Resume 
266      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

OpenTheReport (210)

267     
268     
269      Private Sub OpenTheReport( _ 
270         pReportName As String _ 
271         , Optional psDateField As String = "") 
272       '141007
273         On Error GoTo Proc_Err 
274     
275         Dim vWhere As Variant _ 
276            , vFriendly As Variant 
277     
278         vWhere = Null 
279         vFriendly = Null 
280     
281          '---------- Main Category cCatIDc
282         With Me.cCatIDc_Rpt 
283            If Not IsNull(.Value) Then 
284               vWhere = (vWhere + " AND ") _ 
285                  & "([cCatIDc]=" & .Value & ")" 
286               vFriendly = (vFriendly + ", ") _ 
287                  & .Controls(0).Caption & .Column(1) 
288            End If 
289         End With 
290          '---------- Marked Category cCatID
291         With Me.cCatID_Rpt 
292            If Not IsNull(.Value) Then 
293               vWhere = (vWhere + " AND ") _ 
294                  & "((CID IN (" _ 
295                  & "SELECT CID FROM c_CtcCat WHERE cCatID=" & .Value & ")" _ 
296                  & " OR " _ 
297                  & "([CID_] IN (" _ 
298                  & "SELECT CID FROM c_CtcCat WHERE cCatID=" & .Value & "))" 
299               vFriendly = (vFriendly + ", ") _ 
300                  & .Controls(0).Caption & .Column(1) 
301            End If 
302         End With 
303          '---------- ListID
304         With Me.ListID_Rpt 
305            If Not IsNull(.Value) Then 
306               vWhere = (vWhere + " AND ") _ 
307                  & "(CID IN (" _ 
308                  & "SELECT CID FROM c_ListMbr WHERE ListID=" & .Value & "))" 
309               vFriendly = (vFriendly + ", ") _ 
310                  & .Controls(0).Caption & .Column(1) 
311            End If 
312         End With 
313     
314          '---------- Contact CID
315         With Me.CID_Rpt 
316            If Not IsNull(.Value) Then 
317               vWhere = (vWhere + " AND ") _ 
318                  & "(CID =" & .Value & ")" 
319               vFriendly = (vFriendly + ", ") _ 
320                  & .Controls(0).Caption & .Column(1) 
321            End If 
322         End With 
323          '---------- Company CID_
324         With Me.CID__Rpt 
325            If Not IsNull(.Value) Then 
326               vWhere = (vWhere + " AND ") _ 
327                  & "([CID_] =" & .Value & ")" 
328               vFriendly = (vFriendly + ", ") _ 
329                  & .Controls(0).Caption & .Column(1) 
330            End If 
331         End With 
332          '---------- City
333         With Me.City_Rpt 
334            If Not IsNull(.Value) Then 
335               vWhere = (vWhere + " AND ") _ 
336                  & "(CID IN (" _ 
337                  & "SELECT CID FROM c_Address WHERE City=""" & .Value & """))" 
338               vFriendly = (vFriendly + ", ") _ 
339                  & .Controls(0).Caption & .Value 
340            End If 
341         End With 
342          '---------- State
343         With Me.St_Rpt 
344            If Not IsNull(.Value) Then 
345               vWhere = (vWhere + " AND ") _ 
346                  & "(CID IN (" _ 
347                  & "SELECT CID FROM c_Address WHERE St=""" & .Value & """))" 
348               vFriendly = (vFriendly + ", ") _ 
349                  & .Controls(0).Caption & .Value 
350            End If 
351         End With 
352          '---------- Zip
353         With Me.Zip_Rpt 
354            If Not IsNull(.Value) Then 
355               vWhere = (vWhere + " AND ") _ 
356                  & "(CID IN (" _ 
357                  & "SELECT CID FROM c_Address WHERE Zip=""" & .Value & """))" 
358               vFriendly = (vFriendly + ", ") _ 
359                  & .Controls(0).Caption & .Value 
360            End If 
361         End With 
362          '---------- Ctry
363         With Me.Ctry_Rpt 
364            If Not IsNull(.Value) Then 
365               vWhere = (vWhere + " AND ") _ 
366                  & "(CID IN (" _ 
367                  & "SELECT CID FROM c_Address WHERE Ctry=""" & .Value & """))" 
368               vFriendly = (vFriendly + ", ") _ 
369                  & .Controls(0).Caption & .Value 
370            End If 
371         End With 
372     
373          '---------- PATTERNS
374          '---------- Name
375         With Me.Name_Pattern_Rpt 
376            If Not IsNull(.Value) Then 
377               vWhere = (vWhere + " AND ") _ 
378                  & "(CID IN (" _ 
379                  & "SELECT CID FROM qContact WHERE " _ 
380                  & " ((Contact Like ""*" & .Value & "*"")" _ 
381                  & " OR (Company Like ""*" & .Value & "*""))" _ 
382                  & "))" 
383     
384               vFriendly = (vFriendly + ", ") _ 
385                  & .Controls(0).Caption & " Like " & .Value 
386            End If 
387         End With 
388     
389          '---------- Address
390         With Me.Address_Pattern_Rpt 
391            If Not IsNull(.Value) Then 
392               vWhere = (vWhere + " AND ") _ 
393                  & "(CID IN (" _ 
394                  & "SELECT CID FROM qAddress WHERE " _ 
395                  & " (FullAddress Like ""*" & .Value & "*"")" _ 
396                  & "))" 
397     
398               vFriendly = (vFriendly + ", ") _ 
399                  & .Controls(0).Caption & " Like " & .Value 
400            End If 
401         End With 
402     
403          '---------- Zip
404         With Me.Zip_Pattern_Rpt 
405            If Not IsNull(.Value) Then 
406               vWhere = (vWhere + " AND ") _ 
407                  & "(CID IN (" _ 
408                  & "SELECT CID FROM c_Address WHERE " _ 
409                  & " (Zip Like ""*" & .Value & "*"")" _ 
410                  & " OR (Zip2 Like ""*" & .Value & "*"")" _ 
411                  & "))" 
412     
413               vFriendly = (vFriendly + ", ") _ 
414                  & .Controls(0).Caption & " Like " & .Value 
415            End If 
416         End With 
417     
418          '---------- Phone
419         With Me.Phone_Pattern_Rpt 
420            If Not IsNull(.Value) Then 
421               vWhere = (vWhere + " AND ") _ 
422                  & "(CID IN (" _ 
423                  & "SELECT CID FROM c_Phone WHERE " _ 
424                  & " (Phone Like ""*" & .Value & "*"")" _ 
425                  & "))" 
426     
427               vFriendly = (vFriendly + ", ") _ 
428                  & .Controls(0).Caption & " Like " & .Value 
429            End If 
430         End With 
431     
432          '---------- Dates
433         If Len(psDateField) > 0 Then 
434            With Me.f_GetDateRange.Form 
435     
436               If Not IsNull(.Date1.Value) Then 
437                  vWhere = (vWhere + " AND ") _ 
438                     & "DateValue(" & psDateField & ") >= DateValue(""" & .Date1.Value & """)" 
439                  vFriendly = (vFriendly + ", ") _ 
440                     & psDateField & " >= " & .Date1.Value 
441               End If 
442               If Not IsNull(.Date2.Value) Then 
443                  vWhere = (vWhere + " AND ") _ 
444                     & "DateValue(" & psDateField & ") <= DateValue(""" & .Date2.Value & """)" 
445                  vFriendly = (vFriendly + ", ") _ 
446                     & psDateField & " <= " & .Date1.Value 
447               End If 
448            End With 
449         End If 
450     
451     
452      Debug.Print vWhere 
453     
454         Call ShowPleaseWait 
455     
456       '   On Error Resume Next
457         DoCmd.OpenReport pReportName, acViewPreview, , vWhere, , Nz(vFriendly, "") 
458     
459          'Call ClosePleaseWait
460     
461      Proc_Exit: 
462         On Error Resume Next 
463         Exit Sub 
464     
465      Proc_Err: 
466         If Err.Number = 2501 Then   're port has no data 
467            Resume Next 
468         End If 
469         MsgBox Err.Description, , _ 
470              "ERROR " & Err.Number _ 
471              & "   OpenTheReport : " & Me.Name 
472     
473         Resume Proc_Exit 
474         Resume 
475     
476      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Rpt_ClearCriteria_Click (17)

477     
478      Private Sub cmd_Rpt_ClearCriteria_Click() 
479       '141007
480         Me.cCatIDc_Rpt = Null 
481         Me.cCatID_Rpt = Null 
482         Me.ListID_Rpt = Null 
483         Me.CID_Rpt = Null 
484         Me.CID__Rpt = Null 
485         Me.City_Rpt = Null 
486         Me.St_Rpt = Null 
487         Me.Zip_Rpt = Null 
488         Me.Ctry_Rpt = Null 
489         Me.Name_Pattern_Rpt = Null 
490         Me.Address_Pattern_Rpt = Null 
491         Me.Zip_Pattern_Rpt = Null 
492         Me.Phone_Pattern_Rpt = Null 
493      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Rpt_MyCompanyInformation_Click (5)

494     
495      Private Sub cmd_Rpt_MyCompanyInformation_Click() 
496       '141007
497         DoCmd.OpenReport "r_MyCompanyInformation", acViewPreview 
498      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Rpt_Addresses_Click (5)

499     
500      Private Sub cmd_Rpt_Addresses_Click() 
501       '141007
502         Call OpenTheReport("r_ADDRESSES") 
503      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Rpt_Avery5160_Click (5)

504     
505      Private Sub cmd_Rpt_Avery5160_Click() 
506       '141007
507         Call OpenTheReport("rc_Avery5160") 
508      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Rpt_Birthdays_Click (5)

509     
510      Private Sub cmd_Rpt_Birthdays_Click() 
511       '141007
512         Call OpenTheReport("r_BIRTHDAYS") ', "BDay" 
513      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Rpt_Contacts_Click (5)

514     
515      Private Sub cmd_Rpt_Contacts_Click() 
516       '141007
517         Call OpenTheReport("r_CONTACTS") 
518      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Rpt_CompanyContacts_Click (5)

519     
520      Private Sub cmd_Rpt_CompanyContacts_Click() 
521       '141007
522         Call OpenTheReport("r_COMPANY_Contacts") 
523      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Rpt_Notes_Click (6)

524     
525     
526      Private Sub cmd_Rpt_Notes_Click() 
527       '141007
528         Call OpenTheReport("r_Notes", "dat") 
529      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Rpt_Phone_2col_Click (5)

530     
531      Private Sub cmd_Rpt_Phone_2col_Click() 
532       '141007
533         Call OpenTheReport("r_PHONES_2col") 
534      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Add_Click (34)

535     
536     
537     
538     
539     
540      Private Sub cmd_Add_Click() 
541       '140422
542          'CALLS
543          '  FindMyContact
544          'OPENS
545          '  fc_Popup_AddContact
546          'READS
547          '  local_CID
548     
549         Dim nCIDcurrent As Long _ 
550            , nCIDnew As Long 
551     
552         If Me.Dirty Then Me.Dirty = False 
553         If Me.NewRecord Then 
554            nCIDcurrent = Get_Property("local_CID") 
555         Else 
556            nCIDcurrent = Me.CID 
557         End If 
558     
559         DoCmd.OpenForm "fc_Popup_AddContact", , , , , acDialog 
560     
561       'Stop
562     
563         nCIDnew = Get_Property("local_CID") 
564         If nCIDnew <> nCIDcurrent Then 
565            Call FindMyContact(, nCIDnew) 
566         End If 
567     
568      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Admin_Click (5)

569     
570      Private Sub cmd_Admin_Click() 
571       '140630
572         DoCmd.OpenForm "f_Admin", , , , , , "Anything" 
573      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_ContactCategories_Click (10)

574     
575      Private Sub cmd_ContactCategories_Click() 
576       '141006
577         DoCmd.OpenTable "c_Category" 
578         MsgBox "Remember to close this table when done." _ 
579            & vbCrLf & "F9 to requery combo based on this information when it is active" _ 
580            & vbCrLf & "Shift-F9 to refresh open DataSheet when it is active" _ 
581            & vbCrLf & vbCrLf & "Form Categories will refresh when record is changed" _ 
582            , , "Edit Contact Categories" 
583      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Items_Click (5)

584     
585      Private Sub cmd_Items_Click() 
586       '140701
587         DoCmd.OpenForm "f_Itms" 
588      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Lists_Click (6)

589     
590      Private Sub cmd_Lists_Click() 
591       '141004
592         DoCmd.OpenForm "fc_LISTS", , , , , acDialog 
593         Me.fc_MbrLists_sub.Form.ListID.Requery 
594      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

GotToAddress (9)

595     
596     
597      Public Function GotToAddress() 
598       '110622, 140416
599         With Me.fc_Addresses_sub 
600            .SetFocus 
601            .Form.Addr1.SetFocus 
602         End With 
603      End Function 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Address_Click (4)

604     
605      Private Sub cmd_Address_Click() 
606         GotToAddress 
607      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Address_GotFocus (5)

608     
609      Private Sub cmd_Address_GotFocus() 
610       '101222
611         GotToAddress 
612      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

CatIDc_KeyDown (21)

613     
614     
615     
616      Private Sub CatIDc_KeyDown(KeyCode As Integer, Shift As Integer) 
617       '101222, 110327 cancel if garbage typed so NoInList does its job
618     
619         On Error GoTo Proc_Err 
620         If KeyCode = 9 Then   'tab 
621            Me.fc_Addresses_sub.SetFocus 
622            Me.fc_Addresses_sub.Form.Addr1.SetFocus 
623     
624         End If 
625      Proc_Exit: 
626         On Error Resume Next 
627         Exit Sub 
628      Proc_Err: 
629         DoCmd.CancelEvent 
630          'Me.CatID.SetFocus
631         Resume Proc_Exit 
632         Resume 
633      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

CatIDc_NotInList (50)

634     
635      Private Sub CatIDc_NotInList( _ 
636         NewData As String, _ 
637         Response As Integer) 
638       '141007
639           ' crystal (strive4peace)
640     
641          'set up Error Handler
642         On Error GoTo Proc_Err 
643     
644          Dim s As String _ 
645            , mRecordID As Long _ 
646            , mText As String 
647     
648           ' Display message box asking if user wants to add a new item
649          s = "'" & NewData & "' is not in the current list. " _ 
650            & vbCrLf & vbCrLf _ 
651            & "Do you want to add it? " _ 
652            & vbCrLf _ 
653            & "(Check to ensure new entry is correct before proceeding)"   'Tony 
654     
655          Select Case MsgBox(s, vbYesNo + vbDefaultButton2 _ 
656            , "Add New Data") 
657     
658          Case vbYes 
659     
660            s = "INSERT INTO c_Category (cCategory) " _ 
661               & " SELECT '" & NewData & "';" 
662     
663             rSql s 
664     
665              'assume SQL to add was ok
666              Response = acDataErrAdded 
667     
668          Case Else 
669              Response = acDataErrContinue 
670          End Select 
671     
672      Proc_Exit: 
673         Exit Sub 
674     
675      Proc_Err: 
676         MsgBox Err.Description, , _ 
677              "ERROR " & Err.Number _ 
678              & "   CatIDc_NotInList : " & Me.Name 
679     
680         Resume Proc_Exit 
681         Resume 
682     
683      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

chkProperCase_AfterUpdate (12)

684     
685       'Private Sub cmdEvents_Click()
686       '   If Me.Dirty Then Me.Dirty = False
687       '   DoCmd.OpenForm "ft_Events"
688       '   DoCmd.Close acForm, Me.Name, acSaveNo
689       'End Sub
690     
691      Private Sub chkProperCase_AfterUpdate() 
692       '3-18-09
693         On Error Resume Next 
694         ToggleProperCase Me.ActiveControl 
695      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

CID__NotInList (8)

696     
697     
698      Private Sub CID__NotInList(NewData As String, Response As Integer) 
699     
700         MsgBox "NEED CODE" 
701     
702     
703      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Close_Click (7)

704     
705      Private Sub cmd_Close_Click() 
706       '101007
707         On Error Resume Next 
708         If Me.Dirty Then Me.Dirty = False 
709         DoCmd.Close acForm, Me.Name, acSaveNo 
710      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_eMail_Click (8)

711     
712      Private Sub cmd_eMail_Click() 
713       '101222, 140416
714         With Me.fc_eAdr_sub 
715            .SetFocus 
716            .Form.eAdr.SetFocus 
717         End With 
718      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Phone_Click (11)

719     
720     
721     
722     
723      Private Sub cmd_Phone_Click() 
724       '101222, 140416
725         With Me.fc_Phones_sub 
726            .SetFocus 
727            .Form.Phone.SetFocus 
728         End With 
729      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

fc_eAdr_sub_Enter (5)

730     
731     
732      Private Sub fc_eAdr_sub_Enter() 
733       '=TurnOnNewRecord(ActiveControl.Form,True)
734      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

fc_eAdr_sub_Exit (33)

735     
736      Private Sub fc_eAdr_sub_Exit(Cancel As Integer) 
737       '=TurnOnNewRecord(ActiveControl.Form,False)
738      End Sub 
739     
740       'Private Sub filterTID_AfterUpdate()
741       ''3-20-09
742       '   On Error Resume Next
743       '   SetFindFilters Me.filterTID, Me.fraFind, False
744       'End Sub
745     
746     
747       'Private Sub fnd_Listbox_AfterUpdate()
748       ''130831
749       '   On Error GoTo Proc_Err
750       '   If IsNull(Me.ActiveControl) Then Exit Sub
751       '
752       '   Dim nRecordID As Long
753       '   nRecordID = Me.ActiveControl
754       '   Me.ActiveControl.Value = Null
755       '   Call FindMyContact(, nRecordID)
756       '
757       'Proc_Exit:
758       '   On Error Resume Next
759       '   Exit Sub
760       '
761       'Proc_Err:
762       '   MsgBox Err.Description, , _
763       '        "ERROR " & Err.Number _
764       '        & "  fnd_Listbox_AfterUpdate  : " & Me.Name
765       '   Resume Proc_Exit
766       '   Resume
767       'End Sub
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

ImageCalendar_Click (8)

768     
769     
770     
771      Private Sub ImageCalendar_Click() 
772       '141007
773         Me.f_GetDateRange.SetFocus 
774         Call cmd_Rpt_Notes_Click 
775      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

Label_thanks_Click (7)

776     
777     
778     
779      Private Sub Label_thanks_Click() 
780       '141012
781         Application.FollowHyperlink "http://www.MsAccessGurus.com/Contacts.htm" 
782      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

Label_Tips_Click (6)

783     
784      Private Sub Label_Tips_Click() 
785       '141012
786         Application.FollowHyperlink "http://www.MsAccessGurus.com/freetips.html" 
787     
788      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

lst_CompanyContacts_AfterUpdate (38)

789     
790      Private Sub lst_CompanyContacts_AfterUpdate() 
791       '140512
792          'CALLS
793          '  FindMyContact
794         Dim nRecordID As Long 
795         With Me.lst_CompanyContacts 
796            If IsNull(.Value) Then Exit Sub 
797            nRecordID = .Value 
798         End With 
799         Call FindMyContact(, nRecordID) 
800     
801       ''130901, 131010, 140420
802       '
803       '   'CALLS
804       '   '  runFindMyContact
805       '   '  ClipBoard_SetText
806       '
807       '   On Error GoTo Proc_Err
808       '   Dim sPhone As String
809       '
810       '   sPhone = runFindMyContact("P")
811       '   If sPhone <> "" Then
812       '      Call ClipBoard_SetText(sPhone)
813       '   End If
814       '
815     
816      Proc_Exit: 
817         On Error Resume Next 
818         Exit Sub 
819     
820      Proc_Err: 
821         MsgBox Err.Description, , _ 
822              "ERROR " & Err.Number _ 
823              & "  lst_CompanyContacts_AfterUpdate  : " & Me.Name 
824         Resume Proc_Exit 
825         Resume 
826      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

runFindMyContact (77)

827     
828      Private Function runFindMyContact(Optional pWhich As String = "") As String 
829     
830       '140420
831          'CALLS
832          '  FindMyContact
833          '  FindRecordN
834     
835          'Called By
836          '  fnd_Adr_AfterUpdate
837          '  fnd_Name_AfterUpdate
838          '  lst_CompanyContacts_AfterUpdate
839     
840         On Error GoTo Proc_Err 
841         runFindMyContact = "" 
842         If IsNull(Me.ActiveControl) Then Exit Function 
843     
844         Dim nCID  As Long _ 
845            , nOtherID As Long _ 
846            , sSubFormControlname As String _ 
847            , sPKsubFieldname As String _ 
848            , sFirstcontrolname As String _ 
849            , sValueControlname As String 
850     
851         With Me.ActiveControl 
852            nCID = .Value 
853            If pWhich <> "" Then 
854               Select Case pWhich 
855               Case "A" 
856                  sSubFormControlname = "fc_Addresses_sub" 
857                  sPKsubFieldname = "AdrID" 
858                  sFirstcontrolname = "Addr1" 
859                  sValueControlname = "Addr1" 
860               Case "P" 
861                  sSubFormControlname = "fc_Phones_sub" 
862                  sPKsubFieldname = "PhoneID" 
863                  sFirstcontrolname = "Phone" 
864                  sValueControlname = "Phone" 
865               End Select 
866               If .Column(1) <> "" Then 
867                  nOtherID = .Column(1) 
868               Else 
869                  nOtherID = -99 
870               End If 
871            End If 
872            .Value = Null 
873         End With 
874     
875         Call FindMyContact("", nCID) 
876     
877         If pWhich <> "" And nOtherID <> -99 Then 
878            Me(sSubFormControlname).SetFocus 
879            Call FindRecordN(Me(sSubFormControlname).Form _ 
880               , sPKsubFieldname _ 
881               , sFirstcontrolname _ 
882               , nOtherID _ 
883               ) 
884            If sValueControlname <> "" Then 
885               With Me(sSubFormControlname).Controls(sValueControlname) 
886                  If Not IsNull(.Value) Then 
887                     runFindMyContact = .Value 
888                  End If 
889               End With 
890            End If 
891         End If 
892     
893      Proc_Exit: 
894         On Error Resume Next 
895         Exit Function 
896     
897      Proc_Err: 
898         MsgBox Err.Description, , _ 
899              "ERROR " & Err.Number _ 
900              & "  runFindMyContact  : " & Me.Name 
901         Resume Proc_Exit 
902         Resume 
903      End Function 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

FindMyContact (95)

904     
905      Public Sub FindMyContact( _ 
906         Optional ByVal psWhere As String = "" _ 
907         , Optional pnCID As Long = -99 _ 
908         , Optional psControlFocus As String = "IsACTIV" _ 
909         ) 
910       '130316, 130831, 1002
911          'CALLS
912          '  GetSQL_WHERE
913          '  Form_Current
914          '
915          'Called By
916          '  runFindMyContact
917     
918          'FORM TAG contains SQL for the Recordset
919          'if no criteria specified, local_CID will be used
920     
921         Dim sSQL As String _ 
922            , sSqlOrig As String _ 
923            , nCID As Long _ 
924            , sWhere As String 
925     
926         Dim db As DAO.Database _ 
927             , rs As DAO.Recordset 
928     
929         On Error Resume Next 
930         If Me.Dirty Then Me.Dirty = False 
931         On Error GoTo Proc_Err 
932       '   db.TableDefs.Refresh
933         DoEvents 
934         DoEvents 
935         DoEvents 
936         Set db = CurrentDb 
937     
938         nCID = 0 
939         If pnCID > 0 Then   'ASSUMPTION: real CIDs will be >0 
940            nCID = pnCID 
941         Else 
942            nCID = Get_Property("local_CID") 
943         End If 
944     
945         With Me   'SQL is stored in Tag of control 
946            sSqlOrig = .Tag 
947         End With   'me 
948     
949         If Len(psWhere) > 0 Then 
950            sSQL = GetSQL_WHERE(sSqlOrig, psWhere) 
951         Else 
952            sWhere = "C.CID =" & nCID 
953            sSQL = GetSQL_WHERE(sSqlOrig, sWhere) 
954         End If 
955     
956          'see if the recordset has something
957       'Debug.Print sSQL
958         Set rs = db.OpenRecordset(sSQL, dbOpenDynaset) 
959     
960         If rs.EOF Then 
961             'if nothing in the recordset, get the record added
962            If Not nCID > 0 Then 
963               nCID = Nz(DMax("CID", "c_Contact"), 0) 
964            End If 
965            sWhere = "C.CID =" & nCID 
966            sSQL = GetSQL_WHERE(sSqlOrig, sWhere) 
967       'Debug.Print sSQL
968         End If 
969         rs.Close 
970         Set rs = Nothing 
971         Set db = Nothing 
972         Me.RecordSource = sSQL 
973     
974         If Len(psControlFocus) > 0 Then 
975            Me.Controls(psControlFocus).SetFocus 
976         End If 
977     
978       '   Call Form_Current
979     
980          'On Error Resume Next
981     
982     
983      Proc_Exit: 
984         On Error Resume Next 
985         If Not rs Is Nothing Then 
986            rs.Close 
987            Set rs = Nothing 
988         End If 
989         Set db = Nothing 
990         Exit Sub 
991     
992      Proc_Err: 
993         MsgBox Err.Description, , _ 
994              "ERROR " & Err.Number _ 
995              & "  FindMyContact  : " & Me.Name 
996         Resume Proc_Exit 
997         Resume 
998      End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

OpenFindPeople (11)

999     
1,000   
1,001     '~~~~~~~~~~~~~~~~~~~~~~~~~~ OpenFindPeople
1,002    Private Function OpenFindPeople() 
1,003     '5-26-07
1,004       On Error Resume Next 
1,005       If Me.Dirty Then 
1,006          Form_BeforeUpdate False 
1,007       End If 
1,008       DoCmd.OpenForm "fc_Find" 
1,009    End Function 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

RequeryMyStuff (20)

1,010   
1,011    Private Function RequeryMyStuff() 
1,012     '3-16-9, 110519, 140928
1,013       On Error Resume Next 
1,014       If Me.Dirty Then Me.Dirty = False 
1,015       DoEvents 
1,016       With Me 
1,017          .Refresh 
1,018          .fnd_Name.Requery 
1,019          .fnd_Adr.Requery 
1,020     '      .fnd_Listbox.Requery
1,021          .CID_.Requery 
1,022          .lst_CompanyContacts.Requery 
1,023     '      .fnd_Listbox.Requery
1,024       End With 
1,025   
1,026   
1,027     '   Me.FindVariable.Requery
1,028     '   Me.fnd_Listbox.RowSource = Me.fnd_Name.RowSource
1,029    End Function 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

SynchronizeOtherForms (18)

1,030   
1,031    Private Sub SynchronizeOtherForms()   ' ----- not cuttently being called 
1,032     'hook into other forms
1,033     'strive4peace
1,034   
1,035     '   If Not Me.NewRecord Then
1,036     '      If CurrentProject.AllForms("f_Invoices").IsLoaded Then
1,037     '         With Forms!f_Invoices!CID
1,038     '            If IsNull(.Value) Then
1,039     '               .Value = Me.CID
1,040     '                  DoEvents
1,041     '            End If
1,042     '         End With
1,043     '      End If 'IsLoaded
1,044     '   End If 'NewRecord
1,045     '
1,046   
1,047    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

IsHuman_AfterUpdate (5)

1,048    Private Sub IsHuman_AfterUpdate() 
1,049     '130831
1,050       Call ShowHuman(Nz(Me.IsHuman, True)) 
1,051   
1,052    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

ShowHuman (13)

1,053   
1,054    Private Sub ShowHuman(Optional pBooHuman As Boolean = True) 
1,055     '130831
1,056       If pBooHuman Then 
1,057          Me.Label_MainName.Caption = "Last name" 
1,058     '      Me.Label_NameA.Caption = "First name"
1,059       Else 
1,060          Me.Label_MainName.Caption = "Company" 
1,061     '      Me.Label_NameA.Caption = "Division"
1,062       End If 
1,063   
1,064       Call ShowHideControls(Me, pBooHuman, "~Human~", "MainName") 
1,065    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

Label_emailCrystal_Click (7)

1,066   
1,067    Private Sub Label_emailCrystal_Click() 
1,068     '130813
1,069       Application.FollowHyperlink _ 
1,070          "mailto: strive4peace2010@yahoo.com?subject=Contact Template comment" 
1,071    End Sub 
1,072     '
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Del_Click (107)

1,073   
1,074     '~~~~~~~~~~~~~~~~~~~~~~~~~~ cmd_Del_Click
1,075    Private Sub cmd_Del_Click() 
1,076     '10-1-08, 130813
1,077       On Error GoTo Proc_Err 
1,078     '
1,079     '   Dim db As DAO.Database _
1,080     '      , r As DAO.Recordset
1,081   
1,082       Dim s As String _ 
1,083          , nCID As Long 
1,084   
1,085     '   Dim mCount As Long _
1,086           , mTable As String _
1,087           , mFldname As String _
1,088           , mMsg As String _
1,089           , varList As Variant
1,090   
1,091       If Me.Dirty Then Me.Undo 
1,092   
1,093       If Me.NewRecord Then 
1,094     '      MsgBox "You are not on a current record", , "Cannot delete"
1,095          Exit Sub 
1,096       End If 
1,097   
1,098     '   mTable = "c_Contacts"
1,099     '   mFldname = "CID"
1,100       nCID = Nz(Me.CID, 0) 
1,101   
1,102        'this shouldn't happen
1,103       If nCID = 0 Then 
1,104          MsgBox "You are not on a valid record", , "Cannot delete" 
1,105          Exit Sub 
1,106       End If 
1,107   
1,108       If MsgBox("Do you want to delete " _ 
1,109          & (Me.NameA + " ") & Me.MainName _ 
1,110          , vbYesNo _ 
1,111          , "Permanently delete this record?") = vbNo Then Exit Sub 
1,112   
1,113       s = "DELETE t.* FROM Customers t WHERE CID = " & nCID _ 
1,114          & ";" 
1,115       rSql s 
1,116       s = "DELETE t.* FROM Employees t WHERE CID = " & nCID _ 
1,117          & ";" 
1,118       rSql s 
1,119       s = "DELETE t.* FROM Vendors t WHERE CID = " & nCID _ 
1,120          & ";" 
1,121       rSql s 
1,122       s = "DELETE t.* FROM Prospects t WHERE CID = " & nCID _ 
1,123          & ";" 
1,124       rSql s 
1,125       s = "DELETE t.* FROM Suppliers t WHERE CID = " & nCID _ 
1,126          & ";" 
1,127       rSql s 
1,128       s = "DELETE t.* FROM Shippers t WHERE CID = " & nCID _ 
1,129          & ";" 
1,130       rSql s 
1,131       s = "DELETE t.* FROM Contractors t WHERE CID = " & nCID _ 
1,132          & ";" 
1,133       rSql s 
1,134       s = "DELETE t.* FROM Distributors t WHERE CID = " & nCID _ 
1,135          & ";" 
1,136       rSql s 
1,137       s = "DELETE t.* FROM Manufacturers t WHERE CID = " & nCID _ 
1,138          & ";" 
1,139       rSql s 
1,140       s = "DELETE t.* FROM OEMs t WHERE CID = " & nCID _ 
1,141          & ";" 
1,142       rSql s 
1,143       s = "DELETE t.* FROM c_CtcCat t WHERE CID = " & nCID _ 
1,144          & ";" 
1,145       rSql s 
1,146       Call EndTime   'get database to refresh 
1,147   
1,148       DoEvents 
1,149   
1,150       s = "DELETE t.* FROM c_Contact t WHERE CID = " & nCID _ 
1,151          & ";" 
1,152   
1,153       If rSql(s) < 1 Then 
1,154          MsgBox "Cannot delete, there are Related Records", , "Cannot delete" 
1,155          GoTo Proc_Exit 
1,156       End If 
1,157   
1,158        '----------------------------------------- future: delete related records
1,159   
1,160       On Error Resume Next 
1,161       Me.Requery 
1,162   
1,163       With Me.fnd_Name 
1,164          .Requery 
1,165          .SetFocus 
1,166          .Dropdown 
1,167       End With 
1,168   
1,169    Proc_Exit: 
1,170       Exit Sub 
1,171   
1,172    Proc_Err: 
1,173       MsgBox Err.Description, , _ 
1,174            "ERROR " & Err.Number _ 
1,175            & "   cmd_Del_Click" 
1,176   
1,177       Resume Proc_Exit 
1,178       Resume 
1,179    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmdSwitch_Click (13)

1,180   
1,181    Private Sub cmdSwitch_Click() 
1,182     '11-06
1,183   
1,184       On Error Resume Next 
1,185       If Me.Dirty Then Me.Dirty = False 
1,186   
1,187       If Nz(gCIDlast, 0) = 0 Or gCIDlast = Me.CID Then 
1,188          MsgBox "Can't switch", , "Aborting" 
1,189          Exit Sub 
1,190       End If 
1,191   
1,192    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

fnd_Name_DblClick (6)

1,193   
1,194   
1,195    Private Sub fnd_Name_DblClick(Cancel As Integer) 
1,196       If IsNull(Me.CID) Then Exit Sub 
1,197       Me.fnd_Name = Me.CID 
1,198    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

CID__DblClick (16)

1,199   
1,200   
1,201   
1,202    Private Sub CID__DblClick(Cancel As Integer) 
1,203     '3-20-09, 140416
1,204       On Error Resume Next 
1,205       If IsNull(Me.ActiveControl) Then Exit Sub 
1,206   
1,207       Dim nRecordID As Long 
1,208       nRecordID = Me.ActiveControl 
1,209   
1,210       If Me.Dirty Then Me.Dirty = False 
1,211   
1,212       Call FindMyContact("", nRecordID) 
1,213   
1,214    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

NameB_AfterUpdate (11)

1,215   
1,216   
1,217   
1,218   
1,219   
1,220   
1,221    Private Sub NameB_AfterUpdate() 
1,222     '101007
1,223       If IsNull(Me.ActiveControl) Then Exit Sub 
1,224       Me.ActiveControl = StrConv(Me.ActiveControl, 3)   'vbProperCase 
1,225    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

MainName_AfterUpdate (6)

1,226   
1,227    Private Sub MainName_AfterUpdate() 
1,228     '101007
1,229       If IsNull(Me.ActiveControl) Then Exit Sub 
1,230       Me.ActiveControl = StrConv(Me.ActiveControl, 3)   'vbProperCase 
1,231    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

NameA_AfterUpdate (6)

1,232   
1,233    Private Sub NameA_AfterUpdate() 
1,234     '101007
1,235       If IsNull(Me.ActiveControl) Then Exit Sub 
1,236       Me.ActiveControl = StrConv(Me.ActiveControl, 3)   'vbProperCase 
1,237    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

NickName_AfterUpdate (6)

1,238   
1,239    Private Sub NickName_AfterUpdate() 
1,240     '101007
1,241       If IsNull(Me.ActiveControl) Then Exit Sub 
1,242       Me.ActiveControl = StrConv(Me.ActiveControl, 3)   'vbProperCase 
1,243    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

CID__AfterUpdate (5)

1,244   
1,245    Private Sub CID__AfterUpdate() 
1,246     '140416
1,247       Me.Dirty = False 
1,248    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Binoculars_Click (21)

1,249   
1,250    Private Sub cmd_Binoculars_Click() 
1,251    MsgBox "under construction" 
1,252    Exit Sub 
1,253   
1,254       On Error GoTo Proc_Err 
1,255       If Me.Dirty Then 
1,256          Call Form_BeforeUpdate(False) 
1,257       End If 
1,258       DoCmd.OpenForm "fc_Find", , , , , acDialog 
1,259    Proc_Exit: 
1,260       Exit Sub 
1,261   
1,262    Proc_Err: 
1,263       MsgBox Err.Description, , _ 
1,264            "ERROR " & Err.Number _ 
1,265            & "   cmd_Binoculars_Click: " & Me.Name 
1,266   
1,267       Resume Proc_Exit 
1,268       Resume 
1,269    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Clear_fltr_cCatID_Click (9)

1,270   
1,271   
1,272   
1,273    Private Sub cmd_Clear_fltr_cCatID_Click() 
1,274     '140420, 21
1,275       Me.fltr_cCatID.Value = Null 
1,276       Me.fltr_chkHuman = Null 
1,277       Call FilterMyFind 
1,278    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

fltr_cCatID_AfterUpdate (5)

1,279   
1,280    Private Sub fltr_cCatID_AfterUpdate() 
1,281     '141009
1,282       Call FilterMyFind 
1,283    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

FilterMyFind (140)

1,284   
1,285    Private Function FilterMyFind() As Boolean 
1,286     '131002, 140416, 21, 22, 141009 SetControl_RowSource
1,287   
1,288        'CALLS
1,289        '  SetControl_RowSource
1,290        '
1,291        'Called By
1,292        '  cmd_Clear_fltr_cCatID_Click
1,293        '  fltr_cCatID_AfterUpdate
1,294        '  fltr_chkHuman_AfterUpdate
1,295   
1,296       On Error GoTo Proc_Err 
1,297   
1,298       Dim sSQL As String _ 
1,299          , vWhere As Variant _ 
1,300          , sOrderBy As String _ 
1,301          , sEqn_Fullname As String _ 
1,302          , iPos1 As Integer _ 
1,303          , iPos2 As Integer 
1,304   
1,305       vWhere = Null 
1,306   
1,307        '-------------------------- Filter
1,308       With Me.fltr_cCatID 
1,309          If Not IsNull(.Value) Then 
1,310             vWhere = (vWhere + " AND ") & "c.cCatIDc=" & .Value 
1,311          End If 
1,312       End With 
1,313       With Me.fltr_chkHuman 
1,314          If Not IsNull(.Value) Then 
1,315             vWhere = (vWhere + " AND ") & "c.IsHuman=" & .Value 
1,316          End If 
1,317       End With 
1,318       vWhere = Nz(vWhere, "") 
1,319   
1,320        ' other FIND combo and listbox rowsources -- not sorted, only filtered
1,321       Call SetControl_RowSource(Me.fnd_Adr, vWhere) 
1,322   
1,323         '-------------------------- Sort
1,324       Select Case Me.srtBy 
1,325       Case 2 '"Active, Main Name"; 
1,326          sOrderBy = "iif(C.IsACTIV Is Null,99, C.IsACTIV), [c].[MainName] & [c].[NameA]" 
1,327          sEqn_Fullname = "GetFullName([c].[MainName],[c].[NameA],[c].[NameB],[c].[NickName],[c].[Sufx],'LA',[c].[IsActiv]) " 
1,328       Case 3 '"First, Last"; 
1,329          sOrderBy = "[c].[NameA] & [c].[MainName]" 
1,330          sEqn_Fullname = "GetFullName([c].[MainName],[c].[NameA],[c].[NameB],[c].[NickName],[c].[Sufx],'F',[c].[IsActiv])  " 
1,331       Case 4  '"Last, First" 
1,332          sOrderBy = "[c].[MainName] & [c].[NameA]" 
1,333          sEqn_Fullname = "GetFullName([c].[MainName],[c].[NameA],[c].[NameB],[c].[NickName],[c].[Sufx],'L',[c].[IsActiv]) " 
1,334       Case Else '1 '"Active, First"; 
1,335          sOrderBy = "iif(C.IsACTIV Is Null,99, C.IsACTIV), [c].[NameA] & [c].[MainName]" 
1,336          sEqn_Fullname = "GetFullName([c].[MainName],[c].[NameA],[c].[NameB],[c].[NickName],[c].[Sufx],'FA',[c].[IsActiv])  " 
1,337       End Select 
1,338   
1,339       vWhere = Nz(vWhere, "") 
1,340   
1,341       Call SetControl_RowSource(Me.fnd_Name, vWhere, , , sOrderBy, "GetFullName()", sEqn_Fullname) 
1,342     '
1,343        'rest of code is commented
1,344     '
1,345     '   sSQL = Me.fnd_Name.Tag
1,346     '
1,347     '   If sOrderBy <> "" Then
1,348     '      sSQL = GetSQL_ORDERBY(sSQL, sOrderBy)
1,349     '   End If
1,350     '   sSQL = GetSQL_WHERE(sSQL, vWhere)
1,351     'Debug.Print "where"
1,352     'Debug.Print sSQL
1,353     '
1,354     '   'replace equation for name
1,355     '   iPos1 = InStr(sSQL, "GetFullName")
1,356     '   iPos2 = InStr(iPos1, sSQL, "AS Contact_")
1,357     'Debug.Print iPos1, iPos2
1,358     '
1,359     '   If Not (iPos1 > 0 And iPos2 > 0) Then
1,360     '      MsgBox "Error"
1,361     '      GoTo Proc_Exit
1,362     '   End If
1,363     '
1,364     '   sSQL = Left(sSQL, iPos1 - 1) & sEqn_Fullname & Mid(sSQL, iPos2 + 11)
1,365     '
1,366     'Debug.Print Me.srtBy, sEqn_Fullname
1,367     'Debug.Print
1,368     'Debug.Print sSQL
1,369     ''Stop
1,370   
1,371   
1,372     '   With Me.fnd_Name
1,373     '
1,374     '      If .RowSource <> sSQL Then
1,375     ''Debug.Print pCtl.Name, vWhere
1,376     ''Debug.Print sSQL
1,377     '
1,378     '         .Value = Null
1,379     '         .RowSource = sSQL
1,380     ''         On Error Resume Next
1,381     '         .Requery
1,382     '      End If
1,383     '   End With 'fnd_Name
1,384   
1,385   
1,386   
1,387   
1,388    Proc_Exit: 
1,389       On Error Resume Next 
1,390       Exit Function 
1,391   
1,392    Proc_Err: 
1,393       MsgBox Err.Description, , _ 
1,394            "ERROR " & Err.Number _ 
1,395            & "   FilterMyFind : " & Me.Name 
1,396   
1,397       Resume Proc_Exit 
1,398       Resume 
1,399    End Function 
1,400   
1,401     'Private Sub fnd_CustomerContact_AfterUpdate()
1,402     ''131002
1,403     '   'find by company contact
1,404     '   On Error GoTo Proc_Err
1,405     '   Dim nRecordID As Long
1,406     '   If IsNull(Me.ActiveControl) Then Exit Sub
1,407     '
1,408     '   nRecordID = Me.ActiveControl
1,409     '   Me.ActiveControl.Value = Null
1,410     '   Call FindMyContact("", nRecordID)
1,411     '
1,412     'Proc_Exit:
1,413     '   On Error Resume Next
1,414     '   Exit Sub
1,415     '
1,416     'Proc_Err:
1,417     '   MsgBox Err.Description, , _
1,418     '        "ERROR " & Err.Number _
1,419     '        & "  fnd_Name_AfterUpdate  : " & Me.Name
1,420     '   Resume Proc_Exit
1,421     '   Resume
1,422     '
1,423     'End Sub
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Previous_Click (7)

1,424   
1,425   
1,426   
1,427    Private Sub cmd_Previous_Click() 
1,428     '140421
1,429       Call MoveToRecord(-1) 
1,430    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

cmd_Next_Click (4)

1,431    Private Sub cmd_Next_Click() 
1,432     '140421
1,433       Call MoveToRecord(1) 
1,434    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

MoveToRecord (72)

1,435   
1,436    Private Function MoveToRecord( _ 
1,437       ByVal pNumber As Long _ 
1,438       ) As Boolean 
1,439     '140421, 512
1,440        'CALLS
1,441        '  FindMyContact
1,442        '
1,443        'CALLED BY
1,444        '  cmd_Previous_Click
1,445        '  cmd_Next_Click
1,446        '
1,447       On Error GoTo Proc_Err 
1,448       MoveToRecord = False 
1,449   
1,450       Dim db As DAO.Database _ 
1,451          , rs As DAO.Recordset 
1,452   
1,453       Dim nCID As Long 
1,454   
1,455       If Me.Dirty Then Me.Dirty = False 
1,456   
1,457       If Me.NewRecord Then 
1,458          nCID = -99 
1,459       Else 
1,460          nCID = Me.CID 
1,461       End If 
1,462   
1,463       Set db = CurrentDb 
1,464       Set rs = Me.fnd_Name.Recordset 
1,465       With rs 
1,466          .MoveLast 
1,467    MsgBox .RecordCount & " records in Find combo" 
1,468          .MoveFirst 
1,469          If nCID <> -99 Then 
1,470             .FindFirst "ID = " & CStr(nCID)    '--------- doesn't find 860 '140512 cstr 
1,471             If .NoMatch Then 
1,472                GoTo Proc_Exit   'duct tape till can figure out why code is truncating Tag to 255 
1,473             End If 
1,474             .Move pNumber 
1,475          Else 
1,476              'no current record -- Move First or Last
1,477             If Not .RecordCount > 0 Then 
1,478                GoTo Proc_Exit 
1,479             End If 
1,480             If pNumber < 0 Then 
1,481                .MoveFirst 
1,482             Else 
1,483                .MoveLast 
1,484             End If 
1,485          End If 
1,486          nCID = !CID 
1,487       End With 
1,488   
1,489       Call FindMyContact(, nCID) 
1,490   
1,491       MoveToRecord = True 
1,492   
1,493    Proc_Exit: 
1,494       On Error Resume Next 
1,495       Set rs = Nothing 
1,496       Set db = Nothing 
1,497       Exit Function 
1,498   
1,499    Proc_Err: 
1,500       MsgBox Err.Description, , _ 
1,501            "ERROR " & Err.Number _ 
1,502            & "   MoveToRecord : " & Me.Name 
1,503   
1,504       Resume Proc_Exit 
1,505       Resume 
1,506    End Function 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

fnd_AdrID_AfterUpdate (90)

1,507   
1,508   
1,509   
1,510   
1,511    Private Sub fnd_AdrID_AfterUpdate() 
1,512     '131217 Find or Create Address with specified type, 131224, 140416
1,513   
1,514        'CALLS
1,515        '  rsql
1,516   
1,517       On Error GoTo Proc_Err 
1,518   
1,519       Dim nCIDadr As Long _ 
1,520          , nCID As Long _ 
1,521          , nAdrID As Long _ 
1,522          , nTypIdAdr As Long _ 
1,523          , sAdrType As String _ 
1,524          , iOrdr As Integer _ 
1,525          , sFullName As String _ 
1,526          , sSQL As String 
1,527   
1,528       With Me.fnd_AdrID 
1,529           'exit if user didn't pick anything to find
1,530          If IsNull(.Value) Then Exit Sub 
1,531          nCID = .Value 
1,532          nTypIdAdr = Nz(.Column(1), -999) 
1,533           'CID from Adress table will be null if there is no match
1,534          If .Column(2) <> "" Then 
1,535             nCIDadr = .Column(2) 
1,536          Else 
1,537             nCIDadr = -999   'make a new record 
1,538          End If 
1,539          If .Column(3) <> "" Then nAdrID = .Column(3) Else nAdrID = -999 
1,540          If .Column(4) <> "" Then sAdrType = .Column(4) Else sAdrType = "NEW" 
1,541          .Value = Null 
1,542       End With   'Me.fnd_AdrID 
1,543   
1,544       sFullName = Me.ContactName 
1,545   
1,546       If nCIDadr = -999 Then 
1,547          If MsgBox("Address type of " & sAdrType _ 
1,548                & " does not exist for " & sFullName _ 
1,549                & vbCrLf & vbCrLf & "Do you want to create a NEW " _ 
1,550                & sAdrType & " address?" _ 
1,551                , vbYesNo _ 
1,552                , "Create new address?") _ 
1,553                = vbYes Then 
1,554             With Me.fc_Addresses_sub.Form 
1,555                 'create new address
1,556   
1,557                If .Dirty Then .Dirty = False 
1,558                iOrdr = Nz(DMax("OrdrAdr", "c_Address", "CID=" & nCID), 0) + 1 
1,559                sSQL = "INSERT INTO c_Address (CID, TypIDadr, OrdrAdr)" _ 
1,560                   & " SELECT " & nCID _ 
1,561                   & "," & nTypIdAdr _ 
1,562                   & "," & iOrdr _ 
1,563                   & ";" 
1,564                If Not rSql(sSQL) > 0 Then 
1,565                   MsgBox "Error adding address", , "Contact Crystal" 
1,566                   GoTo Proc_Exit 
1,567                End If 
1,568                .Requery 
1,569                 'find record just created
1,570                .Recordset.FindFirst "OrdrAdr=" & iOrdr 
1,571                .Addr1.SetFocus 
1,572             End With   'Me.fc_Addresses_sub.Form 
1,573             Me.fnd_AdrID.Requery 
1,574   
1,575          Else 
1,576              'don't create new address
1,577             GoTo Proc_Exit 
1,578          End If   'create new address 
1,579   
1,580       Else 
1,581           'find record
1,582          Call FindRecordN(Me.fc_Addresses_sub.Form, "AdrID", "Addr1", nAdrID) 
1,583       End If 
1,584   
1,585    Proc_Exit: 
1,586       On Error Resume Next 
1,587       Exit Sub 
1,588   
1,589    Proc_Err: 
1,590       MsgBox Err.Description, , _ 
1,591            "ERROR " & Err.Number _ 
1,592            & "   fnd_AdrID_AfterUpdate : " & Me.Name 
1,593   
1,594       Resume Proc_Exit 
1,595       Resume 
1,596    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

Form_AfterUpdate (11)

1,597   
1,598     '~~~~~~~~~~~~~~~~~~~~~~~~~~ binoculars_Enter
1,599   
1,600   
1,601    Private Sub Form_AfterUpdate() 
1,602     '...140421
1,603       Dim nCID As Long 
1,604       nCID = Me.CID 
1,605       Call RequeryMyStuff 
1,606       Call Set_Property("local_CID", nCID) 
1,607    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

Form_AfterDelConfirm (4)

1,608   
1,609    Private Sub Form_AfterDelConfirm(Status As Integer) 
1,610       Call RequeryMyStuff 
1,611    End Sub 
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

Form_BeforeUpdate (68)

1,612   
1,613    Private Sub Form_BeforeUpdate(Cancel As Integer) 
1,614   
1,615        'update tracking fields
1,616       Call FormBeforeUpdate(Me) 
1,617   
1,618    Proc_Exit: 
1,619       On Error Resume Next 
1,620       Exit Sub 
1,621    End Sub 
1,622   
1,623   
1,624   
1,625   
1,626     '===================
1,627     'Private Sub ApCID_NotInList( _
1,628     '   NewData As String, _
1,629     '   Response As Integer)
1,630     ''3-21-09
1,631     '    ' crystal (strive4peace)
1,632     '
1,633     '   'set up Error Handler
1,634     '   On Error GoTo Proc_Err
1,635     '
1,636     '    Dim s As String _
1,637     '      , nRecordID As Long _
1,638     '      , mText As String
1,639     '
1,640     '    ' Display message box asking if user wants to add a new item
1,641     '    s = "'" & NewData & "' is not in the current list. " _
1,642     '      & vbCrLf & vbCrLf _
1,643     '      & "Do you want to add it? " _
1,644     '      & vbCrLf _
1,645     '      & "(Check to ensure new entry is correct before proceeding)"
1,646     '
1,647     '    Select Case MsgBox(s, vbYesNo + vbDefaultButton2 _
1,648     '      , "Add New Data")
1,649     '
1,650     '    Case vbYes
1,651     '
1,652     '      s = "INSERT INTO Applications(Applictn) " _
1,653     '         & " SELECT '" & NewData & "';"
1,654     '
1,655     '       rSql s
1,656     '
1,657     '       'assume SQL to add was ok
1,658     '        Response = acDataErrAdded
1,659     '
1,660     '    Case Else
1,661     '        Response = acDataErrContinue
1,662     '    End Select
1,663     '
1,664     'Proc_Exit:
1,665     '   Exit Sub
1,666     '
1,667     'Proc_Err:
1,668     '   MsgBox Err.Description, , _
1,669     '        "ERROR " & Err.Number _
1,670     '        & "   ProcedureName : " & Me.Name
1,671     '
1,672     '   Resume Proc_Exit
1,673     '   Resume
1,674     '
1,675     '
1,676     'End Sub
1,677   
1,678   
1,679   
      Goto Top       Goto Form_fc_MENU_CONTACT       Goto Index

Form_fc_Notes_sub (65)

PROCEDURES       Goto Top       Goto Form_fc_Notes_sub       Goto Forms       Goto Index
  1. Declaration Lines (36)
  2. dtmDun_DblClick (5)
  3. dtmNote_DblClick (6)
  4. Form_BeforeUpdate (7)
  5. Subject_AfterUpdate (6)
  6. TypIDnote_NotInList (5)

Declaration Lines (36)

1        Option Compare Database 
2        Option Explicit 
3         '=======================================================
4         '
5         ' code behind form: fc_AnywhereNotes
6         '
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, 140629
28        ' ~ Crystal
29        '              * have an awesome day :)
30        '                                                   www.AccessMVP.com/strive4peace
31        ' END LICENSE NOTICE
32        '============================================================
33        '
34        'NEEDS PROPERTIES:
35        '   "local_TID"
36        '   "local_RecordID"
      Goto Top       Goto Form_fc_Notes_sub       Goto Index

dtmDun_DblClick (5)

37      
38       Private Sub dtmDun_DblClick(Cancel As Integer) 
39        '130921
40          DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog 
41       End Sub 
      Goto Top       Goto Form_fc_Notes_sub       Goto Index

Form_BeforeUpdate (7)

42      
43       Private Sub Form_BeforeUpdate(Cancel As Integer) 
44        '140618
45           'update tracking fields
46          FormBeforeUpdate Me, True 
47      
48       End Sub 
      Goto Top       Goto Form_fc_Notes_sub       Goto Index

Subject_AfterUpdate (6)

49      
50       Private Sub Subject_AfterUpdate() 
51        '101222
52          If IsNull(Me.Subject) Then Exit Sub 
53          Me.Subject = StrConv(Me.Subject, vbProperCase) 
54       End Sub 
      Goto Top       Goto Form_fc_Notes_sub       Goto Index

TypIDnote_NotInList (5)

55      
56       Private Sub TypIDnote_NotInList(NewData As String, Response As Integer) 
57        '   MsgBox "TypIDnote_NotInList not defined for " & Me.Name _
58        '      , , "Write Code"
59       End Sub 
      Goto Top       Goto Form_fc_Notes_sub       Goto Index

dtmNote_DblClick (6)

60      
61       Private Sub dtmNote_DblClick(Cancel As Integer) 
62        '130908
63          DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog 
64       End Sub 
65      
      Goto Top       Goto Form_fc_Notes_sub       Goto Index

Form_fc_Phones_sub (195)

PROCEDURES       Goto Top       Goto Form_fc_Phones_sub       Goto Forms       Goto Index
  1. cmd_Add_Click (14)
  2. cmd_Address_Click (5)
  3. cmd_Del_Click (6)
  4. cmd_PastePhone_Click (31)
  5. Declaration Lines (41)
  6. Form_BeforeUpdate (29)
  7. IMPhone_AfterUpdate (13)
  8. Phone_AfterUpdate (6)
  9. Phone_GotFocus (6)
  10. phoNote_AfterUpdate (6)
  11. SetPhoneMask (11)
  12. TypIdPho_NotInList (27)

Declaration Lines (41)

1        Option Compare Database 
2        Option Explicit 
3         '=======================================================
4         ' fc_Phones_Sub
5         ' CONTACT MANAGEMENT APPLET
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        '101010
33        '
34        ' CALLS
35        '   StripPhoneNonNumeric
36        '   RecordNew
37        '   RecordDelete
38        '   FormBeforeUpdate
39        '   GetResponse_NIL
40        '
41        'combos have --> DropMe, DropMeIfNull
      Goto Top       Goto Form_fc_Phones_sub       Goto Index

cmd_Add_Click (14)

42      
43        '=======================================================
44        '3-20-09
45        '
46        '=======================================================
47        '
48        ' -107 checked 101007]
49      
50      
51       Private Sub cmd_Add_Click() 
52        '3-20-09 ' -107
53          On Error Resume Next 
54          RecordNew Me, "Phone" 
55       End Sub 
      Goto Top       Goto Form_fc_Phones_sub       Goto Index

cmd_Address_Click (5)

56      
57       Private Sub cmd_Address_Click() 
58        '110622
59          Me.Parent.GotToAddress 
60       End Sub 
      Goto Top       Goto Form_fc_Phones_sub       Goto Index

cmd_Del_Click (6)

61      
62       Private Sub cmd_Del_Click() 
63        '3-20-09 ' -107
64          On Error Resume Next 
65          RecordDelete Me, "Phone" 
66       End Sub 
      Goto Top       Goto Form_fc_Phones_sub       Goto Index

cmd_PastePhone_Click (31)

67      
68       Private Sub cmd_PastePhone_Click() 
69        '101010
70          On Error GoTo Proc_Err 
71      
72          Dim aAns As String _ 
73             , sInputMask As String 
74      
75          aAns = InputBox("Paste Phone Number:", "Paste Phone Number") 
76      
77          If Len(Trim(aAns)) = 0 Then 
78             GoTo Proc_Exit 
79          End If 
80      
81          If Len(Me.Phone.InputMask & "") > 0 Then 
82             Me.Phone = StripPhoneNonNumeric(aAns) 
83          Else 
84             Me.Phone = aAns 
85          End If 
86      
87       Proc_Exit: 
88          Me.Phone.SetFocus 
89          Exit Sub 
90      
91       Proc_Err: 
92          MsgBox Err.Description, , _ 
93               "ERROR " & Err.Number _ 
94               & "   cmd_PastePhone_Click" 
95          Resume Proc_Exit 
96          Resume 
97       End Sub 
      Goto Top       Goto Form_fc_Phones_sub       Goto Index

Form_BeforeUpdate (29)

98      
99       Private Sub Form_BeforeUpdate(Cancel As Integer) 
100       '3-20 -107 '110101 TONY
101         On Error Resume Next 
102     
103         If IsNull(Me.OrdrPho) Then 
104            Me.OrdrPho = Me.Recordset.RecordCount _ 
105               + IIf(Me.NewRecord, 1, 0) 
106         End If 
107     
108       Dim mAnswer As Long 
109     
110         mAnswer = AskSaveTheChanges("Phone" _ 
111            , Me.Phone) 
112         Select Case mAnswer 
113            Case vbCancel 
114               Me.Undo 
115               Cancel = True 
116            Case vbNo 
117               Cancel = True 
118            Case vbYes 
119                'update tracking fields
120               On Error Resume Next 
121               FormBeforeUpdate Me, True 
122            Case Else 
123       '         MsgBox mAnswer
124         End Select 
125     
126      End Sub 
      Goto Top       Goto Form_fc_Phones_sub       Goto Index

IMPhone_AfterUpdate (13)

127     
128      Private Sub IMPhone_AfterUpdate() 
129       '101010,
130         Dim sIMPhone As String 
131     
132         If IsNull(Me.ActiveControl) Then 
133            sIMPhone = "" 
134         Else 
135            sIMPhone = Me.ActiveControl 
136         End If 
137     
138         Call SetPhoneMask(sIMPhone) 
139      End Sub 
      Goto Top       Goto Form_fc_Phones_sub       Goto Index

SetPhoneMask (11)

140     
141      Public Sub SetPhoneMask(ByVal psIMPhone As String) 
142       '140102
143     
144         If Len(Trim(psIMPhone)) > 0 And Not InStr(psIMPhone, ";") > 0 Then 
145            psIMPhone = psIMPhone & ";0;_" 
146         End If 
147         Me.Phone.InputMask = Trim(psIMPhone) 
148         Me.IMPhone = psIMPhone 
149     
150      End Sub 
      Goto Top       Goto Form_fc_Phones_sub       Goto Index

Phone_AfterUpdate (6)

151     
152      Private Sub Phone_AfterUpdate()   '------------ default area code not implemented 
153       ''   If Len(Me.Phone) = 7 Then
154       ''      Me.Phone = "508" & Me.Phone
155       ''   End If
156      End Sub 
      Goto Top       Goto Form_fc_Phones_sub       Goto Index

Phone_GotFocus (6)

157     
158      Private Sub Phone_GotFocus() 
159       '110214 TONY
160       'Me![Phone].SelStart = 4
161       '    Me![Phone].SelLength = 1
162      End Sub 
      Goto Top       Goto Form_fc_Phones_sub       Goto Index

phoNote_AfterUpdate (6)

163     
164      Private Sub phoNote_AfterUpdate() 
165       '101007
166       '   If IsNull(Me.ActiveControl) Then Exit Sub
167       '   Me.ActiveControl = StrConv(Me.ActiveControl, 3) 'vbProperCase
168      End Sub 
      Goto Top       Goto Form_fc_Phones_sub       Goto Index

TypIdPho_NotInList (27)

169     
170      Private Sub TypIdPho_NotInList( _ 
171         NewData As String, _ 
172         Response As Integer) 
173     
174         On Error Resume Next 
175     
176          ' crystal (strive4peace)
177         Dim sTblNm As String _ 
178           , sFldNm As String _ 
179           , nTID As Long 
180     
181         sTblNm = "c_Phoype" 
182         sFldNm = "TypPho" 
183         nTID = 0 
184     
185         Response = GetResponse_NIL(NewData, sTblNm, sFldNm, nTID, "Phone Type") 
186     
187      End Sub 
188     
189       '
190       'Private Sub TypID_DblClick(Cancel As Integer)
191       ''=RemoveTypeID()
192       ''  To add a new Type to the list, simply enter a new value   DOUBLE-CLICK to remove Type
193       '
194       'End Sub
195     
      Goto Top       Goto Form_fc_Phones_sub       Goto Index

Form_fc_PikPeople (418)

PROCEDURES       Goto Top       Goto Form_fc_PikPeople       Goto Forms       Goto Index
  1. AZ_ZA_AfterUpdate (5)
  2. BoldControl (25)
  3. chkActive_AfterUpdate (5)
  4. ClearLetters (5)
  5. cmd_Reset_Click (13)
  6. Declaration Lines (31)
  7. FindRecord (45)
  8. Form_Load (32)
  9. Form_Open (18)
  10. fraSort_AfterUpdate (5)
  11. fraWhen_AfterUpdate (7)
  12. ResetLetters (4)
  13. set_RowSource_Names (216)
  14. set_RowSource_Names_FindPeople (7)

Declaration Lines (31)

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        '
31        'originally released 6-4-07
      Goto Top       Goto Form_fc_PikPeople       Goto Index

set_RowSource_Names (216)

32      
33        'open: populate fePikP
34      
35       Function set_RowSource_Names( _ 
36          DoLetter As Boolean _ 
37          ) 
38        '... 140103 strive4peace
39      
40          On Error GoTo Proc_Err 
41      
42          Dim sLetterField As String _ 
43             , sNameExpr As String _ 
44             , vWhere As Variant _ 
45             , nRecordID As Long _ 
46             , sSQL As String _ 
47             , i As Integer _ 
48             , sOrderBy As String _ 
49             , iMultiplier As Integer _ 
50             , iPos1 As Integer _ 
51             , iPos2 As Integer _ 
52             , iPos3 As Integer 
53      
54          vWhere = Null 
55      
56           '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~```
57          With Me.AirportID 
58             If Not IsNull(.Value) Then 
59                vWhere = (vWhere + " AND ") _ 
60                      & "E.AirportID = " & .Value 
61             End If 
62          End With   'Airport 
63      
64          With Me.St 
65             If Not IsNull(.Value) Then 
66                vWhere = (vWhere + " AND ") _ 
67                      & "E.StDef = '" & .Value & "'" 
68             End If 
69          End With   'St 
70      
71          With Me.Ctry 
72             If Not IsNull(.Value) Then 
73                vWhere = (vWhere + " AND ") _ 
74                      & "E.CtryDef = '" & .Value & "'" 
75             End If 
76          End With   'Ctry 
77      
78          With Me.FLSAid 
79             If Not IsNull(.Value) Then 
80                vWhere = (vWhere + " AND ") _ 
81                      & "E.FLSAid = " & .Value 
82             End If 
83          End With   'FLSAid 
84      
85          With Me.JobTypID   'Position 
86             If Not IsNull(.Value) Then 
87                vWhere = (vWhere + " AND ") _ 
88                      & "EJTy.JobTypID = " & .Value 
89             End If 
90          End With   'Position 
91           '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~```
92          If Me.chkUseWhen Then 
93             If Not IsNull(Me.NumWhen) Then 
94                Select Case Me.fraWhen 
95                   Case 1: iMultiplier = 1   'days 
96                   Case 2: iMultiplier = 7   'weeks 
97                End Select 
98                Select Case Me.fraWhen 
99                Case 1, 2   'days, weeks 
100                  vWhere = (vWhere + " AND ") _ 
101                     & "Format(E.dtmEdit,'yyyymmdd') >= '" _ 
102                     & Format(Date - (NumWhen * iMultiplier), "yyyymmdd") & "'" 
103               Case 3   'months 
104                  vWhere = (vWhere + " AND ") _ 
105                     & "Format(E.dtmEdit,'yyyymmdd') >= '" _ 
106                     & Format(DateAdd("m", -NumWhen, Date), "yyyymmdd") & "'" 
107               Case 4   'years 
108                  vWhere = (vWhere + " AND ") _ 
109                     & "Format(E.dtmEdit,'yyyymmdd') >= '" _ 
110                     & Format(DateAdd("yyyy", -NumWhen, Date), "yyyymmdd") & "'" 
111               End Select 
112            End If 
113         End If 
114     
115     
116         If Not IsNull(Me.chkActive) Then 
117            vWhere = (vWhere + " AND ") _ 
118                     & IIf(Not Me.chkActive, " Not", "") & " E.IsActiv" 
119         End If 
120     
121     
122         vWhere = " WHERE " + vWhere 
123     
124          '--------------------------------- get expression to use for Name
125         Select Case Me.fraSort 
126            Case 2   'sort by Lastname 
127               sNameExpr = "(Firstname + ' ') " _ 
128                  & " & (MidName + ' ') " _ 
129                  & " & Lastname" _ 
130                  & " & (', ' + [Sufx] + ', ') " _ 
131     
132            Case Else   'sort by first name 
133               sNameExpr = "Lastname" _ 
134                  & " & (', ' + [Sufx] + ', ') " _ 
135                  & " & (', ' + Firstname " _ 
136                  & " & ( ' ' + MidName) )" 
137         End Select 
138     
139         If Me.fraSort = 2 Then 
140            sLetterField = "Lastname" 
141         Else 
142            sLetterField = "FirstName" 
143         End If 
144     
145         With Me.lstLetters 
146            If DoLetter Then 
147               sSQL = .Tag 
148               .Value = Null 
149                '--------------------------------- get fieldname to use for letters
150                'SORT: 1=First, 2=Last, 3=Active, 4=Airport 5=Position
151     
152               sSQL = "SELECT DISTINCT" _ 
153                  & " Trim(Left(" & sLetterField & ",1)) AS _ " _ 
154                  & Mid(sSQL, InStr(sSQL, "FROM ")) 
155               If Not IsNull(vWhere) Then 
156                  sSQL = GetSQL_WHERE(sSQL, vWhere & "") 
157               End If 
158     
159                                 Debug.Print "lstLetters" 
160                                 Debug.Print sSQL 
161     
162               If .RowSource <> sSQL Then 
163                  .RowSource = sSQL 
164                  .Requery 
165               End If 
166            Else 
167                'add criteria to main list
168               If Not IsNull(.Value) Then 
169                  vWhere = (vWhere + " AND ") _ 
170                        & " AND left(" & sLetterField & ",1) = '" & .Value & "'" 
171                  sSQL = GetSQL_WHERE(sSQL, vWhere & "") 
172               End If 
173            End If 
174         End With   'lstLetters 
175     
176         Select Case Me.fraSort 
177            Case 2   'lastname 
178               If Me.AZ_ZA.Caption = "AZ" Then 
179                  sOrderBy = "Lastname, Firstname" 
180               Else 
181                  sOrderBy = "Lastname desc, Firstname desc" 
182               End If 
183            Case 3   'Active 
184               If Me.AZ_ZA.Caption = "AZ" Then 
185                  sOrderBy = "E.IsActiv, " & sNameExpr 
186               Else 
187                  sOrderBy = "E.IsActiv desc, " & sNameExpr & " desc" 
188               End If 
189            Case 4   'Airport 
190               If Me.AZ_ZA.Caption = "AZ" Then 
191                  sOrderBy = "IATA, " & sNameExpr 
192               Else 
193                  sOrderBy = "IATA desc, " & sNameExpr & " desc" 
194               End If 
195            Case 5   'Position 
196               If Me.AZ_ZA.Caption = "AZ" Then 
197                  sOrderBy = "JobTyp, " & sNameExpr 
198               Else 
199                  sOrderBy = "JobTyp desc, " & sNameExpr & " desc" 
200               End If 
201            Case Else   'Firstname 
202               If Me.AZ_ZA.Caption = "AZ" Then 
203                  sOrderBy = "Firstname, MidName, Lastname" 
204               Else 
205                  sOrderBy = "Firstname desc, MidName desc, Lastname desc" 
206               End If 
207         End Select 
208     
209     
210          'infuse the name field expression
211          ' after ... AS _
212     
213         sSQL = Me.lstNames.Tag 
214         iPos1 = InStr(sSQL, "AS _") + 4 
215          ' after comma
216         iPos1 = InStr(iPos1, sSQL, ",") + 1 
217          ' before "AS Employee"
218         iPos2 = InStr(iPos1, sSQL, "AS Employee") - 1 
219         iPos3 = InStr(iPos2, sSQL, "ORDER BY ") 
220     
221         sSQL = Left(sSQL, iPos1) _ 
222            & sNameExpr _ 
223            & Mid(sSQL, iPos2, iPos3 - iPos2) _ 
224            & vWhere _ 
225            & " ORDER BY " & sOrderBy & ", E.EmpID;" 
226     
227       Debug.Print "lstNames" 
228       Debug.Print sSQL 
229     
230         With Me.lstNames 
231            If .RowSource <> sSQL Then 
232               .RowSource = sSQL 
233               .Value = Null 
234            End If 
235         End With 
236     
237      Proc_Exit: 
238         On Error Resume Next 
239         Exit Function 
240     
241      Proc_Err: 
242         MsgBox Err.Description _ 
243            , , "ERROR " & Err.Number & "  set_RowSource_Names" 
244         If Err.Number = 9 Then Resume Proc_Exit 
245         Resume Proc_Exit 
246         Resume 
247      End Function 
      Goto Top       Goto Form_fc_PikPeople       Goto Index

ClearLetters (5)

248     
249      Private Function ClearLetters() 
250         Me.lstLetters = Null 
251         set_RowSource_Names True 
252      End Function 
      Goto Top       Goto Form_fc_PikPeople       Goto Index

BoldControl (25)

253     
254      Function BoldControl( _ 
255         pControlname As String _ 
256         , pNum As Integer) 
257     
258         If pNum = 0 Then 
259            Me("label_" & pControlname).FontBold = Nz(Me(pControlname)) 
260            Exit Function 
261         End If 
262     
263         Dim i As Integer 
264         For i = 1 To pNum 
265            Me("label_" & pControlname & Format(i, "#")).FontBold = IIf(Me(pControlname) = i, True, False) 
266         Next i 
267     
268      Exit_Proc: 
269         On Error Resume Next 
270         Exit Function 
271      Err_Proc: 
272         MsgBox Err.Description _ 
273            , , "ERROR " & Err.Number _ 
274            & "   BoldControl: " & pControlname & ":, " & Nz(pNum) 
275         Resume Exit_Proc 
276         Resume 
277      End Function 
      Goto Top       Goto Form_fc_PikPeople       Goto Index

AZ_ZA_AfterUpdate (5)

278     
279      Private Sub AZ_ZA_AfterUpdate() 
280         If Me.AZ_ZA.Caption = "ZA" Then Me.AZ_ZA.Caption = "AZ" Else Me.AZ_ZA.Caption = "ZA" 
281         set_RowSource_Names True 
282      End Sub 
      Goto Top       Goto Form_fc_PikPeople       Goto Index

chkActive_AfterUpdate (5)

283     
284      Private Sub chkActive_AfterUpdate() 
285       '140103
286         Call set_RowSource_Names(True) 
287      End Sub 
      Goto Top       Goto Form_fc_PikPeople       Goto Index

cmd_Reset_Click (13)

288     
289      Private Sub cmd_Reset_Click() 
290       '140103
291         Me.AirportID = Null 
292         Me.St = Null 
293         Me.Ctry = Null 
294         Me.FLSAid = Null 
295         Me.JobTypID = Null 
296         Me.chkActive = False 
297         Me.chkUseWhen = False 
298     
299         Call set_RowSource_Names(True) 
300      End Sub 
      Goto Top       Goto Form_fc_PikPeople       Goto Index

Form_Load (32)

301     
302      Private Sub Form_Load() 
303         On Error GoTo Proc_Err 
304     
305         Dim i As Integer 
306     
307         Me.Label_chkActive.FontBold = Nz(Me.chkActive, False) 
308     
309         BoldControl "fraSort", 5 
310     
311         set_RowSource_Names True 
312     
313       '   If IsLoaded("f_PEOPLE") Then
314       '      With Forms!f_People
315       '         If Not .NewRecord Then
316       '            On Error Resume Next
317       '            Me.lstNames = !pid
318       '         End If
319       '      End With
320       '   End If
321     
322      Proc_Exit: 
323         On Error Resume Next 
324         Exit Sub 
325     
326      Proc_Err: 
327      Form_Load_error: 
328         MsgBox Err.Description _ 
329            , , "ERROR " & Err.Number & "   Form_Load" 
330         Resume Proc_Exit 
331         Resume 
332      End Sub 
      Goto Top       Goto Form_fc_PikPeople       Goto Index

set_RowSource_Names_FindPeople (7)

333     
334      Function set_RowSource_Names_FindPeople(pRecordID As Long) 
335          '10-31-05
336         Me.lstNames.Requery 
337         Me.lstNames = pRecordID 
338         FindRecord pRecordID 
339      End Function 
      Goto Top       Goto Form_fc_PikPeople       Goto Index

FindRecord (45)

340     
341      Private Function FindRecord(pRecordID As Long) 
342         On Error GoTo Proc_Err 
343     
344       '   If Not IsLoaded("f_PEOPLE") Then
345       '      Exit Function
346       '   End If
347       '
348       '   Dim f As Form
349       '   Set f = Forms!f_People
350       '
351       '   'save record if changes made
352       '   If f.Dirty Then f.Dirty = False
353       '
354       '   f.RecordsetClone.FindFirst "[PID] = " & pRecordID
355       '
356       '   If Not f.RecordsetClone.NoMatch Then
357       '      f.Bookmark = f.RecordsetClone.Bookmark
358       '   Else
359       '      If MsgBox("PEOPLE is filtered" _
360       '         & vbCrLf & vbCrLf _
361       '         & "Remove filter and find record?" _
362       '         , vbYesNo _
363       '         , "Remove Filter?") = vbNo Then Exit Function
364       '
365       '      f.FilterOn = False
366       '      f.RecordsetClone.FindFirst "[PID] = " & pRecordID
367       '      f.Bookmark = f.RecordsetClone.Bookmark
368       '
369       '   End If
370     
371      Proc_Exit: 
372         On Error Resume Next 
373       '   Set f = Nothing
374         Exit Function 
375     
376      Proc_Err: 
377          'invalid reference to parent property
378         If Err.Number = 2452 Then Exit Function 
379     
380         MsgBox Err.Description _ 
381            , , "ERROR " & Err.Number & "   FindRecord" 
382         Resume Proc_Exit 
383         Resume 
384      End Function 
      Goto Top       Goto Form_fc_PikPeople       Goto Index

ResetLetters (4)

385     
386      Private Function ResetLetters() 
387         Me.lstLetters = Null 
388      End Function 
      Goto Top       Goto Form_fc_PikPeople       Goto Index

Form_Open (18)

389     
390      Private Sub Form_Open(Cancel As Integer) 
391       '140103
392         Dim sSQL As String 
393          'add new employees
394         sSQL = "INSERT INTO c_fe_PikP ( CID )" _ 
395            & " SELECT Employees.EmpID " _ 
396            & " FROM Employees;" 
397         Call rSql(sSQL) 
398          'delete employees no longer there
399         sSQL = "DELETE c_fe_PikP.* " _ 
400            & " FROM Employees RIGHT JOIN c_fe_PikP ON Employees.EmpID = c_fe_PikP.CID" _ 
401            & " WHERE (((Employees.EmpID) Is Null));" 
402         Call rSql(sSQL) 
403          'reset IsPik
404         sSQL = "UPDATE c_fe_PikP SET c_fe_PikP.IsPik = 0;" 
405         Call rSql(sSQL) 
406      End Sub 
      Goto Top       Goto Form_fc_PikPeople       Goto Index

fraSort_AfterUpdate (5)

407     
408      Private Sub fraSort_AfterUpdate() 
409         BoldControl "fraSort", 5 
410         set_RowSource_Names True 
411      End Sub 
      Goto Top       Goto Form_fc_PikPeople       Goto Index

fraWhen_AfterUpdate (7)

412     
413     
414      Private Sub fraWhen_AfterUpdate() 
415         BoldControl "fraWhen", 4 
416         set_RowSource_Names True 
417      End Sub 
418     
      Goto Top       Goto Form_fc_PikPeople       Goto Index

Form_fc_pop_Appointment (139)

PROCEDURES       Goto Top       Goto Form_fc_pop_Appointment       Goto Forms       Goto Index
  1. cmd_Cancel_Click (13)
  2. cmd_OK_Click (23)
  3. Declaration Lines (2)
  4. dtmAppt_AfterUpdate (34)
  5. Form_AfterUpdate (45)
  6. Form_BeforeUpdate (22)

Declaration Lines (2)

1        Option Compare Database     'Use database order for string comparisons 
2        Option Explicit 
      Goto Top       Goto Form_fc_pop_Appointment       Goto Index

dtmAppt_AfterUpdate (34)

3         '=======================================================
4         '
5         ' code behind form:  f_Pop_Appointment
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       Private Sub dtmAppt_AfterUpdate() 
33        '140614
34          If IsNull(Me.ActiveControl) Then Exit Sub 
35          Me.f_Calendar_sub.Form.Set_Calendar Me.dtmAppt 
36       End Sub 
      Goto Top       Goto Form_fc_pop_Appointment       Goto Index

Form_AfterUpdate (45)

37      
38        '-------------------------------------------------------------------- FORM
39      
40       Private Sub Form_AfterUpdate() 
41        '140212, 216, 140416, 140422
42           'CALLS
43           '  rSql
44           '  Set_Property -- local_CID
45      
46        '   Dim nCID As Long _
47        '      , sSQL As String
48        '
49        '   nCID = Me.CID
50        '   Call Set_Property("local_CID", nCID)
51        '
52        '   'add Category
53        '   With Me.cCatID
54        '      If Not IsNull(.Value) Then
55        '         sSQL = "INSERT INTO c_CtcCat ( cCatID, CID )" _
56        '            & " SELECT " & .Value _
57        '            & ", " & nCID & " AS CID" _
58        '            & ";"
59        '         Call rSql(sSQL)
60        '      End If
61        '   End With 'cCatID
62        '
63        '   'add List
64        '   With Me.ListID
65        '      If Not IsNull(.Value) Then
66        '         sSQL = "INSERT INTO c_ListMbr ( ListID, CID )" _
67        '            & " SELECT " & .Value _
68        '            & ", " & nCID & " AS CID" _
69        '            & ";"
70        '         Call rSql(sSQL)
71        '      End If
72        '   End With 'ListID
73        '
74        '   CurrentDb.TableDefs.Refresh
75        '   DoEvents
76      
77        '   Call FindTheContact(nCID)
78      
79        '   DoCmd.Close acForm, Me.Name 'chances are it won't come back here
80      
81       End Sub 
      Goto Top       Goto Form_fc_pop_Appointment       Goto Index

Form_BeforeUpdate (22)

82      
83       Private Sub Form_BeforeUpdate(Cancel As Integer) 
84        '140616
85      
86          On Error GoTo Proc_Err 
87      
88       UpdateTheRecord: 
89      
90          Me.dtmEdit = Now() 
91      
92       Proc_Exit: 
93          On Error Resume Next 
94          Exit Sub 
95      
96       Proc_Err: 
97          MsgBox Err.Description, , _ 
98               "ERROR " & Err.Number _ 
99               & "   Form_BeforeUpdate : " & Me.Name 
100     
101         Resume Proc_Exit 
102         Resume 
103      End Sub 
      Goto Top       Goto Form_fc_pop_Appointment       Goto Index

cmd_Cancel_Click (13)

104     
105       '-------------------------------------------------------------------- buttons
106     
107      Private Sub cmd_Cancel_Click() 
108       '140211, 17
109         If MsgBox("Do you wish to CANCEL editing this form and close it?", vbYesNo, "Cancel and Close") = vbNo Then Exit Sub 
110         If Me.Dirty Then 
111            Me.Undo 
112         End If 
113     
114         DoCmd.Close acForm, Me.Name 
115     
116      End Sub 
      Goto Top       Goto Form_fc_pop_Appointment       Goto Index

cmd_OK_Click (23)

117     
118      Private Sub cmd_OK_Click() 
119       '140211, 17
120      On Error Resume Next 
121         If Me.Dirty Then 
122             'data validation will be done
123            Me.Dirty = False 
124         End If 
125     
126         If Me.Dirty Then 
127             'MsgBox "Click Cancel to Close without Saving", , "Not OK"
128             'Exit Sub
129             'record was not saved
130             'Me.Undo
131         End If 
132         DoCmd.Close acForm, Me.Name, acSaveNo 
133      End Sub 
134     
135     
136     
137     
138     
139     
      Goto Top       Goto Form_fc_pop_Appointment       Goto Index

Form_fc_Popup_AddContact (302)

PROCEDURES       Goto Top       Goto Form_fc_Popup_AddContact       Goto Forms       Goto Index
  1. cmd_Cancel_Click (13)
  2. cmd_OK_Click (17)
  3. Declaration Lines (33)
  4. Form_AfterUpdate (57)
  5. Form_BeforeUpdate (167)
  6. MarkHuman (15)

Declaration Lines (33)

1        Option Compare Database     'Use database order for string comparisons 
2        Option Explicit 
3         '=======================================================
4         '
5         ' code behind form:  fPopup_AddContact
6         '
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, 140629
28        ' ~ Crystal
29        '              * have an awesome day :)
30        '                                                   www.AccessMVP.com/strive4peace
31        ' END LICENSE NOTICE
32        '============================================================
33        '-------------------------------------------------------------------- FORM
      Goto Top       Goto Form_fc_Popup_AddContact       Goto Index

Form_AfterUpdate (57)

34      
35       Private Sub Form_AfterUpdate() 
36        '140212, 216, 140416, 140422
37           'CALLS
38           '  rSql
39           '  Set_Property -- local_CID
40      
41          Dim nCID As Long _ 
42             , sSQL As String _ 
43             , sTablename As String _ 
44             , sFieldname As String 
45      
46          nCID = Me.CID 
47          Call Set_Property("local_CID", nCID) 
48      
49           'add Category
50          With Me.cCatIDc 
51             If Not IsNull(.Value) Then 
52                sTablename = .Column(2) 
53                sFieldname = .Column(3) 
54                sSQL = "INSERT INTO c_CtcCat ( cCatID, CID )" _ 
55                   & " SELECT " & .Value _ 
56                   & ", " & nCID & " AS CID" _ 
57                   & ";" 
58                Call rSql(sSQL) 
59                 'add record in related CID table
60                sSQL = "INSERT INTO " & sTablename & "( CID, " & sFieldname & ")" _ 
61                   & " SELECT " & nCID & " AS CID" _ 
62                   & ", """ & Replace(Me.txtFullname, """", """""") & """" _ 
63                   & ";" 
64                Call rSql(sSQL) 
65             End If 
66          End With   'cCatIDc 
67      
68      
69      
70      
71      
72           'add List
73          With Me.ListID 
74             If Not IsNull(.Value) Then 
75                sSQL = "INSERT INTO c_ListMbr ( ListID, CID )" _ 
76                   & " SELECT " & .Value _ 
77                   & ", " & nCID & " AS CID" _ 
78                   & ";" 
79                Call rSql(sSQL) 
80             End If 
81          End With   'ListID 
82      
83          CurrentDb.TableDefs.Refresh 
84          DoEvents 
85      
86        '   Call FindTheContact(nCID)
87      
88        '   DoCmd.Close acForm, Me.Name 'chances are it won't come back here
89      
90       End Sub 
      Goto Top       Goto Form_fc_Popup_AddContact       Goto Index

Form_BeforeUpdate (167)

91      
92       Private Sub Form_BeforeUpdate(Cancel As Integer) 
93        '140213, 216, 140422
94      
95           'CALLS
96           '  Set_Property
97      
98          On Error GoTo Proc_Err 
99      
100         Dim db As DAO.Database _ 
101            , rs As DAO.Recordset 
102     
103         Dim sNameA As String _ 
104            , sMainName As String _ 
105            , sWord_MainName As String _ 
106            , nCID As Long _ 
107            , nListID As Long _ 
108            , sSQL As String _ 
109            , sMsg As String 
110     
111         If Me.IsHuman Then 
112            sWord_MainName = "Last Name" 
113         Else 
114            sWord_MainName = "Company" 
115         End If 
116     
117         sNameA = "" 
118         With Me.NameA 
119            If IsNull(.Value) Then 
120               If Me.IsHuman Then 
121                  Select Case MsgBox("First Name must have a value" _ 
122                     & vbCrLf & "OK to Continue Editing " _ 
123                     & vbCrLf & "Cancel to UNDO and CLOSE " _ 
124                        , vbOKCancel + vbDefaultButton2 _ 
125                        , "Missing Data. Continue Editing?") 
126                  Case vbCancel 
127                     Me.Undo 
128                     Cancel = True 
129                     DoCmd.Close acForm, Me.Name 
130                  Case vbOK 
131                     Cancel = True 
132                  End Select 
133                  Exit Sub 
134               End If 
135            Else 
136               sNameA = .Value 
137            End If 
138         End With 
139     
140         With Me.MainName 
141            If IsNull(.Value) Then 
142              Select Case MsgBox("MainName/Company Name must have a value" _ 
143                  & vbCrLf & "OK to Continue Editing " _ 
144                  & vbCrLf & "Cancel to UNDO and CLOSE " _ 
145                     , vbOKCancel + vbDefaultButton2 _ 
146                     , "Missing Data. Continue Editing?") 
147               Case vbCancel 
148                  Me.Undo 
149                  Cancel = True 
150                  DoCmd.Close acForm, Me.Name 
151               Case vbOK 
152                  Cancel = True 
153               End Select 
154               Exit Sub 
155            Else 
156               sMainName = .Value 
157            End If 
158         End With 
159     
160         Set db = CurrentDb 
161     
162         sSQL = "" 
163         sMsg = "" 
164     
165         If sNameA = "" Then 
166             'just check company
167            sSQL = "SELECT c.* " _ 
168               & " FROM c_Contact c " _ 
169               & " WHERE c.MainName='" & Replace(sMainName, "'", "''") & "'" 
170         Else 
171             'check if same NameA and MainName is already in Contacts
172            sSQL = "SELECT c.* " _ 
173               & " FROM c_Contact c " _ 
174               & " WHERE trim(c.NameA)='" & Trim(Replace(sNameA, "'", "''")) _ 
175               & "' AND trim(c.MainName)='" & Trim(Replace(sMainName, "'", "''")) & "'" 
176         End If 
177     
178         sSQL = sSQL & " AND c.CID <> " & Me.CID & ";" 
179     
180         Set rs = db.OpenRecordset(sSQL, dbOpenSnapshot) 
181         If rs.EOF Then 
182            rs.Close 
183            Set rs = Nothing 
184         Else 
185            sMsg = "Is this Contact the same?" 
186     
187             'add person information to the message
188            With rs 
189               If Not .EOF Then 
190                  sMsg = sNameA & " " & sMainName & " FOUND on another record " & vbCrLf 
191                  If Not IsNull(!NameA) Then 
192                     sMsg = sMsg & vbCrLf & Space(5) & "First Name: " & !NameA 
193                  End If 
194                  If Not IsNull(!NickName) Then 
195                     sMsg = sMsg & vbCrLf & Space(5) & "Nick Name: " & !NickName 
196                  End If 
197                  If Not IsNull(!NameB) Then 
198                     sMsg = sMsg & vbCrLf & Space(5) & "Middle Name: " & !NameB 
199                  End If 
200                  sMsg = sMsg & vbCrLf & Space(5) & sWord_MainName & ": " & !MainName 
201     
202                  If Not IsNull(!Sufx) Then 
203                     sMsg = sMsg & vbCrLf & Space(5) & "Suffix: " & !Sufx 
204                  End If 
205                  nCID = !CID 
206                  sMsg = sMsg & vbCrLf & Space(5) & "CID: " & !Sufx 
207     
208               End If 
209               .Close 
210            End With 
211            Set rs = Nothing 
212     
213             'display message and process the choice
214             'is this a DIFFERENT person
215     
216            sMsg = sMsg & vbCrLf _ 
217                  & vbCrLf & "YES = Undo and FIND record.  New Contact is same" _ 
218                  & vbCrLf & "No = ADD.  New Contact is different" _ 
219                  & vbCrLf & "Cancel and continue changing New Contact information" 
220     
221            Select Case MsgBox(sMsg _ 
222                  , vbYesNoCancel + vbDefaultButton1 _ 
223                  , "Is New Contact Different") 
224            Case vbCancel 
225               Cancel = True 
226               GoTo Proc_Exit 
227            Case vbNo 
228               Me.Undo 
229               Cancel = True 
230                ' find Contact
231               Call Set_Property("local_CID", nCID) 
232               GoTo Proc_Exit 
233            End Select 
234         End If 
235     
236      UpdateTheRecord: 
237     
238         Me.dtmEdit = Now() 
239     
240      Proc_Exit: 
241         On Error Resume Next 
242          'release object variables
243         If Not rs Is Nothing Then 
244            rs.Close 
245            Set rs = Nothing 
246         End If 
247         Set db = Nothing 
248         Exit Sub 
249     
250      Proc_Err: 
251         MsgBox Err.Description, , _ 
252              "ERROR " & Err.Number _ 
253              & "   Form_BeforeUpdate : " & Me.Name 
254     
255         Resume Proc_Exit 
256         Resume 
257      End Sub 
      Goto Top       Goto Form_fc_Popup_AddContact       Goto Index

cmd_Cancel_Click (13)

258     
259       '-------------------------------------------------------------------- buttons
260     
261      Private Sub cmd_Cancel_Click() 
262       '140211, 17
263         If MsgBox("Do you wish to CANCEL editing this form and close it?", vbYesNo, "Cancel and Close") = vbNo Then Exit Sub 
264         If Me.Dirty Then 
265            Me.Undo 
266         End If 
267     
268         DoCmd.Close acForm, Me.Name 
269     
270      End Sub 
      Goto Top       Goto Form_fc_Popup_AddContact       Goto Index

cmd_OK_Click (17)

271     
272      Private Sub cmd_OK_Click() 
273       '140211, 17
274      On Error Resume Next 
275         If Me.Dirty Then 
276             'data validation will be done
277            Me.Dirty = False 
278         End If 
279     
280         If Me.Dirty Then 
281             'MsgBox "Click Cancel to Close without Saving", , "Not OK"
282             'Exit Sub
283             'record was not saved
284             'Me.Undo
285         End If 
286         DoCmd.Close acForm, Me.Name, acSaveNo 
287      End Sub 
      Goto Top       Goto Form_fc_Popup_AddContact       Goto Index

MarkHuman (15)

288     
289     
290      Private Function MarkHuman() 
291       '140416 -- called by AfterUpdate of NameA, middle name, nick name, Gender
292         With Me 
293            If IsNull(.ActiveControl) Then Exit Function 
294            If Not .IsHuman Then .IsHuman = True 
295         End With 
296     
297      End Function 
298     
299     
300     
301     
302     
      Goto Top       Goto Form_fc_Popup_AddContact       Goto Index

Form_fc_Tables (67)

PROCEDURES       Goto Top       Goto Form_fc_Tables       Goto Forms       Goto Index
  1. cmd_Design_Click (33)
  2. Declaration Lines (2)
  3. FldAuto_combo_AfterUpdate (6)
  4. FldRoll_combo_AfterUpdate (6)
  5. Form_Current (16)
  6. Tbl_AfterUpdate (4)

Declaration Lines (2)

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

cmd_Design_Click (33)

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 cmd_Design_Click() 
30        '131001
31          Dim sTablename As String 
32          If IsNull(Me.Tbl) Then Exit Sub 
33          sTablename = Me.Tbl 
34          DoCmd.OpenTable sTablename, acViewDesign 
35       End Sub 
      Goto Top       Goto Form_fc_Tables       Goto Index

FldAuto_combo_AfterUpdate (6)

36      
37       Private Sub FldAuto_combo_AfterUpdate() 
38        '131001
39          If IsNull(Me.ActiveControl) Then Exit Sub 
40          Me.FldAuto.Value = Me.FldAuto_combo 
41       End Sub 
      Goto Top       Goto Form_fc_Tables       Goto Index

FldRoll_combo_AfterUpdate (6)

42      
43       Private Sub FldRoll_combo_AfterUpdate() 
44        '131001
45          If IsNull(Me.ActiveControl) Then Exit Sub 
46          Me.FldRoll.Value = Me.FldRoll_combo 
47       End Sub 
      Goto Top       Goto Form_fc_Tables       Goto Index

Form_Current (16)

48      
49       Private Sub Form_Current() 
50        '131001
51          If Not IsNull(Me.Tbl) Then 
52             Me.FldAuto_combo.RowSource = Me.Tbl 
53             Me.FldRoll_combo.RowSource = Me.Tbl 
54             Me.FldAuto_combo.Value = Me.FldAuto 
55             Me.FldRoll_combo.Value = Me.FldRoll 
56          Else 
57             Me.FldAuto_combo.RowSource = "" 
58             Me.FldRoll_combo.RowSource = "" 
59             Me.FldAuto_combo.Value = Null 
60             Me.FldRoll_combo.Value = Null 
61          End If 
62      
63       End Sub 
      Goto Top       Goto Form_fc_Tables       Goto Index

Tbl_AfterUpdate (4)

64      
65       Private Sub Tbl_AfterUpdate() 
66          Call Form_Current 
67       End Sub 
      Goto Top       Goto Form_fc_Tables       Goto Index

Form_fc_templateAnywhere (37)

PROCEDURES       Goto Top       Goto Form_fc_templateAnywhere       Goto Forms       Goto Index
  1. Declaration Lines (2)
  2. Form_BeforeUpdate (30)
  3. Form_Open (5)

Declaration Lines (2)

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

Form_BeforeUpdate (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_BeforeUpdate(Cancel As Integer) 
30        '131009
31          Call FormBeforeUpdate(Me) 
32       End Sub 
      Goto Top       Goto Form_fc_templateAnywhere       Goto Index

Form_Open (5)

33      
34       Private Sub Form_Open(Cancel As Integer) 
35        '131009
36          Me.cmd_Close.Visible = Not IsSubform(Me) 
37       End Sub 
      Goto Top       Goto Form_fc_templateAnywhere       Goto Index

Form_fc_ViewAddress_sub (44)

PROCEDURES       Goto Top       Goto Form_fc_ViewAddress_sub       Goto Forms       Goto Index
  1. cmd_Edit_Click (31)
  2. Declaration Lines (2)
  3. Form_Open (11)

Declaration Lines (2)

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

cmd_Edit_Click (31)

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       Private Sub cmd_Edit_Click() 
31        '131219
32          MsgBox "Edit Address" 
33       End Sub 
      Goto Top       Goto Form_fc_ViewAddress_sub       Goto Index

Form_Open (11)

34      
35       Private Sub Form_Open(Cancel As Integer) 
36        '101010, 131219
37      
38          On Error Resume Next 
39          Dim nCID As Long 
40          nCID = Get_Property("local_CID") 
41      
42       End Sub 
43      
44      
      Goto Top       Goto Form_fc_ViewAddress_sub       Goto Index

Form_fc_Websites_sub (261)

PROCEDURES       Goto Top       Goto Form_fc_Websites_sub       Goto Forms       Goto Index
  1. cmd_Add_Click (7)
  2. cmd_Del_Click (6)
  3. Declaration Lines (49)
  4. Form_BeforeUpdate (89)
  5. GotoWebsite (34)
  6. TypID_NotInList (20)
  7. URL_DblClick (56)

Declaration Lines (49)

1        Option Compare Database 
2        Option Explicit 
3         '
4         '=======================================================
5         ' fc_Websites_Sub
6         ' CONTACT MANAGEMENT APPLET: licensed to 
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, 140629
28        ' ~ Crystal
29        '              * have an awesome day :)
30        '                                                   www.AccessMVP.com/strive4peace
31        ' END LICENSE NOTICE
32        '============================================================
33        ' CALLS
34        '
35        '   RecordNew
36        '   RecordDelete
37        '   ' popNotes
38        '   FormBeforeUpdate
39        '   ' ' TypeID_NIL
40        '   FormNoAdditions
41        '   ' SetHighlightBox
42        '   ' ClickHighlightBox
43        '
44        '=======================================================
45        '3-20-09
46        '
47       Dim mDirty As Boolean _ 
48          , mDirtyCustomer As Boolean _ 
49          , nUsrCatID As Long 
      Goto Top       Goto Form_fc_Websites_sub       Goto Index

cmd_Add_Click (7)

50      
51      
52       Private Sub cmd_Add_Click() 
53        '3-20-09
54          On Error Resume Next 
55          RecordNew Me, "URL" 
56       End Sub 
      Goto Top       Goto Form_fc_Websites_sub       Goto Index

cmd_Del_Click (6)

57      
58       Private Sub cmd_Del_Click() 
59        '3-20-09
60          On Error Resume Next 
61          RecordDelete Me, "URL" 
62       End Sub 
      Goto Top       Goto Form_fc_Websites_sub       Goto Index

TypID_NotInList (20)

63      
64      
65       Private Sub TypID_NotInList( _ 
66          NewData As String, _ 
67          Response As Integer) 
68        '101010
69          On Error Resume Next 
70      
71           ' crystal (strive4peace)
72          Dim sTblNm As String _ 
73            , sFldNm As String _ 
74            , nTID As Long 
75      
76          sTblNm = "c_WebType" 
77          sFldNm = "TypWeb" 
78          nTID = 0 
79      
80          Response = GetResponse_NIL(NewData, sTblNm, sFldNm, nTID, "Address Type") 
81      
82       End Sub 
      Goto Top       Goto Form_fc_Websites_sub       Goto Index

URL_DblClick (56)

83      
84       Private Sub URL_DblClick(Cancel As Integer) 
85          On Error GoTo Proc_Err 
86      
87          Dim mPos As Integer _ 
88             , mStr As String 
89      
90          If Me.Dirty Then Me.Dirty = False 
91      
92          GotoWebsite 
93      
94       Proc_Exit: 
95          Exit Sub 
96      
97       Proc_Err: 
98          Select Case Err.Number 
99           'invalid url
100         Case 5: 
101            If InStr(Me.URL, "www") = 0 Then 
102               mPos = InStr(Me.URL, "//") + 1 
103               If mPos = 1 Then 
104                  MsgBox "Invalid URL", , "Cannot go to site" 
105                  Resume Proc_Exit 
106               End If 
107               mStr = Left(Me.URL, mPos) _ 
108                        & "www." _ 
109                        & Mid(Me.URL, mPos + 1) 
110     
111               Select Case MsgBox("Add www to URL?" _ 
112                  & vbCrLf & vbCrLf _ 
113                  & " --> " & mStr _ 
114                  , vbYesNo _ 
115                  , "Invalid URL") 
116               Case vbYes 
117                  Me.URL = mStr 
118               End Select 
119               Resume Proc_Exit 
120            Else 
121               MsgBox "INVALID URL: " & Me.URL _ 
122                  & vbCrLf & vbCrLf, , _ 
123                    "Cannot Go To URL" 
124               Resume Proc_Exit 
125            End If 
126            End Select 
127     
128         MsgBox "INVALID URL: " & Me.URL _ 
129            & vbCrLf & vbCrLf & Err.Description, , _ 
130              "ERROR " & Err.Number _ 
131              & "   goto URL" 
132     
133         Resume Proc_Exit 
134     
135          'if you want to single-step code to find error, CTRL-Break at MsgBox
136          'then set this to be the next statement
137         Resume 
138      End Sub 
      Goto Top       Goto Form_fc_Websites_sub       Goto Index

Form_BeforeUpdate (89)

139     
140      Private Sub Form_BeforeUpdate(Cancel As Integer) 
141       '3-20-09
142          'set up Error Handler
143         On Error GoTo Proc_Err 
144     
145       '110101 TONY
146      Dim mAnswer As Long 
147     
148         mAnswer = AskSaveTheChanges("URL" _ 
149            , Nz(Me.URL, "")) 
150         Select Case mAnswer 
151            Case vbCancel 
152               Me.Undo 
153               Cancel = True 
154            Case vbNo 
155               Cancel = True 
156            Case vbYes 
157                'update tracking fields
158               On Error Resume Next 
159               FormBeforeUpdate Me, True 
160            Case Else 
161       '         MsgBox mAnswer
162         End Select 
163     
164     
165         Dim s As String 
166     
167         If InStr(Me.URL, "\\") > 0 Then 
168            Me.URL = Replace(Me.URL, "\\", "//") 
169         End If 
170     
171         If InStr(Me.URL, "//") = 0 Then 
172            Select Case MsgBox(Me.URL & " is not valid" & vbCrLf & vbCrLf _ 
173               & "You must start the URL with Http:// or Ftp:// or other acceptable Web Prefix" _ 
174               & vbCrLf & vbCrLf & "YES to automatically fix Web Address by adding --> http://" _ 
175               & vbCrLf & vbCrLf & "NO to fix Web Address yourself" _ 
176               & vbCrLf & vbCrLf & "CANCEL to undo the record" _ 
177               , vbYesNoCancel _ 
178               , "URL not valid") 
179            Case vbYes 
180               Me.URL = "http://" & Trim(Me.URL) 
181            Case vbNo 
182               Cancel = True 
183               Exit Sub 
184            Case vbCancel 
185               Me.Undo 
186               Cancel = True 
187               Exit Sub 
188            End Select 
189         End If 
190     
191       '   s = "SELECT * FROM ref_WebPrefixes WHERE IsActive;"
192       '
193       '   Set r = DBEngine(0)(0).OpenRecordset(s, dbOpenSnapshot)
194       '
195       '   Do While Not r.EOF
196       '      If Left(Me.URL, Len(r!webprefix)) = r!webprefix Then GoTo TestPeriod
197       '      r.MoveNext
198       '   Loop
199     
200     
201      TestPeriod: 
202         If InStr(Me.URL, ".") = 0 Then 
203            If MsgBox("Web Address is not valid, must contain a period" _ 
204               , vbOKCancel, "OK to Fix Web Address or Cancel to cancel Record") = vbCancel Then 
205                  Me.Undo 
206            End If 
207            Cancel = True 
208            GoTo Proc_Exit 
209         End If 
210     
211      URL_okay: 
212     
213      Proc_Exit: 
214         On Error Resume Next 
215       '   r.Close
216       '   Set r = Nothing
217         Exit Sub 
218     
219      Proc_Err: 
220         MsgBox Err.Description, , _ 
221              "ERROR " & Err.Number _ 
222              & "   Web BeforeUpdate" 
223     
224         Resume Proc_Exit 
225         Resume 
226     
227      End Sub 
      Goto Top       Goto Form_fc_Websites_sub       Goto Index

GotoWebsite (34)

228     
229     
230      Sub GotoWebsite() 
231       '9-10-08
232         Dim mWeb As String 
233     
234         If Me.Dirty Then Me.Dirty = False 
235         If IsNull(Me.URL) Then 
236            MsgBox "URL is not filled out", , "Cannot go to to website" 
237            Exit Sub 
238         End If 
239         mWeb = Trim(Me.URL) 
240     
241         If InStr(mWeb, "//") = 0 Then 
242            MsgBox "Web Address is not valid", , "Cannot go to website" 
243            Exit Sub 
244         End If 
245         Application.FollowHyperlink mWeb 
246     
247      Proc_Exit: 
248         Exit Sub 
249     
250      Proc_Err: 
251     
252         MsgBox "INVALID URL: " & mWeb _ 
253            & vbCrLf & vbCrLf & Err.Description, , _ 
254              "ERROR " & Err.Number _ 
255              & "   GotoWebsite" 
256     
257         Resume Proc_Exit 
258         Resume 
259     
260      End Sub 
261     
      Goto Top       Goto Form_fc_Websites_sub       Goto Index

Form_usys_f_PickUser__NOTUSED (94)

PROCEDURES       Goto Top       Goto Form_usys_f_PickUser__NOTUSED       Goto Forms       Goto Index
  1. cdmClose_Click (30)
  2. cmd_NavigationPane_Click (5)
  3. cmdExit_Click (5)
  4. Declaration Lines (2)
  5. Form_Load (11)
  6. Form_Open (16)
  7. UsrID_AfterUpdate (16)
  8. UsrID_BeforeUpdate (9)

Declaration Lines (2)

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

cdmClose_Click (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 cdmClose_Click() 
30        '110519
31          DoCmd.Close acForm, Me.Name, acSaveNo 
32       End Sub 
      Goto Top       Goto Form_usys_f_PickUser__NOTUSED       Goto Index

cmd_NavigationPane_Click (5)

33      
34       Private Sub cmd_NavigationPane_Click() 
35        '110913
36          UnHideDBWindow 
37       End Sub 
      Goto Top       Goto Form_usys_f_PickUser__NOTUSED       Goto Index

cmdExit_Click (5)

38      
39       Private Sub cmdExit_Click() 
40        '110519
41          Application.Quit 
42       End Sub 
      Goto Top       Goto Form_usys_f_PickUser__NOTUSED       Goto Index

Form_Load (11)

43      
44       Private Sub Form_Load() 
45        '110918
46          Dim nUsrID As Long 
47          nUsrID = Get_Property("local_UserID") 
48          If nUsrID = -1 Then 
49              'not going to do anything
50          Else 
51             Me.UsrID = nUsrID 
52          End If 
53       End Sub 
      Goto Top       Goto Form_usys_f_PickUser__NOTUSED       Goto Index

Form_Open (16)

54      
55       Private Sub Form_Open(Cancel As Integer) 
56        '130831
57          Call Custom_SetDefaultProperties 
58           'see if user is known
59      
60      
61           'if not, let user fill form
62      
63      
64      
65           'see if tables are connected
66      
67           'see if connection is right for user
68      
69       End Sub 
      Goto Top       Goto Form_usys_f_PickUser__NOTUSED       Goto Index

UsrID_AfterUpdate (16)

70      
71       Private Sub UsrID_AfterUpdate() 
72        '110918
73          Dim nUsrID As Long _ 
74             , nUsrCatID As Long _ 
75             , sUserName As String 
76      
77             nUsrID = Me.UsrID 
78        '      nUsrCatID = Me.UsrID.Column(2)
79             sUserName = Me.UsrID.Column(1) 
80      
81             Set_Property "local_UserID", nUsrID 
82        '      Set_Property "local_UsrCatID", nUsrCatID
83             Set_Property "local_UserName", sUserName 
84      
85       End Sub 
      Goto Top       Goto Form_usys_f_PickUser__NOTUSED       Goto Index

UsrID_BeforeUpdate (9)

86      
87       Private Sub UsrID_BeforeUpdate(Cancel As Integer) 
88        '110918
89          If IsNull(Me.ActiveControl) Then 
90             MsgBox "you must choose an Author -- or REPORTS" _ 
91                , , "Author must be filled" 
92             Cancel = True 
93          End If 
94       End Sub 
      Goto Top       Goto Form_usys_f_PickUser__NOTUSED       Goto Index

Form_usys_fPw (52)

PROCEDURES       Goto Top       Goto Form_usys_fPw       Goto Forms       Goto Index
  1. cmd_Cancel_Click (30)
  2. cmd_OK_Click (8)
  3. Declaration Lines (2)
  4. Form_Open (12)

Declaration Lines (2)

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

cmd_Cancel_Click (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 cmd_Cancel_Click() 
30        '110522
31          DoCmd.Close acForm, Me.Name, acSaveNo 
32       End Sub 
      Goto Top       Goto Form_usys_fPw       Goto Index

cmd_OK_Click (8)

33      
34       Private Sub cmd_OK_Click() 
35        '110522
36      
37          Set_Property "local_Password", Nz(Me.txtPassword, "INVALID") 
38      
39          DoCmd.Close acForm, Me.Name, acSaveNo 
40       End Sub 
      Goto Top       Goto Form_usys_fPw       Goto Index

Form_Open (12)

41      
42       Private Sub Form_Open(Cancel As Integer) 
43        '110522
44          Dim sStr As String 
45      
46          sStr = Get_Property("local_title") 
47          If Len(Trim(sStr)) > 0 Then 
48             Me.Label_Title.Caption = sStr 
49          Else 
50             Me.Label_Title.Caption = "Password" 
51          End If 
52       End Sub 
      Goto Top       Goto Form_usys_fPw       Goto Index

Modules

  1. bas_crystal_code_general_1308 (2,724)
  2. bas_Crystal_Properties_0806_130410_0429 (628)
  3. bas_Crystal_ReLinker_140629_080726_1001 (1,250)
  4. bas_Crystal_RunSQL_130522 (336)
  5. bas_PleaseWait (47)
  6. bas_RenameControls_ActiveFormReport (172)
  7. mod_crystal_DataDICTIONARY_DisplayControl (613)
  8. mod_crystal_GetFile_Browse (157)
  9. mod_DocumentQueryCalculatedFields_Crystal (284)
  10. mod_helper_HTMLcalendar (653)
  11. mod_local_Anywhere (880)
  12. mod_local_Contacts (463)
  13. mod_local_ui (266)
  14. mod_PlaySound (33)
  15. mod_SaveCSVasExcel (135)
  16. mod_SubDatasheet (105)
  17. mod_TerryKreft_API_Clipboard_Copy_Paste (208)
  18. mod_UI (789)
Goto END of Modules       Goto Top       Goto Index

bas_crystal_code_general_1308 (2724)

PROCEDURES       Goto Top       Goto bas_crystal_code_general_1308       Goto Modules       Goto Index
  1. AddFieldDesc (69)
  2. AddFieldToTable (140)
  3. BoldMe (208)
  4. CancelMe (11)
  5. CapString (14)
  6. ClearList (17)
  7. CloseMe (46)
  8. CorrectName (85)
  9. CorrectProper (23)
  10. Declaration Lines (69)
  11. DoesControlExistOnForm (21)
  12. DoesExist (56)
  13. DoesExistDelete (60)
  14. DropMe (31)
  15. DropMeIfNull (13)
  16. EMailReport (74)
  17. ExitAccess (9)
  18. FindRecordN (111)
  19. GetAge (16)
  20. GetBirthday (14)
  21. GetCurrentPath (16)
  22. IsLoadedForm (28)
  23. IsLoadedReport (27)
  24. IsSubform (17)
  25. IsTable (20)
  26. IsValidURL (38)
  27. ListIndexes (19)
  28. listQuerySQL (21)
  29. LoopAndCombine (97)
  30. LoopCombineVar (82)
  31. MakeADirectory (44)
  32. MakeAPath (48)
  33. MakeMyQuery (67)
  34. open_Form (25)
  35. open_Form_Filter (22)
  36. open_Query (14)
  37. open_Report (21)
  38. ProperCase (45)
  39. RecordDelete (60)
  40. RecordFirst (28)
  41. RecordLast (25)
  42. RecordNew (45)
  43. RecordNext (28)
  44. RecordPrev (27)
  45. RenameTrackingFields (47)
  46. RequeryMe (21)
  47. ResetStuff (14)
  48. RunAddFieldsToTable_Tracking (138)
  49. RunLoopAndCombine (16)
  50. RunLoopCombineVar (20)
  51. SetGBlockDrop (11)
  52. SetRecordSource (59)
  53. SetReportFilter (114)
  54. ShowHideControls (59)
  55. Sort123 (112)
  56. TableHasField (46)
  57. Update_dtmEdit_to_dtmAdd (68)
  58. UpperCase (27)
  59. ZoomMe (21)

Declaration Lines (69)

1        Option Compare Database    'comparison default --> ABC=abc 
2        Option Explicit    'require variable declaration -- always a good practice 
3         '
4         '=======================================================
5         '
6         ' module name: bas_crystal_code_general_1308
7         '
8         '============================================================ LICENSE NOTICE -- must not be modified
9         ' This software is licensed to you under CC BY-NC-SA 3.0
10        '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
11        ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
12        '
13        ' You are free to:
14        '    Share — copy and redistribute the material in any medium or format
15        '    Adapt — remix, transform, and build upon the material
16        ' The licensor cannot revoke these freedoms as long as you follow these terms:
17        '    Attribution — You must give appropriate credit, provide a link to the license,
18        '                   and indicate if changes were made.
19        '                   You may do so in any reasonable manner,
20        '                   but not in any way that suggests the licensor endorses you or your use.
21        '    NonCommercial — You may not use the material for commercial purposes.
22        '    ShareAlike — If you remix, transform, or build upon the material,
23        '                 you must distribute your contributions under the same license as the original.
24        '
25        ' many procedures and module names contain author or controbitor names that must be left intact
26        ' if you make changes, add your name, date, and descriptive information to the comments
27        '
28        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629
29        ' ~ Crystal
30        '              * have an awesome day :)
31        '                                                   www.AccessMVP.com/strive4peace
32        ' END LICENSE NOTICE
33        '============================================================
34        '
35        '  includes code written by Brent Spauling (datAdrenaline)
36        '     IsTable
37        '
38        ' categories of procedures:
39        '   FORMS
40        '   OPEN OBJECTS
41        '   REPORTS
42        '   EMAIL
43        '   MAKE OBJECTS
44        '   DATA STRUCTURE
45        '   LIST OBJECTS
46        '   TEST OBJECTS
47        '   CONTROLS
48        '   STRING
49        '   NUMERIC
50        '   DATE
51        '   APPLICATION
52        '   DIRECTORIES
53        '
54        ' NEEDS REFERENCE to -->
55           'a Microsoft DAO Library
56           ' -- OR --
57           ' Microsoft Office 12.0 Access Database Engine Object Library
58        '=======================================================
59        ' modified 4-11-09
60        ' 5-12-09 c_ tables
61        ' 5-18-09 RunAddFieldsToTable_Tracking -- DefaultValue for dtmEdit
62        ' 12-3-09 dbFailOnError
63        ' 12-3 Microsoft Office 12.0 Access Database Engine Object Library
64        '
65        '110323 removed GetDataType
66        '130304 DoesExist
67        '130417 MakeMyQuery, 130418 BoldMe
68      
69       Dim gBlockDrop As Boolean 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

CancelMe (11)

70      
71        '===================================================== FORMS
72        '~~~~~~~~~~~~~~~~~~~~~~~~~~ CancelMe
73       Function CancelMe() As Byte 
74        ' Crystal (strive4peace)
75           'example useage: OnClick event of an Undo command button
76           ' = CancelMe()
77           'if there is nothing to Undo, this will create an error -- just ignore
78         On Error Resume Next 
79         DoCmd.RunCommand acCmdUndo 
80       End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

CloseMe (46)

81      
82      
83        '~~~~~~~~~~~~~~~~~~~~~~~~~~ CloseMe
84       Function CloseMe(pF As Form _ 
85          , Optional booSave As Boolean = False _ 
86          , Optional pFormOpen As String = "" _ 
87          ) As Byte 
88        ' Crystal (strive4peace)
89        ' 8-17-08, 12-1 pOpenForm, 12-19 dirty, 4-9-09
90      
91           'close a form
92           'example useage: [Event Procedure] of a Close command button
93           '   CloseMe
94           '   CloseMe Me
95           ' close form and save changes
96           '   CloseMe Me, true
97           ' close form and open/switch to another
98           '   CloseMe Me,, "OtherFormname"
99      
100         On Error GoTo Proc_Err 
101     
102         If Len(pF.RecordSource) > 0 Then If pF.Dirty Then _ 
103            pF.Dirty = False 
104     
105         DoCmd.Close acForm, pF.Name _ 
106            , IIf(booSave, acSaveYes, acSaveNo) 
107     
108         If pFormOpen <> "" Then 
109            If CurrentProject.AllForms(pFormOpen).IsLoaded Then 
110              Forms(pFormOpen).Visible = True 
111              DoCmd.SelectObject acForm, pFormOpen 
112            Else 
113               DoCmd.OpenForm pFormOpen 
114            End If 
115         End If 
116     
117      Proc_Exit: 
118         On Error Resume Next 
119         Exit Function 
120     
121      Proc_Err: 
122       '   MsgBox Err.Number & " " & Err.Description _
123            , , "Cannot close right "
124         Resume Proc_Exit 
125      End Function 
126       '~~~~~~~~~~~~~~~~~~~~~~~
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

RecordFirst (28)

127     
128       '~~~~~~~~~~~~~~~~~~~~~~~~~~ RecordFirst
129      Function RecordFirst(Optional pF As Form _ 
130         , Optional pFirstControlName As String = "") As Byte 
131       ' Crystal (strive4peace)
132       '3-20-09
133          'example useage: Click [Event Procedure] for a Go To First Record command button
134          ' RecordFirst
135          ' RecordFirst Me
136          ' RecordFirst Me, "Controlname"
137          ' use the optional form parameter for subforms
138     
139         On Error Resume Next 
140         If pF Is Nothing Then Set pF = Screen.ActiveForm 
141     
142          'if there have been changes to the current record, save them
143         If pF.Dirty Then pF.Dirty = False: DoEvents 
144     
145         If pF.Recordset.RecordCount > 0 Then 
146            pF.Recordset.MoveFirst 
147            If pFirstControlName <> "" Then 
148               pF(pFirstControlName).SetFocus 
149            End If 
150     
151         End If 
152     
153         Exit Function 
154      End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

RecordPrev (27)

155     
156       '~~~~~~~~~~~~~~~~~~~~~~~~~~ RecordPrev
157      Function RecordPrev(Optional pF As Form _ 
158         , Optional pFirstControlName As String = "") As Byte 
159       ' Crystal (strive4peace)
160       '3-20-09
161          'example useage: Click [Event Procedure] for a Go To Previous Record command button
162          ' RecordPrev
163          ' RecordPrev Me
164          ' RecordPrev Me, "Controlname"
165          ' use the optional form parameter for subforms
166     
167         On Error Resume Next 
168         If pF Is Nothing Then Set pF = Screen.ActiveForm 
169     
170          'if there have been changes to the current record, save them
171         If pF.Dirty Then pF.Dirty = False: DoEvents 
172     
173         If pF.Recordset.RecordCount > 0 Then 
174            pF.Recordset.Move -1 
175            If pFirstControlName <> "" Then 
176               pF(pFirstControlName).SetFocus 
177            End If 
178     
179         End If 
180     
181      End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

RecordNext (28)

182     
183       '~~~~~~~~~~~~~~~~~~~~~~~~~~ RecordNext
184      Function RecordNext(Optional pF As Form _ 
185         , Optional pFirstControlName As String = "") As Byte 
186       ' Crystal (strive4peace)
187       '3-20-09
188          'example useage: Click [Event Procedure] for a Go To Next Record command button
189          ' RecordNext
190          ' RecordNext Me
191          ' RecordNext Me, "Controlname"
192          ' use the optional form parameter for subforms
193     
194         On Error Resume Next 
195         If pF Is Nothing Then Set pF = Screen.ActiveForm 
196     
197          'if there have been changes to the current record, save them
198         If pF.Dirty Then pF.Dirty = False: DoEvents 
199     
200         If pF.Recordset.RecordCount > 0 Then 
201            pF.Recordset.Move 1 
202            If pFirstControlName <> "" Then 
203               pF(pFirstControlName).SetFocus 
204               DoEvents 
205            End If 
206     
207         End If 
208     
209      End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

RecordLast (25)

210     
211       '~~~~~~~~~~~~~~~~~~~~~~~~~~ RecordLast
212      Function RecordLast(Optional pF As Form _ 
213         , Optional pFirstControlName As String = "") As Byte 
214       ' Crystal (strive4peace)
215       '3-20-09
216          'eexample useage: Click [Event Procedure] for a Go To Last Record command button
217          ' RecordLast
218          ' RecordLast Me
219          ' RecordLast Me, "Controlname"
220     
221         On Error Resume Next 
222         If pF Is Nothing Then Set pF = Screen.ActiveForm 
223     
224          'if there have been changes to the current record, save them
225         If pF.Dirty Then pF.Dirty = False: DoEvents 
226     
227         If pF.Recordset.RecordCount > 0 Then 
228            pF.Recordset.MoveLast 
229            If pFirstControlName <> "" Then 
230               pF(pFirstControlName).SetFocus 
231            End If 
232         End If 
233     
234      End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

RecordNew (45)

235     
236       '~~~~~~~~~~~~~~~~~~~~~~~~~~ RecordNew
237      Function RecordNew(pF As Form _ 
238         , Optional pFirstControlName As String = "") As Byte 
239       ' Crystal (strive4peace)
240       '3-20-09
241     
242          'example useage: Click [Event Procedure] for a New Record command button
243          ' RecordNew
244          ' RecordNew Me
245          ' RecordNew Me, "Controlname"
246     
247         On Error Resume Next 
248         If pF.Dirty Then pF.Dirty = False 
249     
250         On Error GoTo Proc_Err 
251     
252         If Not pF.NewRecord Then 
253            If Not pF.AllowAdditions Then 
254               pF.AllowAdditions = True 
255            End If 
256            pF.Recordset.AddNew 
257         End If 
258     
259         On Error Resume Next 
260         If pFirstControlName <> "" Then 
261            pF(pFirstControlName).SetFocus 
262         End If 
263     
264         DoEvents 
265     
266      Proc_Exit: 
267         Exit Function 
268      Proc_Err: 
269         If Err.Number = 2046 Then 
270             ' already on a new record
271            Exit Function 
272         End If 
273         MsgBox Err.Description, , _ 
274           "ERROR " & Err.Number & "   RecordNew" 
275     
276         Resume Proc_Exit 
277         Resume 
278     
279      End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

RecordDelete (60)

280     
281       '~~~~~~~~~~~~~~~~~~~~~~~~~~ RecordDelete
282       Function RecordDelete(pF As Form _ 
283         , Optional pFirstControlName As String = "" _ 
284         , Optional pDesc As String = "" _ 
285         ) As Byte 
286       ' Crystal (strive4peace)
287       '3-20-09
288          'example useage: Click [Event Procedure] for a Delete Record command button
289          ' RecordDelete
290          ' RecordDelete Me
291          ' RecordDelete Me, [Controlname]
292     
293         On Error GoTo Proc_Err 
294     
295       '   If pF Is Nothing Then Set pF = Screen.ActiveForm
296     
297         If pF.Dirty Then 
298             'user cancelled the record
299            If Not pF.Dirty Then Exit Function 
300            pF.Dirty = False 
301         End If 
302     
303         If pF.NewRecord Then 
304       '      pF.AllowEdits = False
305       '      pF.Requery
306       '      DoEvents
307            Exit Function 
308         End If 
309     
310         If MsgBox("Do you wish to permanently delete " _ 
311            & IIf(pDesc = "", "this record", pDesc) & "?" _ 
312            , vbYesNo + vbDefaultButton2 _ 
313            , "Delete Record?") = vbNo Then Exit Function 
314     
315          'DoEvents
316         DoCmd.SetWarnings False 
317         DoCmd.RunCommand acCmdDeleteRecord 
318         DoCmd.SetWarnings True 
319     
320         ' pF.Recordset.Delete
321     
322         pF.Requery 
323     
324         If pF.Recordset.RecordCount > 0 Then 
325            If pFirstControlName <> "" Then 
326               pF(pFirstControlName).SetFocus 
327            End If 
328         End If 
329     
330      Proc_Exit: 
331         Exit Function 
332      Proc_Err: 
333         If Err.Number = 2101 Then Exit Function 
334         MsgBox Err.Number & " " & Err.Description, , "Cannot delete record" 
335         Resume Proc_Exit 
336     
337         Resume 
338     
339      End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

IsSubform (17)

340     
341       '~~~~~~~~~~~~~~~~~~~~~~~~~~ IsSubform
342      Function IsSubform(pForm As Form) As Boolean 
343       ' Crystal (strive4peace)
344       '8-29-07
345          'return:
346          ' TRUE is specified form reference is being used as a subform
347          ' FALSE if it is not
348     
349          'example useage: in code before parent controls are used
350          'If IsSubform(Me) then ...
351     
352          On Error Resume Next 
353          IsSubform = _ 
354             Not IsError(Len(pForm.Parent.Name) > 0) 
355     
356      End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

Sort123 (112)

357     
358       '~~~~~~~~~~~~~~~~~~~~~~~~~~ Sort123
359      Function Sort123( _ 
360         pF As Form _ 
361         , pField1 As String _ 
362         , Optional pField2 = "" _ 
363         , Optional pField3 = "" _ 
364         ) As Byte 
365       '091203
366     
367          'written by Crystal
368          'strive4peace2010@yahoo.com
369     
370          'sort form by specified field(s)
371          'sending the same sort fields
372          'toggles Ascending and Descending order
373     
374          ' --------------------------------------------------------
375          ' PARAMETERS
376          '  pF = form reference
377          '       if in code behind a form, this is
378          '                   Me
379          '  pField1 -- name of field for first sort
380          '  pField2 -- optional, name of field for second sort
381          '  pField3 -- optional, name of field for third sort
382          '
383          ' --------------------------------------------------------
384          ' NOTES
385          '  you must specify FIELD names in the RecordSource
386          '  control names do not matter
387          ' --------------------------------------------------------
388          '
389          'USEAGE
390          ' commonly called on
391          '     CLICK event of column header label control
392          '
393          ' in code behind form to specify main and secondary sort fields
394          '    Sort123 Me, "Fieldname1", "Fieldname2"
395     
396          'set up Error Handler
397         On Error GoTo Proc_Err 
398     
399          'dimension sort string variables
400          ' for both ascending and descending cases
401         Dim mOrderBy As String _ 
402            , mOrderByZA As String 
403     
404          'initialize the OrderBy string for ascending order
405         mOrderBy = "" 
406     
407          '  assign the first field to the OrderBy string
408         If Len(Trim(pField1)) > 0 Then 
409            mOrderBy = pField1 
410            mOrderByZA = pField1 & " desc" 
411     
412             '  assign the second field to the OrderBy string
413             '  if it is specified
414            If Len(Trim(pField2)) > 0 Then 
415               mOrderBy = (mOrderBy + ", ") & pField2 
416               mOrderByZA = (mOrderByZA + ", ") & pField2 
417            End If 
418     
419             '  assign the third field to the OrderBy string
420             '  if it is specified
421            If Len(Trim(pField3)) > 0 Then 
422               mOrderBy = (mOrderBy + ", ") & pField3 
423               mOrderByZA = (mOrderByZA + ", ") & pField3 
424            End If 
425     
426         Else 
427             ' no sort string specified
428             ' remove OrderBy from the form
429            pF.OrderByOn = False 
430             ' exit the procedure
431            GoTo Proc_Exit 
432         End If 
433     
434          ' use WITH to minimize the number of times
435          ' this code will access the form
436     
437         With pF 
438             ' if the form is already sorted
439             ' by the ascending sort string,
440             ' then change order to be descending
441            If .OrderBy = mOrderBy Then 
442               .OrderBy = mOrderByZA 
443            Else 
444                ' change the sort order to ascending
445                ' if form is not sorted this way
446               If .OrderBy <> mOrderBy Then 
447                  .OrderBy = mOrderBy 
448               End If 
449            End If 
450             ' make the form use the specified sort order
451            .OrderByOn = True 
452         End With 
453     
454      Proc_Exit: 
455         Exit Function 
456     
457      Proc_Err: 
458         MsgBox Err.Description, , _ 
459              "ERROR " & Err.Number _ 
460              & "   Sort123" 
461     
462         Resume Proc_Exit 
463     
464          'if you want to single-step code to find error, CTRL-Break at MsgBox
465          'then set this to be the next statement
466         Resume 
467     
468      End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

FindRecordN (111)

469     
470       '~~~~~~~~~~~~~~~~~~~~~~~~~~ FindRecordN
471       ' usually used by Find combos on forms
472       ' find record given a numeric fieldname and value
473     
474      Function FindRecordN(pF As Form _ 
475         , pKeyFieldname As String _ 
476         , Optional pCtrlName_SetFocus As String = "" _ 
477         , Optional pRecordID = 0 _ 
478         , Optional pbClear As Boolean = True _ 
479         , Optional pbChkIsLoaded As Boolean = False _ 
480         ) As Boolean 
481       '8-17-08, 8-22 pbChkIsLoaded, 12-19-08 comments, 4-5-09 comments
482     
483          'Crystal (strive4peace)
484     
485         'PARAMETERS
486         'pF --> form reference
487         'pKeyFieldname = name of numeric key field
488         'pCtrlName_SetFocus -- name of control to set focus to
489         'pRecordID = numeric value of key field to look up
490         'pbClear -- set control = Null after finding (default = true)
491         'pbChkIsLoaded -- check if form is loaded (default = false)
492     
493          'USEAGE
494          '  on the AfterUpdate [Event Procedure] of a control to find a record (ie: combo or listbox)
495          '   FindRecordN Me, "SoftwareID", "SoftwareName"
496          '
497          ' if you are searching a subform:
498          '   FindRecordN Me.subform_controlname.form, "SoftwareID", "SoftwareName"
499          '
500          ' if you want to find a record, such as you got the ID in code:
501          '   FindRecordN Me, "SoftwareID", "SoftwareName", lngSoftwareID
502          '       by default, if you specify an ID to find,
503          '       the procedure will not attempt to clear any controls
504          '
505          ' if you are finding a record on a form that may not be open:
506          '    FindRecordN Forms!People, "PeopleID", "LastName",,,True
507          '
508          ' if you are want to send a value of the field to search:
509          '   FindRecordN Me, "PID", "Lastname", lngPID
510          '      note: if you are sending a value, the control will not be cleared
511          '
512     
513          'set up Error Handler
514         On Error GoTo Proc_Err 
515     
516         FindRecordN = False 
517     
518         If pbChkIsLoaded Then 
519            If Not IsLoadedForm(pF.Name) Then 
520               Exit Function 
521            End If 
522         End If 
523     
524         If pRecordID = 0 Then 
525             'if nothing is picked in the active control, exit
526            If IsNull(pF.ActiveControl) Then Exit Function 
527             'set value to look up by what is selected
528            pRecordID = pF.ActiveControl 
529             'clear the choice to find
530            If pbClear Then pF.ActiveControl = Null 
531         End If 
532     
533          'make sure form is open
534     
535          'save current record if changes were made
536         If pF.Dirty Then pF.Dirty = False 
537     
538          'find the first value that matches
539         pF.RecordsetClone.FindFirst pKeyFieldname _ 
540            & "= " _ 
541            & pRecordID 
542     
543          'if a matching record was found, then move to it
544         If Not pF.RecordsetClone.NoMatch Then 
545            pF.Bookmark = pF.RecordsetClone.Bookmark 
546            DoEvents 
547         Else 
548       '~~CL~~ need to test this
549            pF.FilterOn = False 
550            DoEvents 
551            pF.Requery 
552            pF.RecordsetClone.FindFirst pKeyFieldname _ 
553               & "= " _ 
554               & pRecordID 
555            pF.Bookmark = pF.RecordsetClone.Bookmark 
556         End If 
557     
558         If pCtrlName_SetFocus <> "" Then 
559             'this fails if controlname is not correctly specified
560            pF(pCtrlName_SetFocus).SetFocus 
561         End If 
562     
563         FindRecordN = True 
564     
565      Proc_Exit: 
566         On Error Resume Next 
567         Exit Function 
568     
569      Proc_Err: 
570         MsgBox Err.Description, , _ 
571              "ERROR " & Err.Number & "   FindRecordN" 
572     
573         Resume Proc_Exit 
574     
575          'if you want to single-step code to find error, CTRL-Break at MsgBox
576          'then set this to be the next statement
577         Resume 
578     
579      End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

open_Form (25)

580     
581       '===================================================== OPEN OBJECTS
582       '~~~~~~~~~~~~~~~~~~~~~~~~~~ Open_Form
583      Function open_Form(pFormName As String _ 
584         , Optional pOpenArgs As String) As Byte 
585       ' Crystal (strive4peace)
586          'Open the the passed Form, optionally send pOpenArgs as Open Arguments
587          'for instance, you may have a form where the user can pick an Address
588          'maybe what they want is not on the list, so you can open the Addresses form
589          'The code behind the Addresses form would:
590          '  capture the ActiveForm.Name in the Open event with a global variable
591          '  requery the passed controlname on the captured formname and fill it out automatically
592          'example useage: OnClick event of an option on a menu (command button, label, etc)
593          ' = Open_Form("Addresses")
594          ' = Open_Form("Addresses", "AddrID")
595         On Error GoTo Proc_Err 
596         If IsMissing(pOpenArgs) Then 
597            DoCmd.OpenForm pFormName 
598         Else 
599            DoCmd.OpenForm pFormName, , , , , , pOpenArgs 
600            End If 
601         Exit Function 
602      Proc_Err: 
603         MsgBox Err.Number & " " & Err.Description, , "Cannot open " & pFormName 
604      End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

open_Form_Filter (22)

605     
606       '~~~~~~~~~~~~~~~~~~~~~~~~~~ open_Form_Filter
607      Function open_Form_Filter(pFormName As String _ 
608         , pFilter As String _ 
609         , Optional pOpenArgs As String) As Byte 
610       ' Crystal (strive4peace)
611          'Open the the passed Form and filter records for specified criteria
612          'optionally with the specified argument in pOpenArgs
613          'example useage: OnClick event of an option on a menu (command button, label, etc)
614          ' = Open_Form("Addresses")
615          ' = Open_Form("Addresses","PeopleID=5")
616          ' = Open_Form("Addresses","State='" & me.PickState & "'","AddrID")
617         On Error GoTo Proc_Err 
618         If IsMissing(pOpenArgs) Then 
619            DoCmd.OpenForm pFormName, , , pFilter 
620         Else 
621            DoCmd.OpenForm pFormName, , , Nz(pFilter, ""), , , pOpenArgs 
622            End If 
623         Exit Function 
624      Proc_Err: 
625         MsgBox Err.Number & " " & Err.Description, , "Cannot open " & pFormName & " with Filter " & Nz(pFilter, "") 
626      End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

open_Query (14)

627     
628       '~~~~~~~~~~~~~~~~~~~~~~~~~~ Open_Query
629      Function open_Query(pQueryName As String) As Byte 
630       ' Crystal (strive4peace)
631          'Open the the passed Query
632          'example useage: OnClick event of a command button, AfterUpdate event of control
633          ' = Open_Query("qry_PhoneList")
634     
635         On Error GoTo Proc_Err 
636         DoCmd.OpenQuery pQueryName 
637         Exit Function 
638      Proc_Err: 
639         MsgBox Err.Number & " " & Err.Description, , "Cannot open " & pQueryName 
640      End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

open_Report (21)

641     
642       '~~~~~~~~~~~~~~~~~~~~~~~~~~ Open_Report
643      Function open_Report(pReportName As String _ 
644         , Optional pWhere As String) As Byte 
645       ' Crystal (strive4peace)
646          'Open the the passed Report
647          'optionally, send arguments to limit the records
648          'example useage: OnClick event of a command button on a report menu form
649          ' = Open_Report("AddressLabels")
650          ' = Open_Report("AddressLabels", "State='NY'")
651     
652         On Error GoTo Proc_Err 
653         If IsMissing(pWhere) Then 
654            DoCmd.OpenReport pReportName, acPreview 
655         Else 
656            DoCmd.OpenReport pReportName, acPreview, , pWhere 
657         End If 
658         Exit Function 
659      Proc_Err: 
660         MsgBox Err.Number & " " & Err.Description, , "Cannot open " & pReportName & "  " & Nz(pWhere, "") 
661      End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

SetRecordSource (59)

662     
663       '===================================================== REPORTS
664       '~~~~~~~~~~~~~~~~~~~~~~~~~~ SetRecordSource
665      Sub SetRecordSource(ByVal pReportName As String _ 
666         , ByVal pSQL As String) 
667     
668          ' written by Crystal
669          ' strive4peace2010@yahoo.com
670     
671          ' PARAMETERS:
672          ' pReportName is the name of your report
673          ' pSQL is an SQL string or tablename or queryname
674     
675          ' USEAGE:
676          '    SetRecordSource "MyReportname","QueryName"
677          '    SetRecordSource "MyAppointments","SELECT * FROM Addresses WHERE City='Denver';"
678     
679         On Error GoTo Proc_Err 
680     
681          '---------- declare variables
682         Dim rpt As Report 
683     
684          '---------- open design view of report in Hidden mode
685         DoCmd.OpenReport pReportName, acViewDesign   ', , , acHidden 
686     
687          '---------- set object variable to report
688         Set rpt = Reports(pReportName) 
689     
690          '---------- replace report RecordSource
691         rpt.RecordSource = pSQL 
692     
693          'Save and Close report
694         DoCmd.Close acReport, pReportName, acSaveYes 
695     
696      Proc_Exit: 
697     
698         If Not rpt Is Nothing Then Set rpt = Nothing 
699         Exit Sub 
700     
701      Proc_Err: 
702         Select Case Err.Number 
703         Case 29068 
704            On Error Resume Next 
705            DoCmd.Close acReport, pReportName 
706            On Error GoTo Proc_Err 
707         Case Else 
708            MsgBox Err.Description, _ 
709               , "ERROR " & Err.Number & "  SetRecordSource" 
710            DoCmd.Echo True 
711     
712         End Select 
713     
714         Resume Proc_Exit 
715     
716          'if you want to single-step code to find error, CTRL-Break at MsgBox
717          'then set this to be the next statement
718         Resume 
719     
720      End Sub 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

SetReportFilter (114)

721     
722         '------------------------------------ SetReportFilter
723         'from HTML Calendar 141001
724      Sub SetReportFilter( _ 
725         pReportName As String _ 
726         , pvFilter As Variant) 
727     
728          'Save a filter to the specified report
729          'You can do this before you send a report in an email message
730          'You can use this to filter subreports instead of putting criteria in the recordset
731     
732          ' USEAGE:
733          ' example: in code that processes reports for viewing, printing, or email
734          ' SetReportFilter "MyReportname","someID=1000"
735          ' SetReportFilter "MyAppointments","City='Denver' AND dt_appt=#9/18/05#"
736     
737          ' written by Crystal
738          ' Strive4peace2004@yahoo.ca
739     
740          ' PARAMETERS:
741          ' pReportName is the name of your report
742          ' pvFilter is a valid filter string or null
743     
744         On Error GoTo SetReportFilter_error 
745     
746          '---------- declare variables
747         Dim rpt As Report 
748     
749          '----------  open design view of report and set the report object variable
750         DoCmd.OpenReport pReportName, acViewDesign 
751         Set rpt = Reports(pReportName) 
752     
753          '---------- set report filter and turn it on
754         If Not IsNull(pvFilter) Then 
755            rpt.Filter = pvFilter 
756            rpt.FilterOn = True 
757         Else 
758            rpt.FilterOn = False 
759         End If 
760     
761          '---------- save and close the changed report
762         DoCmd.Save acReport, pReportName 
763         DoCmd.Close acReport, pReportName, acSaveNo 
764     
765          '----------  Release object variable
766         Set rpt = Nothing 
767     
768         Exit Sub 
769     
770      SetReportFilter_error: 
771         Resume Next 
772     
773         MsgBox Err.Description, , "ERROR " & Err.Number & "  SetReportFilter" 
774          'press F8 to step thru code and fix problem
775         Stop 
776         Resume 
777          'next line will be the one with the error
778      End Sub 
779       ''~~~~~~~~~~~~~~~~~~~~~~~~~~ SetReportFilter
780       'Sub SetReportFilter(pReportName As String _
781       '   , pFilter As String)
782       '' Crystal (strive4peace)
783       '
784       '   'Save a filter to the specified report
785       '   'You can do this before you send a report in an email message
786       '   'You can use this to filter subreports instead of putting criteria in the recordset
787       '
788       '   ' USEAGE:
789       '   ' example: in code that processes reports for viewing, printing, or email
790       '   '   SetReportFilter "MyReportname","someID=1000"
791       '   '   SetReportFilter "MyAppointments","City='Denver' AND dt_appt=#9/18/05#"
792       '
793       '   ' written by Crystal
794       '   ' strive4peace2010@yahoo.com
795       '
796       '   ' PARAMETERS:
797       '   ' pReportName is the name of your report
798       '   ' pFilter is a valid filter string
799       '
800       '   On Error GoTo Proc_Err
801       '
802       '   '---------- declare variables
803       '   Dim rpt As Report
804       '
805       '   '---------- open design view of report in Hidden mode (> Access 2000)
806       '   DoCmd.OpenReport pReportName, acViewDesign ', , , acHidden
807       '
808       '   '---------- set object variable to report
809       '   Set rpt = Reports(pReportName)
810       '
811       '   '---------- set report filter and turn it on
812       '   rpt.Filter = pFilter
813       '   rpt.FilterOn = IIf(Len(pFilter) > 0, True, False)
814       '
815       '   '---------- Save and Close report
816       '   DoCmd.Close acReport, pReportName, acSaveYes
817       '
818       'Proc_Exit:
819       '   '----------  Release object variable
820       '   Set rpt = Nothing
821       '   Exit Sub
822       '
823       'Proc_Err:
824       '   Resume Next
825       '
826       '   MsgBox Err.Description, , "ERROR " & Err.Number & "  SetReportFilter"
827       '
828       '   Resume Proc_Exit
829       '
830       '   'if you want to single-step code to find error, CTRL-Break at MsgBox
831       '   'then set this to be the next statement
832       '   Resume
833       '
834       'End Sub
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

EMailReport (74)

835     
836       '=========================== Email
837       'SendObject
838       '[objecttype]
839       '[, objectname]
840       '[, outputformat]
841       '[, to]
842       '[, cc]
843       '[, bcc]
844       '[, subject]
845       '[, messagetext]
846       '[, editmessage]
847       '[, templatefile]
848     
849       '~~~~~~~~~~~~~~~~~~~~~~~~~~ EMailReport
850      Sub EMailReport(pReportName As String _ 
851         , pEmailAddress As String _ 
852         , Optional pFriendlyName As String = "" _ 
853         , Optional pBooEditMessage As Boolean = True _ 
854         , Optional pWhoFrom As String = "" _ 
855         , Optional pFormat As String = "SNP") 
856       ' Crystal (strive4peace)
857     
858          'Email a report to someone and construct the subject and message
859          'SNAPSHOT or RTF Format
860     
861          'example useage: on the command button code to process a report
862          ' EMailReport "rptSonglist", "anyone@mymailbox.com", _
863                "A List of the Original Songs from an upcoming Star", _
864                false, "Susan Manager"
865     
866          'PARAMETERS
867          'pReportName --> "rptSonglist"
868          'pEmailAddress --> "anyone@mymailbox.com"
869          'pFriendlyName --> "A List of the Original Songs from an upcoming Star"
870          'pBooEditMessage --> true if you want to edit the message before mail is sent
871          '                --> false if you want it to get sent automatically
872          'pWhoFrom --> "Susan Manager"
873     
874         On Error GoTo Proc_Err 
875     
876         Dim mFormat As String 
877     
878         Select Case pFormat 
879            Case "RTF": mFormat = acFormatRTF 
880            Case "SNP": mFormat = acFormatSNP 
881       '      Case "PDF": mFormat = acFormatPDF 'can uncomment for later versions of Access
882            Case "HTML": mFormat = acFormatHTML 
883            Case "TXT": mFormat = acFormatTXT 
884            Case "XLS": mFormat = acFormatXLS 
885         End Select 
886     
887        DoCmd.SendObject acSendReport, pReportName, acFormatRTF, pEmailAddress _ 
888         , , , pFriendlyName & Format(Now(), " ddd m-d-yy h:nn am/pm"), _ 
889         pFriendlyName & " is attached  ---    " _ 
890         & "Regards, " & pWhoFrom, pBooEditMessage 
891     
892         Exit Sub 
893     
894      Proc_Exit: 
895         Resume Next 
896         Exit Sub 
897     
898      Proc_Err: 
899     
900         MsgBox Err.Description _ 
901            , , "ERROR " & Err.Number & "  SetReportFilter" 
902     
903         Resume Proc_Exit 
904     
905          'if you want to single-step code to find error, CTRL-Break at MsgBox
906          'then set this to be the next statement
907         Resume 
908      End Sub 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

MakeMyQuery (67)

909     
910       '===================================================== MAKE OBJECTS
911     
912       '~~~~~~~~~~~~~~~~~~~~~~~~~~ MakeMyQuery
913     
914      Function MakeMyQuery( _ 
915         ByVal pQryName As String _ 
916         , ByVal pSQL As String _ 
917         , Optional pDb As DAO.Database _ 
918         ) As Boolean 
919     
920       'crystal, strive4peace2010@yahoo.com
921       '... 6-3-08, 130417
922     
923          'CALLED BY ANALYZER 130417
924          'DbTests_MakeQuery
925     
926         On Error GoTo Proc_Err 
927     
928         MakeMyQuery = False 
929     
930         Dim db As DAO.Database 
931     
932         If Not pDb Is Nothing Then 
933            Set db = pDb 
934         Else 
935            Set db = CurrentDb 
936         End If 
937     
938       '   Debug.Print pQryName & " > " & pSql
939     
940          'if query already exists, update the SQL
941          'if not, create the query
942     
943         With db 
944            If Nz(DLookup("[Name]", "MSysObjects", _ 
945                "[Name]='" & pQryName _ 
946                & "' And [Type]=5"), "") = "" Then 
947                .CreateQueryDef pQryName, pSQL 
948            Else 
949                'if query is open, close it
950               On Error Resume Next 
951               DoCmd.Close acQuery, pQryName, acSaveNo 
952               On Error GoTo Proc_Err 
953               .QueryDefs(pQryName).SQL = pSQL 
954            End If 
955     
956            .QueryDefs.Refresh 
957         End With   'db 
958     
959         DoEvents 
960     
961         MakeMyQuery = True 
962     
963      Proc_Exit: 
964         On Error Resume Next 
965         Set db = Nothing 
966         Exit Function 
967     
968      Proc_Err: 
969         MsgBox Err.Description, , _ 
970           "ERROR " & Err.Number & "  MakeMyQuery" 
971     
972         Resume Proc_Exit 
973         Resume 
974     
975      End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

AddFieldToTable (140)

976       '===================================================== DATA STRUCTURE
977       '~~~~~~~~~~~~~~~~~~~~~~~~~~ AddFieldToTable
978      Function AddFieldToTable( _ 
979         pTablename As String _ 
980         , pFldName As String _ 
981         , pDataType As Integer _ 
982         , Optional pFieldSize As Integer _ 
983         , Optional pDefaultValue As String = "" _ 
984         , Optional pDesc As String = "" _ 
985         , Optional pSkipMessage As Boolean = True _ 
986         , Optional pTdf As DAO.TableDef) _ 
987         As Boolean 
988     
989          'written by Crystal
990          'strive4peace2010 at yahoo.com
991          'modified 8-28-07, 12-3-09, 130901 pTdf
992     
993          'PARAMETERS
994          'pTablename --> name of table to modify structure of
995          'pFldname --> name of field to create
996          'pDataType --> dbText, dbLong, dbDate, etc
997          'pFieldSize --> length for text fields
998          'pDefaultValue --> *AN* = autonumber
999          '         --> *Null* --> DefaultValue = Null
1,000        '         --> *Now* --> DefaultValue = Now()
1,001        '         --> otherwise whatever is specified
1,002   
1,003        'NEEDS Reference to
1,004        'a Microsoft DAO Library
1,005        ' -- OR --
1,006        ' Microsoft Office 12.0 Access Database Engine Object Library
1,007   
1,008       On Error GoTo Proc_Err 
1,009   
1,010       AddFieldToTable = False 
1,011   
1,012       Dim db As DAO.Database _ 
1,013          , tdf As DAO.TableDef _ 
1,014          , fld As DAO.Field 
1,015   
1,016        'you could make this a passed parameter
1,017        ' and open another database
1,018   
1,019       Set db = CurrentDb 
1,020       If pTablename = "" Then 
1,021          If pTdf Is Nothing Then Exit Function 
1,022          Set tdf = pTdf 
1,023       Else 
1,024          Set tdf = db.TableDefs(pTablename) 
1,025       End If 
1,026   
1,027   
1,028       With tdf 
1,029   
1,030          Select Case pDataType 
1,031            Case dbText 
1,032                 'Text
1,033                Set fld = .CreateField(pFldName, _ 
1,034                  pDataType, pFieldSize) 
1,035            Case Else 
1,036                 'Long Integer, Date, etc
1,037                Set fld = .CreateField(pFldName, pDataType) 
1,038          End Select 
1,039   
1,040          If Len(pDefaultValue) > 0 Then 
1,041             Select Case pDefaultValue 
1,042             Case "*AN*" 
1,043                 'Autonumber
1,044                fld.Attributes = dbAutoIncrField 
1,045             Case "*Null*" 
1,046                 'Null for DefaultValue
1,047                fld.DefaultValue = "Null" 
1,048             Case "*Now*" 
1,049                 'Now for DefaultValue
1,050                fld.DefaultValue = "=Now()" 
1,051             Case Else 
1,052                 'Now for DefaultValue
1,053                fld.DefaultValue = "=" & pDefaultValue 
1,054             End Select 
1,055          End If 
1,056   
1,057          If pDataType = dbText Then 
1,058             fld.AllowZeroLength = True 
1,059             On Error Resume Next 
1,060             fld.Properties("UnicodeCompression") = True 
1,061             If Err > 0 Then 
1,062                fld.Properties.Append fld.CreateProperty("UnicodeCompression" _ 
1,063                   , dbBoolean, True) 
1,064             End If 
1,065             On Error GoTo Proc_Err 
1,066          End If 
1,067   
1,068          .Fields.Append fld 
1,069   
1,070          If Len(pDesc) > 0 Then 
1,071             On Error Resume Next 
1,072             fld.Properties("Description") = pDesc 
1,073             If Err > 0 Then 
1,074                fld.Properties.Append fld.CreateProperty("Description" _ 
1,075                   , dbText, pDesc) 
1,076             End If 
1,077             On Error GoTo Proc_Err 
1,078          End If 
1,079       End With 
1,080   
1,081       db.TableDefs.Refresh 
1,082       DoEvents 
1,083   
1,084       If Not pSkipMessage Then 
1,085         MsgBox "Added --> " & pFldName _ 
1,086          & " to --> " & pTablename, , "Done" 
1,087       End If 
1,088   
1,089       AddFieldToTable = True 
1,090   
1,091    Proc_Exit: 
1,092       On Error Resume Next 
1,093       Set fld = Nothing 
1,094       Set tdf = Nothing 
1,095        'if db is external and you OPENed it,
1,096        'you will need to close it too
1,097       Set db = Nothing 
1,098   
1,099       Exit Function 
1,100   
1,101    Proc_Err: 
1,102        'if the field is already there, ignore error
1,103       If Err = 3191 Then Resume Proc_Exit 
1,104        'linked table
1,105       If Err.Number = 3057 Or Err.Number = 3211 Then Resume Proc_Exit 
1,106       MsgBox Err.Description, , _ 
1,107         "ERROR " & Err.Number & "   AddFieldToTable" 
1,108   
1,109       Resume Proc_Exit 
1,110   
1,111        'if you want to single-step code to find error, CTRL-Break at MsgBox
1,112        'then set this to be the next statement
1,113       Resume 
1,114   
1,115    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

AddFieldDesc (69)

1,116   
1,117     '~~~~~~~~~~~~~~~~~~~~~~~~~~ AddFieldDesc
1,118    Function AddFieldDesc( _ 
1,119       pTablename As String, _ 
1,120       pFldName As String, _ 
1,121       pDesc As String, _ 
1,122       Optional pSkipMessage As Boolean = True) _ 
1,123       As Boolean 
1,124     ' Crystal (strive4peace)
1,125   
1,126       On Error GoTo Proc_Err 
1,127   
1,128       AddFieldDesc = False 
1,129   
1,130       Dim db As DAO.Database _ 
1,131          , fld As DAO.Field _ 
1,132          , prop As DAO.Property 
1,133   
1,134        'you could make this a passed parameter
1,135        ' and open another database
1,136   
1,137       Set db = CurrentDb 
1,138   
1,139       With db.TableDefs(pTablename) 
1,140   
1,141          On Error Resume Next 
1,142          .Fields(pFldName).Properties("Description") = pDesc 
1,143   
1,144          If Err.Number = 3270 Then 
1,145             On Error GoTo Proc_Err 
1,146             Set prop = .Fields(pFldName).CreateProperty("Description" _ 
1,147                , dbText, pDesc) 
1,148             .Fields(pFldName).Properties.Append prop 
1,149          Else 
1,150             On Error GoTo Proc_Err 
1,151          End If 
1,152   
1,153       End With 
1,154   
1,155       If Not pSkipMessage Then 
1,156         MsgBox "Added/Updated --> " & pDesc _ 
1,157          & vbCrLf & " as Description to --> " & pTablename & "." & pFldName, , "Done" 
1,158       End If 
1,159   
1,160       AddFieldDesc = True 
1,161   
1,162    Proc_Exit: 
1,163       On Error Resume Next 
1,164       If Not prop Is Nothing Then Set prop = Nothing 
1,165       If Not fld Is Nothing Then Set fld = Nothing 
1,166   
1,167       If Not db Is Nothing Then Set db = Nothing 
1,168       Exit Function 
1,169   
1,170    Proc_Err: 
1,171        'if the field is already there, ignore error
1,172       If Err = 3191 Then Resume Proc_Exit 
1,173        'linked table
1,174       If Err = 3057 Then Resume Proc_Exit 
1,175       MsgBox Err.Description, , _ 
1,176         "ERROR " & Err.Number & "   AddFieldDesc" 
1,177   
1,178       Resume Proc_Exit 
1,179   
1,180        'if you want to single-step code to find error, CTRL-Break at MsgBox
1,181        'then set this to be the next statement
1,182       Resume 
1,183   
1,184    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

TableHasField (46)

1,185   
1,186   
1,187   
1,188     '~~~~~~~~~~~~~~~~~~~~~~~~~~ TableHasField
1,189    Function TableHasField( _ 
1,190       pTbl As String _ 
1,191       , pFldName As String _ 
1,192       ) As Boolean 
1,193     ' Crystal (strive4peace)
1,194   
1,195       On Error GoTo Proc_Err 
1,196   
1,197       TableHasField = False 
1,198       Dim db As DAO.Database _ 
1,199          , tdf As DAO.TableDef _ 
1,200          , fld As DAO.Field 
1,201   
1,202       Set db = CurrentDb 
1,203       Set tdf = db.TableDefs(pTbl) 
1,204   
1,205       For Each fld In tdf.Fields 
1,206          If fld.Name = pFldName Then 
1,207             TableHasField = True 
1,208             GoTo Proc_Exit 
1,209          End If 
1,210       Next fld 
1,211   
1,212    Proc_Exit: 
1,213       Set fld = Nothing 
1,214       Set tdf = Nothing 
1,215       Set db = Nothing 
1,216       Exit Function 
1,217   
1,218    Proc_Err: 
1,219       MsgBox Err.Description, , _ 
1,220            "ERROR " & Err.Number _ 
1,221            & "   TableHasField" 
1,222   
1,223       Resume Proc_Exit 
1,224   
1,225        'if you want to single-step code to find error, CTRL-Break at MsgBox
1,226        'then set this to be the next statement
1,227       Resume 
1,228   
1,229    End Function 
1,230     '===================================================== LIST OBJECTS
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

listQuerySQL (21)

1,231   
1,232     '~~~~~~~~~~~~~~~~~~~~~~~~~~ listQuerySQL
1,233    Sub listQuerySQL() 
1,234       Dim qdf As DAO.QueryDef, db As DAO.Database 
1,235       Dim i As Integer 
1,236   
1,237       Set db = CurrentDb   'or whatever 
1,238       i = 0 
1,239       For Each qdf In db.QueryDefs 
1,240          i = i + 1 
1,241   
1,242          If MsgBox(qdf.SQL, vbOKCancel, _ 
1,243             i & " " & qdf.Name) = vbCancel Then Exit Sub 
1,244   
1,245          Debug.Print "--- " & i & " -- " & qdf.Name & " ---" 
1,246          Debug.Print qdf.SQL 
1,247       Next qdf 
1,248   
1,249        'Set qdf = Nothing --> not necessary -- looses scope at end of loop
1,250       Set db = Nothing 
1,251    End Sub 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

ListIndexes (19)

1,252   
1,253     '~~~~~~~~~~~~~~~~~~~~~~~~~~ ListIndexes
1,254    Sub ListIndexes(pt As String) 
1,255     '11-11-07
1,256       Dim db As DAO.Database _ 
1,257          , tdf As TableDef _ 
1,258          , idx As DAO.Index 
1,259   
1,260       Set db = CurrentDb 
1,261       Set tdf = db.TableDefs(pt) 
1,262   
1,263       For Each idx In tdf.Indexes 
1,264          Debug.Print idx.Name, idx.Fields.Count, idx.Fields(0).Name 
1,265       Next idx 
1,266   
1,267       Set tdf = Nothing 
1,268       Set db = Nothing 
1,269   
1,270    End Sub 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

IsTable (20)

1,271   
1,272     '===================================================== TEST OBJECTS
1,273   
1,274     '~~~~~~~~~~~~~~~~~~~~~~~~~~ IsTable
1,275    Public Function IsTable( _ 
1,276       strTableName As String _ 
1,277       ) As Boolean 
1,278        'return TRUE if table or query exists in current database
1,279        'written by Brent Spauling (datAdrenaline)
1,280   
1,281        With CurrentProject.Connection 
1,282            IsTable = .OpenSchema(20, Array(Empty, Empty, strTableName)).EOF   'adSchemaTables = 20 
1,283        End With 
1,284        Exit Function 
1,285   
1,286         'for Access 97...
1,287        IsTable = (DCount("Name", "MSysObjects", _ 
1,288                    "Name = '" & strTableName & "' And Type In (1,4,6)") <> 0) 
1,289   
1,290    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

DoesExist (56)

1,291   
1,292     '~~~~~~~~~~~~~~~~~~~~~~~~~~ DoesExist
1,293    Function DoesExist( _ 
1,294       sTblOrQryName As String _ 
1,295       , Optional sTQ As String = "" _ 
1,296       ) As Boolean 
1,297     'Crystal 100421, 130304
1,298   
1,299        'checks table and queries to see if the name exists
1,300        'example useage: call before Appending records to a table.  If not there, make the table
1,301        ' If not DoesExist("SummaryTable") then Call MakeTheTable("SummaryTable")
1,302      DoesExist = False 
1,303      Dim i As Integer 
1,304   
1,305   
1,306      Dim db As DAO.Database 
1,307      Set db = CurrentDb 
1,308   
1,309      Dim sName As String 
1,310   
1,311      If sTQ = "Q" Then GoTo TestForQuery 
1,312   
1,313       On Error Resume Next 
1,314       With db 
1,315          .TableDefs.Refresh 
1,316          sName = .TableDefs(sTblOrQryName).Name 
1,317          If Err.Number > 0 Then 
1,318             Err.Clear 
1,319          Else 
1,320             Err.Clear 
1,321             DoesExist = True 
1,322             GoTo Proc_Exit 
1,323           End If 
1,324           'if only testing for a table, then exit
1,325          If sTQ = "T" Then Exit Function 
1,326       End With   'db 
1,327   
1,328    TestForQuery: 
1,329       With db 
1,330          .QueryDefs.Refresh 
1,331          On Error Resume Next 
1,332          sName = .QueryDefs(sTblOrQryName).Name 
1,333          If Err.Number > 0 Then 
1,334             Err.Clear 
1,335          Else 
1,336             Err.Clear 
1,337             DoesExist = True 
1,338             GoTo Proc_Exit 
1,339          End If 
1,340       End With   'db 
1,341   
1,342    Proc_Exit: 
1,343       On Error Resume Next 
1,344       Set db = Nothing 
1,345   
1,346    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

DoesExistDelete (60)

1,347   
1,348      '~~~~~~~~~~~~~~~~~~~~~~~~~~ DoesExistDelete
1,349    Function DoesExistDelete( _ 
1,350       TblOrQryName As String _ 
1,351       , Optional pTQ As String = "TQ" _ 
1,352       ) As Boolean 
1,353     ' Crystal (strive4peace)
1,354   
1,355     '11-16-08, 12-20
1,356   
1,357        'checks table and queries to see if the name exists
1,358        'example useage: delete linked table references
1,359   
1,360       On Error GoTo Proc_Err 
1,361       DoesExistDelete = False 
1,362   
1,363       Dim db As DAO.Database 
1,364   
1,365       Dim i As Integer 
1,366   
1,367       Set db = CurrentDb 
1,368   
1,369       If InStr(pTQ, "T") > 0 Then 
1,370   
1,371          For i = (db.TableDefs.Count - 1) To 0 Step -1 
1,372   
1,373            If db.TableDefs(i).Name = TblOrQryName Then 
1,374              db.TableDefs.Delete db.TableDefs(i).Name 
1,375              DoesExistDelete = True 
1,376              Exit Function 
1,377            End If 
1,378   
1,379          Next i 
1,380       End If 
1,381   
1,382       If InStr(pTQ, "Q") > 0 Then 
1,383   
1,384          For i = 0 To db.QueryDefs.Count - 1 
1,385   
1,386            If db.QueryDefs(i).Name = TblOrQryName Then 
1,387              db.QueryDefs.Delete db.QueryDefs(i).Name 
1,388              DoesExistDelete = True 
1,389              Exit Function 
1,390            End If 
1,391          Next i 
1,392      End If 
1,393   
1,394   
1,395    Proc_Exit: 
1,396       Set db = Nothing 
1,397       Exit Function 
1,398   
1,399    Proc_Err: 
1,400       MsgBox Err.Description, , _ 
1,401            "ERROR " & Err.Number _ 
1,402            & "   DoesExistDelete" 
1,403   
1,404       Resume Proc_Exit 
1,405       Resume 
1,406    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

IsLoadedForm (28)

1,407   
1,408     '~~~~~~~~~~~~~~~~~~~~~~~~~~ IsLoadedForm
1,409    Function IsLoadedForm(pFormName As String) As Boolean 
1,410     ' Crystal (strive4peace)
1,411   
1,412        'This function returns  TRUE if the passed form is loaded  FALSE if it is not
1,413        'example useage: call before opening a form
1,414        ' If IsLoadedForm("Formname") Then DoCmd.SelectObject acForm, "Formname"
1,415       IsLoadedForm = False 
1,416        '  True if the specified form is open not in Design view
1,417       If CurrentProject.AllForms(pFormName).IsLoaded Then 
1,418          If Forms(pFormName).CurrentView <> 0 Then IsLoadedForm = True 
1,419       End If 
1,420       Exit Function 
1,421   
1,422        'for Access 97
1,423       IsLoadedForm = False 
1,424       Dim i As Integer 
1,425       Err.Number = 0 
1,426       On Error GoTo Proc_Exit 
1,427       For i = 0 To Forms.Count - 1 
1,428          If pFormName = Forms(i).Name Then 
1,429             IsLoadedForm = True 
1,430             Exit Function 
1,431          End If 
1,432       Next i 
1,433    Proc_Exit: 
1,434    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

IsLoadedReport (27)

1,435   
1,436     '~~~~~~~~~~~~~~~~~~~~~~~~~~ IsLoadedReport
1,437    Function IsLoadedReport(pReportName As String) As Boolean 
1,438     ' Crystal (strive4peace)
1,439        'This function returns  TRUE if the passed Report is loaded  FALSE if it is not
1,440        'example useage: call before changing a report filter
1,441        ' If IsLoadedReport("Reportname") Then --> report does not have to be opened
1,442   
1,443       If CurrentProject.AllReports(pReportName).IsLoaded Then 
1,444          If Forms(pReportName).CurrentView <> 0 Then IsLoadedReport = True 
1,445       End If 
1,446   
1,447       Exit Function 
1,448   
1,449        'for Access 97...
1,450       IsLoadedReport = False 
1,451       Dim i As Integer 
1,452       Err.Number = 0 
1,453       On Error GoTo Proc_Exit 
1,454       For i = 0 To Reports.Count - 1 
1,455          If pReportName = Reports(i).Name Then 
1,456             IsLoadedReport = True 
1,457             Exit Function 
1,458          End If 
1,459       Next i 
1,460    Proc_Exit: 
1,461    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

DoesControlExistOnForm (21)

1,462   
1,463     '~~~~~~~~~~~~~~~~~~~~~~~~~~ DoesControlExistOnForm
1,464    Function DoesControlExistOnForm(pF As Form _ 
1,465       , pControlname As String) As Boolean 
1,466     ' Crystal (strive4peace)
1,467   
1,468       On Error GoTo Proc_Err 
1,469       DoesControlExistOnForm = False 
1,470   
1,471       Dim sStr As String 
1,472   
1,473       sStr = pF(pControlname).Name 
1,474   
1,475       DoesControlExistOnForm = True 
1,476   
1,477    Proc_Exit: 
1,478       On Error Resume Next 
1,479       Exit Function 
1,480    Proc_Err: 
1,481       Resume Proc_Exit 
1,482    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

IsValidURL (38)

1,483   
1,484     '~~~~~~~~~~~~~~~~~~~~~~~~~~ IsValidURL
1,485    Function IsValidURL( _ 
1,486       pURL As String _ 
1,487       ) As Boolean 
1,488     ' Crystal (strive4peace)
1,489   
1,490     '6-9-07
1,491        'default value is to allow URL's that do not pass validation
1,492   
1,493       IsValidURL = True 
1,494   
1,495       Select Case True 
1,496       Case Left(pURL, 7) = "http://", Left(pURL, 6) = "ftp://", InStr(pURL, "www.") > 0 
1,497       Case Else 
1,498          If MsgBox("URL is missing 'www.' or 'http://' or 'Ftp://'" _ 
1,499             & vbCrLf & vbCrLf & "OK to keep anyway and stop checking or CANCEL to Undo Record" _ 
1,500             , vbOKCancel _ 
1,501             , "Invalid URL: keep anyway and stop checking OR Cancel update") = vbCancel Then 
1,502   
1,503             IsValidURL = False 
1,504             Exit Function 
1,505   
1,506          End If 
1,507       End Select 
1,508   
1,509       If InStr(pURL, ".") = 0 Then 
1,510          If MsgBox("Web Website is not valid, must contain a period" _ 
1,511             & vbCrLf & vbCrLf & "OK to keep anyway and stop checking or CANCEL to Undo Record" _ 
1,512             , vbOKCancel, "Fix Web Website or Cancel") = vbCancel Then 
1,513   
1,514             IsValidURL = False 
1,515   
1,516             Exit Function 
1,517          End If 
1,518       End If 
1,519   
1,520    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

SetGBlockDrop (11)

1,521   
1,522     '===================================================== CONTROLS
1,523     '~~~~~~~~~~~~~~~~~~~~~~~~~~ SetGBlockDrop
1,524    Function SetGBlockDrop( _ 
1,525       Optional pBoo As Boolean = True _ 
1,526       ) As Byte 
1,527   
1,528     '11-23-08
1,529   
1,530       gBlockDrop = Nz(pBoo, True) 
1,531    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

DropMe (31)

1,532   
1,533     '~~~~~~~~~~~~~~~~~~~~~~~~~~ DropMe
1,534    Function DropMe(Optional bSetToNull As Boolean = False) As Byte 
1,535     ' Crystal (strive4peace)
1,536   
1,537       On Error GoTo Proc_Err 
1,538        'usually used on the MouseUp event of a Combo Box
1,539        'so you can click anywhere and drop the list
1,540        'instead of just on the arrow
1,541        '=DropMe()
1,542   
1,543        'gBlockDrop is set on ZoomMe
1,544        'this is done so the box won't drop when
1,545        'double-click has been used for Zoom box
1,546       If gBlockDrop Then 
1,547          gBlockDrop = False 
1,548          Exit Function 
1,549       End If 
1,550   
1,551       If bSetToNull Then 
1,552          Screen.ActiveControl = Null 
1,553       End If 
1,554   
1,555       Screen.ActiveControl.Dropdown 
1,556    Proc_Exit: 
1,557       Exit Function 
1,558    Proc_Err: 
1,559        'MsgBox Err.Number & " " & Err.Description _
1,560           , , "Cannot drop list right now"
1,561       Resume Proc_Exit 
1,562    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

DropMeIfNull (13)

1,563   
1,564     '~~~~~~~~~~~~~~~~~~~~~~~~~~ DropMeIfNull
1,565    Function DropMeIfNull() As Byte 
1,566     ' Crystal (strive4peace)
1,567   
1,568        'usually used on the GotFocus event of a Combo Box
1,569        'so if there is nothing filled out yet, the list will drop
1,570        'Do NOT use on the first control in the tab order
1,571        '=DropMeIfNull()
1,572       On Error Resume Next 
1,573       If IsNull(Screen.ActiveControl) Then Screen.ActiveControl.Dropdown 
1,574       Exit Function 
1,575    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

RequeryMe (21)

1,576   
1,577     '~~~~~~~~~~~~~~~~~~~~~~~~~~ RequeryMe
1,578    Function RequeryMe(Optional pC As Control) As Byte 
1,579     ' Crystal (strive4peace)
1,580   
1,581        'used to rebuild combo box and listbox lists
1,582        'put on the double-click event of a combobox
1,583        ' =RequeryMe()
1,584        ' =RequeryMe([listRels])
1,585        ' if control is not specief. ActiveControl will be used
1,586   
1,587       On Error GoTo Proc_Err 
1,588       If pC Is Nothing Then 
1,589          Screen.ActiveControl.Requery 
1,590       Else 
1,591          pC.Requery 
1,592       End If 
1,593       Exit Function 
1,594    Proc_Err: 
1,595       MsgBox Err.Number & " " & Err.Description, , "Cannot Requery control right now" 
1,596    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

ZoomMe (21)

1,597   
1,598     '~~~~~~~~~~~~~~~~~~~~~~~~~~ ZoomMe
1,599    Function ZoomMe() As Byte 
1,600     ' Crystal (strive4peace)
1,601   
1,602        'pop up the ZOOM box for editing
1,603        'used in text and combo boxes where the text
1,604        'may be longer than the display
1,605        'put on the Double-Click event of the control
1,606        '=ZoomMe()
1,607       On Error Resume Next 
1,608       DoCmd.RunCommand acCmdZoomBox 
1,609   
1,610        'this is set so that if DropMe is used on a combo
1,611        'for mouse up, the list won't drop
1,612        'after the Zoom box
1,613       gBlockDrop = True 
1,614   
1,615        'this is the old way
1,616        'SendKeys "+{F2}", True
1,617    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

ClearList (17)

1,618   
1,619     '~~~~~~~~~~~~~~~~~~~~~~~~~~ ClearList
1,620    Function ClearList( _ 
1,621       ctl As Control _ 
1,622       ) As Boolean 
1,623     ' Crystal (strive4peace)
1,624     '4-4-09
1,625     'clear listbox items selected
1,626   
1,627       On Error Resume Next 
1,628       ClearList = False 
1,629       Dim varItem As Variant 
1,630       For Each varItem In ctl.ItemsSelected 
1,631           ctl.Selected(varItem) = False 
1,632           ClearList = True 
1,633       Next varItem 
1,634    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

ShowHideControls (59)

1,635   
1,636     '~~~~~~~~~~~~~~~~~~~~~~~~~~ ShowHideControls
1,637    Function ShowHideControls(pObj As Object _ 
1,638      , pBoo As Boolean _ 
1,639      , pTag As String _ 
1,640      , Optional pControlNameFocus As String = "" _ 
1,641      ) As Byte 
1,642     ' Crystal (strive4peace)
1,643   
1,644        'PARAMETERS
1,645        ' pObj : form reference or section of form
1,646        ' if section, Parent property will be used to get form reference
1,647        '  if 'parent' is in the Tag
1,648   
1,649       Dim ctl As Control _ 
1,650       , f As Form 
1,651   
1,652        'Set to PARENT form if specified in the Tag
1,653       If InStr(pObj.Tag, "parent") > 0 Then 
1,654          Set f = pObj.Parent 
1,655       Else 
1,656          Set f = pObj 
1,657       End If 
1,658   
1,659        'move focus if we are making invisible
1,660        If Not pBoo Then 
1,661          If pControlNameFocus <> "" Then f(pControlNameFocus).SetFocus 
1,662        End If 
1,663   
1,664       On Error GoTo Proc_Err 
1,665   
1,666       For Each ctl In pObj.Controls 
1,667   
1,668          If InStr(ctl.Tag, pTag) > 0 Then 
1,669            ctl.Visible = pBoo 
1,670          End If 
1,671   
1,672       Next ctl 
1,673   
1,674        'move focus after controls are visible
1,675       If pBoo Then 
1,676          If pControlNameFocus <> "" Then f(pControlNameFocus).SetFocus 
1,677       End If 
1,678   
1,679    Proc_Exit: 
1,680   
1,681       Set ctl = Nothing 
1,682       Set f = Nothing 
1,683       Exit Function 
1,684   
1,685    Proc_Err: 
1,686       MsgBox Err.Description, , _ 
1,687       "ERROR " & Err.Number _ 
1,688       & " ShowHideControls" 
1,689   
1,690       Resume Proc_Exit 
1,691       Resume 
1,692   
1,693    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

ProperCase (45)

1,694   
1,695     '~~~~~~~~~~~~~~~~~~~~~~~~~~ ProperCase
1,696    Function ProperCase(Optional pC As Control _ 
1,697       ) As Boolean 
1,698     ' Crystal (strive4peace)
1,699     '8-12-08, 4-4-09
1,700   
1,701        'change active control to Proper case if cma_ProperCase = true
1,702   
1,703        'EXAMPLES
1,704   
1,705        ' on AfterUpdate property -->
1,706        ' =ProperCase()
1,707        ' =ProperCase([ControlName])
1,708        '
1,709        ' in code -->
1,710        ' ProperCase Me.ActiveControl
1,711   
1,712        'if there is an error ignore it (and it probably won't happen anyway
1,713        '-- unless, for instance, you try this with a number)
1,714        'since null values are tested 
1,715   
1,716        'for a more in-depth version that corrects for things like MacDonald, O'Hare, etc, look here:
1,717        '   Uppercase converter (incl. Auto-Correct) by Rob Richards (r_Cubed)
1,718        '   http://www.utteraccess.com/forums/showflat.php?Cat=&Board=48&Number=619856
1,719   
1,720       ProperCase = False 
1,721   
1,722       On Error Resume Next 
1,723   
1,724        'THIS ONLY EXECUTES IF A CUSTOM PROPERTY IS SET
1,725     '   If Not Get_Property("cma_ProperCase") Then Exit Function
1,726   
1,727        'if a control reference was not passed, use the active control on the screen
1,728       If pC Is Nothing Then Set pC = Screen.ActiveControl 
1,729   
1,730        'if the control is not filled out, don't do anything
1,731       If IsNull(pC) Then Exit Function 
1,732   
1,733        'convert the contents of the control to ProperCase
1,734       pC = CorrectProper(StrConv(pC, vbProperCase)) 
1,735   
1,736       ProperCase = True 
1,737   
1,738    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

UpperCase (27)

1,739   
1,740     '~~~~~~~~~~~~~~~~~~~~~~~~~~ UpperCase
1,741    Function UpperCase(Optional pC As Control) As Byte 
1,742     ' Crystal (strive4peace)
1,743   
1,744        '10-27-07
1,745        'change active control to Upper Case
1,746        'EXAMPLE
1,747        ' on AfterUpdate property -->
1,748        ' =UpperCase([ControlName])
1,749   
1,750        'if there is an error ignore it (and it probably won't happen anyway
1,751        '-- unless, for instance, you try this with a number)
1,752        'since null values are tested 
1,753   
1,754       On Error Resume Next 
1,755   
1,756        'if a control reference was not passed, use the active control on the screen
1,757       If pC Is Nothing Then Set pC = Screen.ActiveControl 
1,758   
1,759        'if the control is not filled out, don't do anything
1,760       If IsNull(pC) Then Exit Function 
1,761   
1,762        'convert the contents of the control to UpperCase
1,763       pC = UCase(pC) 
1,764   
1,765    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

CorrectProper (23)

1,766   
1,767     '~~~~~~~~~~~~~~~~~~~~~~~~~~ CorrectProper
1,768    Function CorrectProper(pString As String) As String 
1,769     ' Crystal (strive4peace)
1,770   
1,771     '5-15-07
1,772        'correct:
1,773        'Macx* --> MacX*
1,774        'Vanx* --> VanX*
1,775        'Mcx* --> McX*
1,776        'will only correct if at beginning of passed string, not in the middle
1,777   
1,778       Select Case True 
1,779       Case Len(pString) > 4 And InStr(".Mac.Van.", "." & Left(pString, 3) & ".") > 0 
1,780          pString = Left(pString, 3) & UCase(Mid(pString, 4, 1)) & Right(pString, Len(pString) - 4) 
1,781       Case Left(pString, 2) = "Mc" And Len(pString) > 3 
1,782          pString = Left(pString, 2) & UCase(Mid(pString, 3, 1)) & Right(pString, Len(pString) - 3) 
1,783   
1,784       End Select 
1,785   
1,786       CorrectProper = pString 
1,787   
1,788    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

BoldMe (208)

1,789   
1,790     '~~~~~~~~~~~~~~~~~~~~~~~~~~ BoldMe
1,791    Function BoldMe(Optional pF As Form _ 
1,792       , Optional pControlname As String = "" _ 
1,793       , Optional pnLastOption As Integer = 0 _ 
1,794       , Optional pValue As Variant _ 
1,795       , Optional pnFirstOption As Integer = 1 _ 
1,796       ) As Byte 
1,797     '9-9-08,12-4-09
1,798     '3-26-10 modify attached label if available. reversed naming convention
1,799     '100330 nz, 130418 frame
1,800   
1,801        'CALLED BY ANALYZER
1,802        'a_f_ANALYZER_MENU
1,803   
1,804        ' Crystal
1,805        ' strive4peace2010@yahoo.com
1,806        ' http://www.accessMVP.com/strive4peace/BoldMe.htm
1,807   
1,808        'Bold the label is the option is chosen or value is true
1,809        'remove Bold if the value is not true or the option is not chosen
1,810   
1,811        ' --------------------------------------------------------
1,812        'PARAMETERS
1,813        '  pF = form reference
1,814        '       if in code behind a form, this is
1,815        '                   Me
1,816        '
1,817        '  pControlName is name of control to test
1,818        '               if not specified, ActiveControl will be used
1,819        '
1,820        '  pnLastOption is the LAST option number in the frame (group)
1,821        '              must be specified for option frame
1,822        '
1,823        '  pValue is the comparison value for deciding Bold
1,824        '         if parameter is passed
1,825        '         then the opn frame will not be tested
1,826        '
1,827        '               Unattached Labels MUST be named like this:
1,828        '               Controlname_Label
1,829        '
1,830        '               NOTE: the "label" control
1,831        '                         does not have to be a label ControlType
1,832        '                     It can be, for instance, a textbox
1,833        '
1,834        '  pnFirstOption is the FIRST option number in the frame (group)
1,835        '              if missing, 1 is assumed
1,836   
1,837   
1,838        ' --------------------------------------------------------
1,839        ' NOTES
1,840        '
1,841        ' for checkboxes and toggle buttons
1,842        '
1,843        '               if checkbox Name = MyCheckbox
1,844        '                  then label Name = MyCheckbox_Label
1,845        '               if the label is attached, it can be named anything
1,846        '
1,847        ' for options in a frame
1,848        '
1,849        '    if Frame Name = MyOptionFrame
1,850        '
1,851        '    then Frame Option Buttons are Named:
1,852        '          MyOptionFrame1, MyOptionFrame2, etc
1,853        '
1,854        '    Labels for Frame Option Buttons are Named:
1,855        '          MyOptionFrame1_Label, MyOptionFrame2__Label, etc
1,856        '          if the labels are attached, they can be named anything
1,857        '
1,858        '    Numbers in the name correspond to the Option Order
1,859        '
1,860        '    Option Values can be any number
1,861        '
1,862   
1,863        ' --------------------------------------------------------
1,864        'USEAGE
1,865        '   BoldMe Me
1,866        '       Bold the label of the
1,867        '         active checkbox or toggle control
1,868        '       if the control value = True
1,869        '
1,870        '   BoldMe Me, "Mycheckbox_controlname"
1,871        '       Bold the label of the
1,872        '         specified checkbox or toggle control
1,873        '       if the control value = True
1,874        '
1,875        '   BoldMe Me, "Mycheckbox_controlname",,True
1,876        '       Bold the label of the
1,877        '         specified checkbox or toggle control
1,878        '
1,879        '   BoldMe Me, "MyFrame_controlname", 4
1,880        '       Bold the label of the option
1,881        '            in the specified frame control
1,882        '            if the Option Value = the Frame Value
1,883        '       where there are 4 options to pick from
1,884        '
1,885        '   BoldMe Me, "MyFrame_controlname", 4, 999
1,886        '       Bold the label of the option
1,887        '            in the specified frame control
1,888        '            if the Option Value = 999
1,889        '       where there are 4 options to pick from
1,890        '
1,891   
1,892       On Error GoTo Proc_Err 
1,893   
1,894       If pF Is Nothing Then Set pF = Screen.ActiveForm 
1,895   
1,896       Dim bBoo As Boolean _ 
1,897          , sControlname As String _ 
1,898          , sControlNameLabel As String _ 
1,899          , sControlNameOption As String 
1,900   
1,901       If Len(pControlname) > 0 Then 
1,902          sControlname = pControlname 
1,903       Else 
1,904          sControlname = pF.ActiveControl.Name 
1,905       End If 
1,906   
1,907       If IsMissing(pValue) Then 
1,908          pValue = pF(sControlname).Value 
1,909       End If 
1,910   
1,911        ' use WITH to minimize the number of times
1,912        ' this code has to access the object
1,913   
1,914        'checkbox or toggle button
1,915       With pF(sControlname) 
1,916   
1,917          Select Case .ControlType 
1,918          Case acCheckBox, acToggleButton 
1,919   
1,920             If IsMissing(pValue) Then 
1,921                bBoo = Nz(.Value, False) 
1,922             Else 
1,923                 'note: Null cannot be compared
1,924                bBoo = Nz(pValue) 
1,925             End If 
1,926   
1,927             If pF(sControlname).Controls.Count > 0 Then 
1,928                sControlNameLabel = pF(sControlname).Controls(0).Name 
1,929             Else 
1,930                sControlNameLabel = sControlname & "_Label" 
1,931             End If 
1,932   
1,933             With pF(sControlNameLabel) 
1,934                 ' see if Bold is already right
1,935                If .FontBold <> bBoo Then 
1,936                    ' Bold needs to change
1,937                   .FontBold = bBoo 
1,938                End If 
1,939             End With 
1,940   
1,941             GoTo Proc_Exit 
1,942   
1,943           'option box - MUST SPECIFY pnLastOption
1,944          Case acOptionGroup 
1,945   
1,946             Dim i As Integer 
1,947   
1,948             For i = pnFirstOption To pnLastOption 
1,949                sControlNameOption = sControlname & Format(i, "0") 
1,950                If IsNull(pValue) Then 
1,951                    ' if the comparison is blank
1,952                    ' no option will be bolded
1,953                   bBoo = False 
1,954                Else 
1,955                    ' if the option value = the comparison value
1,956                    ' then bBoo = TRUE
1,957                   bBoo = IIf( _ 
1,958                   pF(sControlNameOption).OptionValue = pValue, True, False) 
1,959                End If 
1,960   
1,961                If pF(sControlNameOption).Controls.Count > 0 Then 
1,962                   sControlNameLabel = pF(sControlNameOption).Controls(0).Name 
1,963                Else 
1,964                   sControlNameLabel = sControlNameOption & "_Label" 
1,965                End If 
1,966   
1,967                With pF(sControlNameLabel) 
1,968                   If .FontBold <> bBoo Then 
1,969                      .FontBold = bBoo 
1,970                   End If 
1,971                End With 
1,972   
1,973             Next i 
1,974   
1,975             GoTo Proc_Exit 
1,976   
1,977          End Select 
1,978   
1,979       End With 
1,980   
1,981    Proc_Exit: 
1,982       On Error Resume Next 
1,983       pF.Repaint 
1,984       Exit Function 
1,985   
1,986    Proc_Err: 
1,987       MsgBox Err.Description _ 
1,988          , , "ERROR " & Err.Number & "  BoldMe " & sControlname 
1,989   
1,990       Resume Proc_Exit 
1,991   
1,992        'if you want to single-step code to find error, CTRL-Break at MsgBox
1,993        'then set this to be the next statement
1,994       Resume 
1,995   
1,996    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

CapString (14)

1,997   
1,998     '===================================================== STRING
1,999   
2,000     '~~~~~~~~~~~~~~~~~~~~~~~~~~ CapString
2,001    Function CapString(pString As String _ 
2,002       , Optional pBoo As Boolean = True) As String 
2,003        'use in a query or recordset to show all capital letters
2,004        'if pString = "hello" then CapString = "HELLO"
2,005       If Not pBoo Then 
2,006          CapString = Nz(pString, "") 
2,007       Else 
2,008          CapString = UCase(Nz(pString, "")) 
2,009       End If 
2,010    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

CorrectName (85)

2,011   
2,012     '~~~~~~~~~~~~~~~~~~~~~~~~~~ CorrectName
2,013    Function CorrectName( _ 
2,014       ByVal pName As String _ 
2,015       , Optional ByVal pBooDateStamp As Boolean = False _ 
2,016       ) As String 
2,017   
2,018       Dim i As Integer _ 
2,019          , mName As String _ 
2,020          , mChar As String * 1 _ 
2,021          , mLastChar As String * 1 _ 
2,022          , mNewChar As String * 1 _ 
2,023          , mExt As String _ 
2,024          , iPos As Integer 
2,025   
2,026        'crystal
2,027        'strive4peace2010@yahoo.com
2,028   
2,029        'PARAMETERS
2,030        'pName is the string you want to correct
2,031        'pBooDateStamp (optional) adds date and time to end
2,032   
2,033        'EXAMPLE USEAGE
2,034        '  on the AfterUpdate event of a control
2,035        '  =CorrectName([controlname])
2,036        '
2,037        'in a query:
2,038        'field --> CorrectName: CorrectName([strFieldname])
2,039   
2,040        'EXAMPLE
2,041        ' ? CorrectName("as(,48209j@##@!")
2,042        ' --> as_48209j_
2,043        ' ? CorrectName("as(,48209j@##@!", true)
2,044        ' --> as_48209j_070511_301pm
2,045   
2,046       CorrectName = "" 
2,047   
2,048       If Len(Nz(pName)) < 1 Then Exit Function 
2,049   
2,050       pName = LTrim(Trim(pName)) 
2,051   
2,052        'see if file has an extension
2,053   
2,054       iPos = InStrRev(pName, ".") 
2,055       mExt = "" 
2,056   
2,057       If iPos > 0 Then 
2,058          If iPos > (Len(pName) - 6) Then 
2,059             mExt = Mid(pName, iPos + 1) 
2,060             mExt = "." & CorrectName(mExt) 
2,061             pName = Trim(Left(pName, iPos - 1)) 
2,062          End If 
2,063       End If 
2,064   
2,065   
2,066       For i = 1 To Len(pName) 
2,067          mChar = Mid(pName, i, 1) 
2,068   
2,069           'use this line if you also want to replaces spaces
2,070          If InStr("`!@#$%^&*()+=|\:;""'<>,.?/ ", mChar) > 0 Then 
2,071   
2,072           'use this line to leave spaces
2,073     '      If InStr("`!@#$%^&*()+=|\:;""'<>,.?/", mChar) > 0 Then
2,074   
2,075             mNewChar = "_" 
2,076          Else 
2,077             mNewChar = mChar 
2,078          End If 
2,079   
2,080          If mLastChar = "_" And mNewChar = "_" Then 
2,081              'leave the same for multiple characters to replace in a row
2,082          Else 
2,083             mName = mName & mNewChar 
2,084          End If 
2,085   
2,086          mLastChar = mNewChar 
2,087       Next i 
2,088   
2,089       CorrectName = mName _ 
2,090        & IIf(Not pBooDateStamp, "", _ 
2,091          IIf(mLastChar = "_", "", "_") _ 
2,092          & Format(Now(), "yymmdd_hnnam/pm") _ 
2,093        ) & mExt 
2,094   
2,095    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

RunLoopAndCombine (16)

2,096   
2,097     '~~~~~~~~~~~~~~~~ RunLoopAndCombine
2,098    Sub RunLoopAndCombine() 
2,099       Dim mTableName As String, _ 
2,100       mIDFieldname As String, _ 
2,101       mTextFieldname As String, _ 
2,102       mValueID As Long 
2,103   
2,104       mTableName = "usys_qPIDFriendlyT" 
2,105       mIDFieldname = "PID" 
2,106       mTextFieldname = "FriendlyT" 
2,107       mValueID = 138 
2,108   
2,109       MsgBox LoopAndCombine(mTableName, mIDFieldname, mTextFieldname, mValueID) 
2,110   
2,111    End Sub 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

LoopAndCombine (97)

2,112   
2,113     '~~~~~~~~~~~~~~~~ LoopAndCombine
2,114    Function LoopAndCombine( _ 
2,115       pTablename As String _ 
2,116       , pIDFieldname As String _ 
2,117       , pTextFieldname As String _ 
2,118       , pValueID As Long _ 
2,119       , Optional pWhere As String = "" _ 
2,120       , Optional pDeli As String = ", " _ 
2,121       , Optional pNoValue As String = "" _ 
2,122       , Optional pOrderBy As String = "" _ 
2,123       ) As String 
2,124   
2,125        'crystal 5-6-07
2,126        'strive4peace2010@yahoo.com
2,127   
2,128        'NEEDS REFERENCE
2,129        'a Microsoft DAO Library
2,130        ' -- OR --
2,131        ' Microsoft Office #.0 Access Database Engine Object Library
2,132   
2,133        'PARAMETERS
2,134        'pTablename --> tablename to get list from
2,135        'pIDFieldname --> fieldname to link on (ie: "BookID")
2,136        'pTextFieldname --> fieldname to combine (ie: "PageNumber")
2,137        'pValueID --> actual value of ID for this iteration ( ie: [BookID])
2,138        'pWhere, Optional  --> more criteria (ie: "Year(PubDate) = 2006")
2,139        'pDeli, Optional  --> delimiter other than comma (ie: ";", Chr(13) & Chr(10))
2,140        'pNoValue, Optional  --> value to use if no data (ie: "No Pages")
2,141        'pOrderBy, Optional  --> fieldlist to Order By
2,142   
2,143        'Set up error handler
2,144       On Error GoTo Proc_Err 
2,145   
2,146        'dimension variables
2,147       Dim R As DAO.Recordset, mAllValues As String, s As String 
2,148   
2,149     '   If Len(Trim(pDeli)) > 0 Then _
2,150           pDeli = pDeli Else pDeli = ","
2,151   
2,152       mAllValues = "" 
2,153   
2,154       s = "SELECT [" & pTextFieldname & "] " _ 
2,155           & " FROM [" & pTablename & "]" _ 
2,156           & " WHERE [" & pIDFieldname _ 
2,157           & "] = " & pValueID _ 
2,158           & IIf(Len(pWhere) > 0, " AND " & pWhere, "") _ 
2,159           & IIf(Len(pOrderBy) > 0, " ORDER BY " & pOrderBy, "") _ 
2,160           & ";" 
2,161   
2,162        'open the recordset
2,163       Set R = CurrentDb.OpenRecordset(s, dbOpenSnapshot) 
2,164   
2,165        'loop through the recordset until the end
2,166       Do While Not R.EOF 
2,167          If Not IsNull(R(pTextFieldname)) Then 
2,168   
2,169              '~~~~~~~~~~~~~~~~~~~~~~~~~ CHOOSE ONE
2,170   
2,171              '---- if fieldname is numeric
2,172             mAllValues = mAllValues _ 
2,173              & Trim(R(pTextFieldname)) & pDeli 
2,174   
2,175              '---- if fieldname you want quotes areound data
2,176              'mAllValues = mAllValues _
2,177               & " '" & trim(r(pTextFieldname)) & "'" & pDeli
2,178   
2,179              '~~~~~~~~~~~~~~~~~~~~~~~~~
2,180           End If 
2,181          R.MoveNext 
2,182       Loop 
2,183   
2,184       If Len(mAllValues) = 0 Then 
2,185          mAllValues = pNoValue 
2,186       Else 
2,187          mAllValues = Left(mAllValues, Len(mAllValues) - Len(pDeli)) 
2,188       End If 
2,189   
2,190   
2,191    Proc_Exit: 
2,192        'close the recordset
2,193       R.Close 
2,194        'release the recordset variable
2,195       Set R = Nothing 
2,196   
2,197       LoopAndCombine = Trim(mAllValues) 
2,198       Exit Function 
2,199   
2,200     'if there is an error, the following code will execute
2,201    Proc_Err: 
2,202       MsgBox Err.Description, , _ 
2,203         "ERROR " & Err.Number _ 
2,204          & "   LoopAndCombine" 
2,205   
2,206       Resume Proc_Exit 
2,207       Resume 
2,208    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

RunLoopCombineVar (20)

2,209   
2,210     '~~~~~~~~~~~~~~~~ RunLoopCombineVar
2,211    Sub RunLoopCombineVar() 
2,212       Dim mTableName As String _ 
2,213       , mIDFieldname As String _ 
2,214       , mTextFieldname As String _ 
2,215       , mValueID As Long _ 
2,216       , mDeli As String _ 
2,217       , mOrderBy As String 
2,218   
2,219       mTableName = "c_AdrLines" 
2,220       mIDFieldname = "AddrID" 
2,221       mTextFieldname = "AdrLine" 
2,222       mValueID = 1 
2,223       mDeli = Chr(13) & Chr(10) 
2,224       mOrderBy = "Ordr" 
2,225   
2,226       MsgBox LoopCombineVar(mTableName, mIDFieldname, mTextFieldname, mValueID, mDeli, mOrderBy) 
2,227   
2,228    End Sub 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

LoopCombineVar (82)

2,229   
2,230     '~~~~~~~~~~~~~~~~ LoopCombineVar
2,231    Function LoopCombineVar( _ 
2,232       pTablename As String _ 
2,233       , pIDFieldname As String _ 
2,234       , pTextFieldname As String _ 
2,235       , pValueID As Long _ 
2,236       , Optional pDeli As String = ", " _ 
2,237       , Optional pOrderBy As Variant = Null _ 
2,238       ) As Variant 
2,239   
2,240        'crystal 5-6-07
2,241        'strive4peace2010@yahoo.com
2,242   
2,243        'NEEDS REFERENCE
2,244        'a Microsoft DAO Library
2,245        ' -- OR --
2,246        ' Microsoft Office 12.0 Access Database Engine Object Library
2,247   
2,248        'PARAMETERS
2,249        'pTablename --> tablename to get list from
2,250        'pIDFieldname --> fieldname to link on (ie: "BookID")
2,251        'pTextFieldname --> fieldname to combine (ie: "PageNumber")
2,252        'pValueID --> actual value of ID for this iteration ( ie: [BookID])
2,253        'pOrderBy, Optional  --> fieldlist to Order By
2,254        'pDeli, Optional  --> delimiter other than comma (ie: ";", Chr(13) & Chr(10))
2,255   
2,256        'Set up error handler
2,257       On Error GoTo Proc_Err 
2,258   
2,259       LoopCombineVar = Null 
2,260   
2,261        'dimension variables
2,262       Dim R As DAO.Recordset 
2,263   
2,264       Dim mAllValues As Variant _ 
2,265          , s As String 
2,266   
2,267       mAllValues = Null 
2,268   
2,269       s = "SELECT [" & pTextFieldname & "] " _ 
2,270           & " FROM [" & pTablename & "]" _ 
2,271           & " WHERE [" & pIDFieldname _ 
2,272           & "] = " & pValueID _ 
2,273           & " AND ([" & pTextFieldname & "] Is Not Null)" _ 
2,274           & IIf(IsNull(pOrderBy), "", " ORDER BY " & pOrderBy) _ 
2,275           & ";" 
2,276   
2,277        'open the recordset
2,278       Set R = CurrentDb.OpenRecordset(s, dbOpenSnapshot) 
2,279   
2,280        'loop through the recordset until the end
2,281       Do While Not R.EOF 
2,282   
2,283          mAllValues = (mAllValues + pDeli) _ 
2,284           & Trim(R(pTextFieldname)) 
2,285   
2,286          R.MoveNext 
2,287       Loop 
2,288   
2,289   
2,290    Proc_Exit: 
2,291       If Not R Is Nothing Then 
2,292           'close the recordset
2,293          R.Close 
2,294           'release the recordset variable
2,295          Set R = Nothing 
2,296        End If 
2,297   
2,298       LoopCombineVar = mAllValues 
2,299       Exit Function 
2,300   
2,301     'if there is an error, the following code will execute
2,302    Proc_Err: 
2,303       MsgBox Err.Description, , _ 
2,304         "ERROR " & Err.Number _ 
2,305          & "   LoopCombineVar" 
2,306   
2,307       Resume Proc_Exit 
2,308       Resume 
2,309    End Function 
2,310     '===================================================== NUMERIC
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

GetAge (16)

2,311   
2,312     '~~~~~~~~~~~~~~~~~~~~~~~~~~ GetAge
2,313    Function GetAge(pDOB As Date _ 
2,314       , Optional pDate As Date = 0) As Integer 
2,315     ' Crystal (strive4peace)
2,316     '3-20-09
2,317        'get age in years given DOB and the date to take age from
2,318        'if pDate is not specified, the current date is used
2,319   
2,320       If pDate = 0 Or Not IsDate(pDate) Then pDate = Date 
2,321   
2,322       GetAge = 0 
2,323       If Nz(pDOB, 0) = 0 Then Exit Function 
2,324       GetAge = DateDiff("yyyy", pDOB, pDate) _ 
2,325          + (pDate < DateSerial(Year(pDate), Month(pDOB), Day(pDOB))) 
2,326    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

GetBirthday (14)

2,327   
2,328     '===================================================== DATE
2,329     '~~~~~~~~~~~~~~~~ GetBirthday
2,330    Function GetBirthday(pDOB As Date _ 
2,331       , pCurrentDate As Date _ 
2,332       ) As Date 
2,333     ' Crystal (strive4peace)
2,334   
2,335       GetBirthday = DateSerial( _ 
2,336          Year(pCurrentDate) _ 
2,337          , Month(pDOB) _ 
2,338          , Day(pDOB)) 
2,339   
2,340    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

ExitAccess (9)

2,341   
2,342     '===================================================== APPLICATION
2,343   
2,344     '~~~~~~~~~~~~~~~~~~~~~~~~~~ ExitAccess
2,345    Function ExitAccess() As Byte 
2,346        'use for the OnClick event of an Exit command button
2,347        '=ExitAccess()
2,348       Application.Quit 
2,349    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

ResetStuff (14)

2,350   
2,351     '~~~~~~~~~~~~~~~~~~~~~~~~~~ ResetStuff
2,352    Function ResetStuff( _ 
2,353       Optional SkipMsg As Boolean = False _ 
2,354       ) As Byte 
2,355   
2,356       DoCmd.Echo True 
2,357       DoCmd.SetWarnings True 
2,358       DoCmd.Hourglass False 
2,359       Application.SysCmd acSysCmdClearStatus 
2,360       If IsMissing(SkipMsg) Then 
2,361          MsgBox "Reset done", , "Done" 
2,362       End If 
2,363    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

GetCurrentPath (16)

2,364   
2,365     '===================================================== DIRECTORIES
2,366   
2,367     '~~~~~~~~~~~~~~~~~~~~~~~~~~ GetCurrentPath
2,368    Function GetCurrentPath() As String 
2,369     ' Crystal (strive4peace)
2,370        'get current path of the database
2,371        'for use with Access 97 in place of CurrentProject.Path
2,372   
2,373       Dim i As Integer 
2,374       For i = Len(CurrentDb.Name) To 1 Step -1 
2,375          If Mid(CurrentDb.Name, i, 1) = "\" Then GoTo GetCurrentPath_GotLength 
2,376       Next i 
2,377    GetCurrentPath_GotLength: 
2,378       GetCurrentPath = Left(CurrentDb.Name, i) 
2,379    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

MakeAPath (48)

2,380   
2,381     '~~~~~~~~~~~~~~~~~~~~~~~~~~ MakeAPath
2,382    Function MakeAPath( _ 
2,383       pPath As String _ 
2,384       ) As Boolean 
2,385     ' Crystal (strive4peace)
2,386        'Make a directory path
2,387   
2,388       MakeAPath = False 
2,389   
2,390       If Len(Dir(pPath, vbDirectory)) > 0 Then 
2,391           'directory is already there
2,392          MakeAPath = True 
2,393          GoTo Proc_Exit 
2,394       End If 
2,395   
2,396       Dim i As Integer _ 
2,397          , iPos As Integer _ 
2,398          , mStr As String 
2,399   
2,400       iPos = 1 
2,401       If Right(pPath, 1) <> "\" Then pPath = pPath & "\" 
2,402   
2,403       iPos = InStr(iPos, pPath, "\") 
2,404   
2,405       Do While iPos > 0 
2,406          mStr = Left(pPath, iPos) 
2,407          If Len(Dir(pPath, vbDirectory)) = 0 Then 
2,408             On Error Resume Next 
2,409             MkDir mStr 
2,410          End If 
2,411          iPos = InStr(iPos + 1, pPath, "\") 
2,412       Loop 
2,413   
2,414       If Len(Dir(pPath, vbDirectory)) > 0 Then 
2,415          MakeAPath = True 
2,416          GoTo Proc_Exit 
2,417       End If 
2,418   
2,419       MsgBox "Could not make path: " _ 
2,420          & pPath _ 
2,421          , , "Error making " _ 
2,422             & " directory" 
2,423   
2,424    Proc_Exit: 
2,425       Exit Function 
2,426   
2,427    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

MakeADirectory (44)

2,428   
2,429     '~~~~~~~~~~~~~~~~~~~~~~~~~~ MakeADirectory
2,430    Function MakeADirectory( _ 
2,431       pPath As String _ 
2,432       ) As Boolean 
2,433     ' Crystal (strive4peace)
2,434        '9-10-06
2,435   
2,436        'Make a directory
2,437        'if it cannot be created, MakeAPath will be called
2,438   
2,439       MakeADirectory = False 
2,440   
2,441        'On Error GoTo Proc_Err
2,442       On Error Resume Next 
2,443   
2,444       Dim mPath As String 
2,445       mPath = Trim(pPath) 
2,446   
2,447        '--- exit if directory is already there
2,448       If Len(Dir(mPath, vbDirectory)) > 0 Then 
2,449          MakeADirectory = True 
2,450          GoTo Proc_Exit 
2,451       End If 
2,452   
2,453        '--- if directory does not exist, create it
2,454       MkDir mPath 
2,455   
2,456        'if it is still not there...
2,457       If Len(Dir(mPath, vbDirectory)) = 0 Then 
2,458   
2,459           'create each directory before it...
2,460          If Not MakeAPath(mPath) Then 
2,461             GoTo Proc_Exit 
2,462          End If 
2,463       End If 
2,464       DoEvents 
2,465   
2,466       MakeADirectory = True 
2,467   
2,468    Proc_Exit: 
2,469       Exit Function 
2,470   
2,471    End Function 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

RunAddFieldsToTable_Tracking (138)

2,472   
2,473   
2,474     '******************************************************
2,475     '******************************************************
2,476   
2,477     '~~~~~~~~~~~~~~~~~~~~~~~~~~ RunAddFieldsToTable_Tracking
2,478    Sub RunAddFieldsToTable_Tracking() 
2,479     'USED BY ANALYZER After new tables are added
2,480       Dim tdf As DAO.TableDef 
2,481   
2,482        'written by Crystal
2,483        'strive4peace2010 at yahoo.com
2,484        'modified 7-29-08, 8-6, 5-18-09, 130420
2,485   
2,486        'will add the following tracking fields to every table:
2,487        'IDadd, IDedit, dateAdd, dateEdit
2,488   
2,489        ' if dtmEdit already exists, the Default Value will be updated to Now()
2,490   
2,491       Dim nCountDone As Integer _ 
2,492          , nCountChecked As Integer _ 
2,493          , nCountUpdateDefaultValue As Long _ 
2,494          , i As Integer 
2,495   
2,496       nCountUpdateDefaultValue = 0 
2,497       Dim db As DAO.Database 
2,498       Set db = CurrentDb 
2,499   
2,500       For Each tdf In db.TableDefs 
2,501          If Left(tdf.Name, 4) <> "Msys" Then 
2,502             Debug.Print 
2,503             Debug.Print tdf.Name & "..."; 
2,504             nCountChecked = nCountChecked + 1 
2,505   
2,506             ' ----------------------------------------- IDs
2,507             ' if you do not want to add tracking fields for user
2,508             '  then comment these lines
2,509   
2,510     '         If AddFieldToTable("", "IDadd", dbLong _
2,511     '            , , "*Null*", "user who added record", , tdf) Then
2,512     '            nCountDone = nCountDone + 1
2,513     '            Debug.Print "  IDadd";
2,514     '         End If
2,515     '
2,516     '         If AddFieldToTable("", "IDedit" _
2,517     '            , dbLong, , "*Null*", "user who last edited record", , tdf) Then
2,518     '            nCountDone = nCountDone + 1
2,519     '            Debug.Print "  IDedit";
2,520     '         End If
2,521              ' ----------------------------------------- Dates
2,522   
2,523             If AddFieldToTable("", "dtmAdd", dbDate _ 
2,524                , , "*Now*", "date record was added", , tdf) Then 
2,525                nCountDone = nCountDone + 1 
2,526                Debug.Print "  " & "dtmAdd"; 
2,527             End If 
2,528   
2,529             If AddFieldToTable("", "dtmEdit", dbDate _ 
2,530                , , "*Now*", "date record was last edited", , tdf) Then 
2,531                nCountDone = nCountDone + 1 
2,532                Debug.Print "  " & "dtmEdit"; 
2,533             Else 
2,534                 'update Default Value of the edit date field
2,535                On Error Resume Next 
2,536                db.TableDefs(tdf.Name).Fields("dtmEdit").DefaultValue = "=Now()" 
2,537                If Err.Number = 0 Then 
2,538                   nCountUpdateDefaultValue = nCountUpdateDefaultValue + 1 
2,539                End If 
2,540                On Error GoTo Proc_Err 
2,541             End If 
2,542   
2,543              ' ----------------------------------------- Syncronization
2,544     '         If AddFieldToTable("", "IDsync", dbLong _
2,545     '            , , , "user who last synchronized this record", , tdf) Then
2,546     '            nCountDone = nCountDone + 1
2,547     '            Debug.Print "  origID";
2,548     '         End If
2,549     '         If AddFieldToTable("", "origID", dbLong _
2,550     '            , , "*Null*", "original ID", , tdf) Then
2,551     '            nCountDone = nCountDone + 1
2,552     '            Debug.Print "  origID";
2,553     '         End If
2,554     '         If AddFieldToTable("", "dtmSync", dbLong _
2,555     '            , , , "date/time syncronized", , tdf) Then
2,556     '            nCountDone = nCountDone + 1
2,557     '            Debug.Print "  dtmSync";
2,558     '         End If
2,559   
2,560     '         With tdf
2,561     '            'arrange the tracking fields
2,562     '            i = .Fields.Count
2,563     '
2,564     '            .Fields("IDAdd").OrdinalPosition = i
2,565     '            .Fields("IDEdit").OrdinalPosition = i + 1
2,566     '
2,567     '            .Fields("IDsync").OrdinalPosition = i + 2
2,568     '            .Fields("origID").OrdinalPosition = i + 3
2,569     '            .Fields("dtmSync").OrdinalPosition = i + 4
2,570     '
2,571     '            'make dtmAdd and dtmEdit the last fields
2,572     '            .Fields("dtmAdd").OrdinalPosition = i + 5
2,573     '            .Fields("dtmEdit").OrdinalPosition = i + 6
2,574     '
2,575     '
2,576     '         End With 'tdf
2,577   
2,578          End If 
2,579    NextTdf: 
2,580       Next tdf 
2,581   
2,582       MsgBox nCountChecked & " tables checked" & vbCrLf & vbCrLf _ 
2,583          & "Added " _ 
2,584          & nCountDone & " tracking fields" _ 
2,585          & vbCrLf & vbCrLf _ 
2,586          & "dtmEdit" & " Default Value checked/updated to Now() in " _ 
2,587             & nCountUpdateDefaultValue & " tables" _ 
2,588          , , "Add Tracking Fields to Table Design" 
2,589   
2,590    Proc_Exit: 
2,591       On Error Resume Next 
2,592        'close and release object variables
2,593       Set tdf = Nothing 
2,594       Set db = Nothing 
2,595       Exit Sub 
2,596   
2,597    Proc_Err: 
2,598     '   Select Case Err.Number
2,599     '      Case 3265: Resume NextTDF
2,600     '   End Select
2,601   
2,602       MsgBox Err.Description, , _ 
2,603            "ERROR " & Err.Number _ 
2,604            & "   addTrackingFieldsToTable" 
2,605   
2,606       Resume Proc_Exit 
2,607       Resume 
2,608   
2,609    End Sub 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

Update_dtmEdit_to_dtmAdd (68)

2,610   
2,611     '~~~~~~~~~~~~~~~~~~~~~~~~~~ RunAddFieldsToTable_Tracking
2,612    Sub Update_dtmEdit_to_dtmAdd() 
2,613     '091203 dbFailOnError
2,614   
2,615       Dim tdf As DAO.TableDef 
2,616       Dim s As String 
2,617   
2,618        'written by Crystal
2,619        'strive4peace2010 at yahoo.com
2,620        '5-18-09
2,621   
2,622        'will set dtmEdit = dtmAdd where it is null and dtmAdd has a value
2,623   
2,624       Dim nCountDone As Integer _ 
2,625          , sFieldname_DateAdd As String _ 
2,626          , sFieldname_DateEdit As String 
2,627   
2,628       sFieldname_DateAdd = "dtmAdd" 
2,629       sFieldname_DateEdit = "dtmEdit" 
2,630   
2,631       nCountDone = 0 
2,632   
2,633       For Each tdf In CurrentDb.TableDefs 
2,634          If Left(tdf.Name, 4) <> "Msys" Then 
2,635             Debug.Print 
2,636             Debug.Print tdf.Name & "..."; 
2,637             nCountDone = nCountDone + 1 
2,638   
2,639             s = "UPDATE [" & tdf.Name & "]" _ 
2,640                & " SET " & sFieldname_DateEdit & "=" & sFieldname_DateAdd _ 
2,641                & " WHERE (" & sFieldname_DateEdit & " Is Null)" _ 
2,642                & " AND (" & sFieldname_DateAdd & " Is Not Null);" 
2,643   
2,644              'rSql s 'needed module not here
2,645             CurrentDb.Execute s, dbFailOnError 
2,646   
2,647             s = "UPDATE [" & tdf.Name & "]" _ 
2,648                & " SET " & sFieldname_DateEdit & "=#" & Now() & "#" _ 
2,649                & " WHERE (" & sFieldname_DateEdit & " Is Null);" 
2,650              'rSql s 'needed module not here
2,651             CurrentDb.Execute s, dbFailOnError 
2,652   
2,653          End If 
2,654    NextTdf: 
2,655       Next tdf 
2,656   
2,657       MsgBox sFieldname_DateEdit & " set to " _ 
2,658          & sFieldname_DateAdd & " in " _ 
2,659          & nCountDone & " tables" _ 
2,660          , , "Update Edit Date to Add Date" 
2,661   
2,662    Proc_Exit: 
2,663       On Error Resume Next 
2,664        'close and release object variables
2,665       Set tdf = Nothing 
2,666       Exit Sub 
2,667   
2,668    Proc_Err: 
2,669   
2,670       MsgBox Err.Description, , _ 
2,671            "ERROR " & Err.Number _ 
2,672            & "   Update_dtmEdit_to_dtmAdd" 
2,673   
2,674       Resume Proc_Exit 
2,675       Resume 
2,676   
2,677    End Sub 
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

RenameTrackingFields (47)

2,678   
2,679    Public Sub RenameTrackingFields() 
2,680     'Crystal 101216
2,681   
2,682       Dim db As DAO.Database _ 
2,683          , tdf As DAO.TableDef _ 
2,684          , fld As DAO.Field 
2,685   
2,686       Dim i As Integer _ 
2,687          , j As Integer 
2,688   
2,689       Set db = DBEngine(0)(0) 
2,690   
2,691       i = 0 
2,692       j = 0 
2,693   
2,694       For Each tdf In CurrentDb.TableDefs 
2,695           'only rename fields in local tables
2,696          If Len(tdf.Connect & "") < 1 Then 
2,697              'ignore Microsoft system tables
2,698             If Left(tdf.Name, 4) <> "msys" Then 
2,699                 'look at all the field names
2,700                j = j + 1 
2,701                For Each fld In tdf.Fields 
2,702                   Select Case True 
2,703                      Case fld.Name = "datAdd" 
2,704                         fld.Name = "dtmAdd" 
2,705                         i = i + 1 
2,706                      Case fld.Name = "datEdit" 
2,707                         fld.Name = "dtmEdit" 
2,708                         i = i + 1 
2,709                      Case Else 
2,710                   End Select 
2,711                Next fld 
2,712             End If 
2,713          End If 
2,714       Next tdf 
2,715   
2,716       MsgBox "Made " & i & " changes to field names" _ 
2,717          & vbCrLf & vbCrLf & "Looked in " & j & " tables", , "Done" 
2,718   
2,719       Set fld = Nothing 
2,720       Set tdf = Nothing 
2,721       Set db = Nothing 
2,722   
2,723    End Sub 
2,724   
      Goto Top       Goto bas_crystal_code_general_1308       Goto Index

bas_Crystal_Properties_0806_130410_0429 (628)

PROCEDURES       Goto Top       Goto bas_Crystal_Properties_0806_130410_0429       Goto Modules       Goto Index
  1. Custom_Delete_Properties (27)
  2. Custom_SetDefaultProperties (222)
  3. Declaration Lines (2)
  4. Delete_Property (58)
  5. Get_Property (62)
  6. GetDefaultExampleID (10)
  7. HideDBWindow (10)
  8. IsPropertyDefined (45)
  9. RunDeleteDatabaseProperty (13)
  10. RunSet_Property (18)
  11. RunSetDatabaseProperties (13)
  12. runShow_Properties (7)
  13. Set_Property (87)
  14. SetDefaultExampleID (13)
  15. Show_Properties (26)
  16. ShowProperty (10)
  17. UnHideDBWindow (5)

Declaration Lines (2)

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

Set_Property (87)

3         '
4         '=======================================================
5         ' bas_Crystal_Properties_0806_130410_0429
6         ' ANALYZER: licensed to you for mon-commercial use
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, 140629
28        ' ~ Crystal
29        '              * have an awesome day :)
30        '                                                   www.AccessMVP.com/strive4peace
31        ' END LICENSE NOTICE
32        '============================================================
33        '3-12-08, 5-27-08
34        ' 6-17-08 IsPropertyDefined
35        '
36        ' this is a generic function to be used to
37        ' set or change a database property
38        '~~~~~~~~~~~~~~~~~~~~~ Set_Property
39       Function Set_Property( _ 
40          pPropName As String _ 
41          , Optional pValue As Variant _ 
42          , Optional pDataType As Long = 0 _ 
43          , Optional obj As Object _ 
44          , Optional bSkipMsg As Boolean = True _ 
45          ) As Byte 
46      
47           ' Crystal
48           ' strive4peace2010@yahoo.com
49           ' 8-9, 130410
50      
51           ' PARAMETERS
52           ' pPropName is the (database) property name to set
53           ' optional:
54           ' pValue is the value for the property
55           ' pDataType is the Data Type: dbBoolean, dbLong, dbText, ...
56           '   if not passed -- uses defaults
57           ' bSkipMsg = True: don't give user feedback
58           ' obj = database, field, tabledef, querydef,
59           '   or other object with properties
60           '   if obj is not specified, then CurrentDb is used
61      
62           'set up Error Handler
63          On Error GoTo Proc_Err 
64      
65          If obj Is Nothing Then 
66             Set obj = CurrentDb 
67          End If 
68      
69           'assume property is defined
70          obj.Properties(pPropName) = pValue 
71      
72       Done: 
73          On Error Resume Next 
74          If Not bSkipMsg Then 
75             MsgBox pPropName & " is " _ 
76             & obj.Properties(pPropName) _ 
77             & " for " & obj.Name, , "Done" 
78          End If 
79      
80       Proc_Exit: 
81          Exit Function 
82      
83       Proc_Err: 
84           'property is not defined
85          obj.Properties.Append obj.CreateProperty( _ 
86             pPropName, pDataType, pValue) 
87          Resume Done 
88          Resume 
89       End Function 
      Goto Top       Goto bas_Crystal_Properties_0806_130410_0429       Goto Index

Get_Property (62)

90      
91        '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
92        '
93        ' this is a generic function to be used to
94        ' get the value of a database property
95        ' you can pass an optional database object
96        ' if you want to look somewhere other than CurrentDb
97        '~~~~~~~~~~~~~~~~~~~~~ Get_Property
98       Function Get_Property( _ 
99          pPropName As String _ 
100         , Optional obj As Object _ 
101         , Optional pvDefaultValue As Variant _ 
102         ) As Variant 
103     
104          'Crystal
105          ' strive4peace2010@yahoo.com
106          ' 8-9, 130410, 130831 pvDefaultValue
107     
108          ' PARAMETERS
109          ' pPropName is the (database) property name to return the value of
110          ' optional:
111          ' obj = database, field, tabledef, querydef,
112          '   or other object with properties
113          '   if obj is not specified, then CurrentDb is used
114          '
115          'RETURNS
116          ' Null (or pvDefaultValue) if property has no value or is not defined
117          ' OR
118          ' Value of property
119     
120          ' Assumes all needed properties are defined
121     
122         On Error GoTo Proc_Err 
123     
124          'initialize return value
125         If Not IsNull(pvDefaultValue) Then 
126            Get_Property = pvDefaultValue 
127         Else 
128            Get_Property = Null 
129         End If 
130     
131         On Error GoTo Proc_Exit 
132     
133         If obj Is Nothing Then 
134            Set obj = CurrentDb 
135         End If 
136     
137         Get_Property = obj.Properties(pPropName) 
138     
139      Proc_Exit: 
140         On Error Resume Next 
141         Exit Function 
142     
143      Proc_Err: 
144     
145         MsgBox Err.Description, , _ 
146              "ERROR " & Err.Number _ 
147              & "   Get_Property: Property not defined" 
148     
149         Resume Proc_Exit 
150         Resume 
151      End Function 
      Goto Top       Goto bas_Crystal_Properties_0806_130410_0429       Goto Index

RunDeleteDatabaseProperty (13)

152       '
153       ' example to show how to use Delete_Property
154       '~~~~~~~~~~~~~~~~~~~~~ RunDeleteDatabaseProperty
155      Sub RunDeleteDatabaseProperty() 
156         Dim sPropName As String 
157     
158         sPropName = "DefaultUserID" 
159     
160         Delete_Property sPropName 
161     
162         MsgBox sPropName & " has been deleted", , "Done" 
163     
164      End Sub 
      Goto Top       Goto bas_Crystal_Properties_0806_130410_0429       Goto Index

Delete_Property (58)

165     
166     
167       '
168       ' this is a generic function to delete a database property
169       '~~~~~~~~~~~~~~~~~~~~~ Delete_Property
170      Function Delete_Property( _ 
171         ByVal pPropName As String _ 
172         , Optional bSkipMsg As Boolean = False _ 
173         , Optional obj As Object _ 
174         ) As Boolean 
175     
176          'Crystal
177          ' strive4peace2010@yahoo.com
178          ' 8-9, 130410
179     
180          ' PARAMETERS
181          ' pPropName is the (database) property name to return the value of
182          ' optional:
183          ' obj = database, field, tabledef, querydef,
184          '   or other object with properties
185          '   if obj is not specified, then CurrentDb is used
186          '
187          ' RETURNS
188          ' True -- property was deleted
189          ' False -- the property didn't exist to begin with
190     
191          'ignore errors -- it may not be set
192         On Error GoTo Proc_Err 
193     
194         Delete_Property = False 
195     
196         If obj Is Nothing Then 
197            Set obj = CurrentDb 
198         End If 
199     
200         obj.Properties.Delete pPropName 
201     
202         If Not bSkipMsg Then 
203            MsgBox pPropName & " is deleted", , "Done" 
204         End If 
205     
206         Delete_Property = True 
207     
208      Proc_Exit: 
209         On Error Resume Next 
210         Exit Function 
211     
212      Proc_Err: 
213     
214         MsgBox Err.Description, , _ 
215              "ERROR " & Err.Number _ 
216              & "   Delete_Property: " & pPropName 
217     
218         Resume Proc_Exit 
219         Resume 
220     
221     
222      End Function 
      Goto Top       Goto bas_Crystal_Properties_0806_130410_0429       Goto Index

IsPropertyDefined (45)

223     
224       '
225       ' this is a generic function to see if
226       ' a property is defined
227       '
228       '~~~~~~~~~~~~~~~~~~~~~ IsPropertyDefined
229      Function IsPropertyDefined( _ 
230         ByVal pPropName As String _ 
231         , Optional obj As Object _ 
232         ) As Boolean 
233       '121127, 130429
234          'Crystal, strive4peace
235          '130429 - used by the Analyzer: GetPropertyValue
236          'PARAMETERS
237          ' Obj can be a database, a Tabledef, a Field...
238          ' if it is missing, CurrentDb is used
239          '
240         On Error GoTo Proc_Err 
241     
242         IsPropertyDefined = False 
243     
244         Dim varValue As Variant 
245     
246          'may need to test for IsNull
247         If obj Is Nothing Then 
248            Set obj = CurrentDb 
249         End If 
250     
251         varValue = obj.Properties(pPropName) 
252     
253         IsPropertyDefined = True 
254     
255      Proc_Exit: 
256         On Error Resume Next 
257         Exit Function 
258     
259      Proc_Err: 
260         Resume Proc_Exit 
261     
262          'if you want to single-step code to find error, CTRL-Break at MsgBox
263          'then set this to be the next statement
264         Resume 
265     
266     
267      End Function 
      Goto Top       Goto bas_Crystal_Properties_0806_130410_0429       Goto Index

runShow_Properties (7)

268     
269       Sub runShow_Properties() 
270        '130402
271       '   Show_Properties CurrentDb.TableDefs("a_Flds").Fields("FldDesc")
272         Show_Properties CurrentDb.TableDefs("a_Flds") 
273     
274       End Sub 
      Goto Top       Goto bas_Crystal_Properties_0806_130410_0429       Goto Index

Show_Properties (26)

275        'loop through database properties
276       'show all in Debug window
277       '~~~~~~~~~~~~~~~~~~~~~ Show_Properties
278      Sub Show_Properties( _ 
279          Optional obj As Object _ 
280         ) 
281     
282          'Crystal (strive4peace2010@yahoo.com) ... 130430
283     
284         Dim prp As Property 
285         Dim i As Integer 
286         i = 0 
287         On Error Resume Next 
288     
289         If obj Is Nothing Then 
290            Set obj = CurrentDb 
291         End If 
292     
293         For Each prp In obj.Properties 
294            Debug.Print 
295            Debug.Print i, prp.Name; 
296               Debug.Print " = ", prp.Value; 
297            i = i + 1 
298         Next prp 
299         Set prp = Nothing 
300      End Sub 
      Goto Top       Goto bas_Crystal_Properties_0806_130410_0429       Goto Index

ShowProperty (10)

301     
302       '
303       'display value of the passed property
304       '~~~~~~~~~~~~~~~~~~~~~ ShowProperty
305      Sub ShowProperty(pPropName As String) 
306            MsgBox pPropName & " is " _ 
307            & CurrentDb.Properties(pPropName) _ 
308            & " for this database", , "Done" 
309     
310      End Sub 
      Goto Top       Goto bas_Crystal_Properties_0806_130410_0429       Goto Index

GetDefaultExampleID (10)

311     
312       '**************************************************
313       '~~~~~~~~~~~~~~~~~~~ these are in here as examples
314       '
315       ' to show how you can get and set a database property
316       '
317       'get the value of DefaultExampleID
318      Function GetDefaultExampleID() As Long 
319         GetDefaultExampleID = Nz(CurrentDb.Properties("DefaultExampleID"), 0) 
320      End Function 
      Goto Top       Goto bas_Crystal_Properties_0806_130410_0429       Goto Index

SetDefaultExampleID (13)

321       '
322       'set the value of DefaultExampleID, pass an value
323      Sub SetDefaultExampleID(pExampleID As Long) 
324     
325          'use the passed value to set a database property called ExampleID
326         Set_Property "DefaultExampleID", pExampleID, dbLong 
327     
328          'update a table with the value of the ExampleID
329         Dim s As String 
330         s = "UPDATE Tablename SET fieldname =" & pExampleID & ";" 
331         CurrentDb.Execute s 
332     
333      End Sub 
      Goto Top       Goto bas_Crystal_Properties_0806_130410_0429       Goto Index

RunSet_Property (18)

334       '
335       'initialize the DefaultExampleID property, show a message box
336      Sub RunSet_Property() 
337         Dim sPropName As String _ 
338         , nPropType As Long _ 
339         , mValue 
340     
341         sPropName = "DefaultExampleID" 
342         nPropType = dbLong 
343         mValue = 1 
344     
345         Set_Property sPropName, mValue, nPropType 
346     
347         MsgBox sPropName & " is " _ 
348         & CurrentDb.Properties(sPropName) _ 
349         & " for this database", , "Done" 
350     
351      End Sub 
      Goto Top       Goto bas_Crystal_Properties_0806_130410_0429       Goto Index

RunSetDatabaseProperties (13)

352       '
353       'see if DefaultExampleID property is defined
354       'if not, define it
355       '~~~~~~~~~~~~~~~~~~~~~ RunSetDatabaseProperties
356      Function RunSetDatabaseProperties() As Byte 
357     
358         If Not IsPropertyDefined("DefaultExampleID") Then 
359            Set_Property "DefaultExampleID", 1, dbLong 
360         End If 
361     
362         MsgBox "Default Database Properties are set", , "Done" 
363     
364      End Function 
      Goto Top       Goto bas_Crystal_Properties_0806_130410_0429       Goto Index

Custom_SetDefaultProperties (222)

365     
366       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
367       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
368     
369       '******************************************************
370       '              CUSTOM routines - RUN when CREATING a NEW database
371       '******************************************************
372       ' this is where you define the 'default' database properties
373       ' this will need to be run each time you
374       '   : create a copy of the database by importing objects
375       '     (since DATABASE PROPERTIES ARE NOT IMPORTED!!!)
376       '
377       '~~~~~~~~~~~~~~~~~~~~~ custom_SetDefaultProperties
378       ' CUSTOMIZE
379       '
380      Sub Custom_SetDefaultProperties( _ 
381         Optional psWhich As String = "" _ 
382         , Optional bSkipMsg As Boolean = True _ 
383         , Optional bSkipAlreadySet As Boolean = True _ 
384         , Optional psPropName As String = "" _ 
385         , Optional obj As Object _ 
386         ) 
387          '110522 .. password
388          '110918 userID, usrName, usrCatID
389          '110105 local_ConvertToProper
390        '100829, 30 template, 130831 local_CID
391     
392          'comment this line if you have not customized this procedure
393          'exit sub
394     
395          ' PARAMETERS
396          ' psWhich = property category
397          '   ie: db --> Overall database properties
398          '       find --> properties for the FIND form
399          '       if ZLS or not given,
400          '       default --> execute all categories
401          ' bSkipMsg = True: skip user intereraction
402          ' bSkipAlreadySet = True: skip if property already set
403          ' psPropName = set a specific property
404          '          if psWhich is not given, all categories will be searched
405          ' obj = database, field, tabledef, querydef,
406          '   or other object with properties
407          '   if obj is not specified, then DBEngine(0)(0) is used
408          '
409          ' CALLS
410          ' IsPropertyDefined if bSkipAlreadySet
411          ' Set_Property
412     
413         On Error GoTo Proc_Err 
414     
415         Dim i As Integer _ 
416            , sPropName As String _ 
417            , nPropType As Long _ 
418            , varValue As Variant 
419     
420         If obj Is Nothing Then 
421            Set obj = DBEngine(0)(0) 
422         End If 
423     
424          '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ DB properties
425     
426         If psWhich = "" Or psWhich = "db" Then 
427     
428            For i = 1 To 23 
429     
430               Select Case i 
431     
432               Case 1 
433                  sPropName = "local_IsAdmin" 
434                  nPropType = dbBoolean 
435                  varValue = True 
436     
437               Case 2 
438                  sPropName = "local_UserID" 
439                  nPropType = dbLong 
440                  varValue = 0 
441     
442               Case 3 
443                  sPropName = "local_FileBE" 
444                  nPropType = dbText 
445                  varValue = " " 
446     
447                '===============================================================
448                '                                   update when template changes
449                '===============================================================
450               Case 4 
451                  sPropName = "local_FileRpt" 
452                  nPropType = dbText 
453                  varValue = " " 
454     
455               Case 5 
456                  sPropName = "local_FileTemplate" 
457                  nPropType = dbText 
458                  varValue = " " 
459     
460               Case 6 
461                  sPropName = "local_PathRpt" 
462                  nPropType = dbText 
463                  varValue = " " 
464     
465               Case 7 
466                  sPropName = "local_PathBE"   'used by Admin 
467                  nPropType = dbText 
468                  varValue = " " 
469     
470               Case 8 
471                  sPropName = "local_PathTemplate" 
472                  nPropType = dbText 
473                  varValue = " " 
474     
475               Case 9 
476                  sPropName = "local__BE_is_ok" 
477                  nPropType = dbBoolean 
478                  varValue = False 
479     
480               Case 10 
481                  sPropName = "local_LastCID" 
482                  nPropType = dbBoolean 
483                  varValue = False 
484     
485               Case 11 
486                  sPropName = "local_ConvertToProper" 
487                  nPropType = dbBoolean 
488                  varValue = True 
489     
490               Case 12 
491                  sPropName = "local_Password" 
492                  nPropType = dbText 
493                  varValue = "secret" 
494     
495               Case 13 
496                  sPropName = "local_Title" 
497                  nPropType = dbText 
498                  varValue = "password" 
499     
500     
501               Case 14 
502                  sPropName = "local_UserName" 
503                  nPropType = dbText 
504                  varValue = " " 
505     
506               Case 15 
507                  sPropName = "local_CID" 
508                  nPropType = dbLong 
509                  varValue = -99 
510     
511               Case 16 
512                  sPropName = "local_usrCatID" 
513                  nPropType = dbLong 
514                  varValue = -99 
515     
516               Case 17   'Anywhere Attachments, Notes 
517                  sPropName = "local_RecordID" 
518                  nPropType = dbLong 
519                  varValue = -99 
520     
521               Case 18   'Anywhere Attachments, Notes 
522                  sPropName = "local_TID" 
523                  nPropType = dbLong 
524                  varValue = -99 
525     
526               Case 19 
527                  sPropName = "local_Contact" 
528                  nPropType = dbText 
529                  varValue = " " 
530     
531               Case 20   'Anywhere Attachments 
532                  sPropName = "local_PathAttRelative" 
533                  nPropType = dbText 
534                  varValue = "\Attachments\" 
535     
536               Case 21   'Anywhere Attachments FULL PATH without trailing \ 
537                  sPropName = "local_PathAtt" 
538                  nPropType = dbText 
539                  varValue = " " 'c:\database\Attachments" 
540     
541               Case 22 
542                  sPropName = "local_RolliD" 
543                  nPropType = dbLong 
544                  varValue = -99 
545     
546               Case 23 
547                  sPropName = "local_AdminMode" 
548                  nPropType = dbBoolean 
549                  varValue = False 
550               End Select 
551     
552     
553               If bSkipAlreadySet Then 
554                  If IsPropertyDefined(sPropName, obj) Then 
555                     GoTo NextProp_Db 
556                  End If 
557               End If 
558     
559               If sPropName = psPropName Then 
560                  Set_Property sPropName, varValue, nPropType, obj, bSkipMsg 
561                  GoTo Proc_Exit 
562               ElseIf psPropName = "" Then 
563                  Set_Property sPropName, varValue, nPropType, obj, bSkipMsg 
564               End If 
565      NextProp_Db: 
566            Next i 
567         End If 
568     
569         If Not bSkipMsg Then 
570            MsgBox "Default Database Properties are set", , "Done" 
571         End If 
572     
573      Proc_Exit: 
574         Exit Sub 
575     
576      Proc_Err: 
577         MsgBox Err.Description, , _ 
578              "ERROR " & Err.Number _ 
579              & "   custom_SetDefaultProperties" 
580     
581         Resume Proc_Exit 
582     
583          'if you want to single-step code to find error, CTRL-Break at MsgBox
584          'then set this to be the next statement
585         Resume 
586      End Sub 
      Goto Top       Goto bas_Crystal_Properties_0806_130410_0429       Goto Index

Custom_Delete_Properties (27)

587     
588      Function Custom_Delete_Properties(sBeginsWith As String) As Integer 
589       '140609 strive4peace
590         Dim prp As DAO.Property _ 
591            , db As DAO.Database 
592     
593         Dim i As Integer _ 
594            , iCount As Integer 
595     
596         Custom_Delete_Properties = 0 
597         iCount = 0 
598         Set db = CurrentDb 
599     
600         For i = (db.Properties.Count - 1) To 0 Step -1 
601            With db.Properties(i) 
602               If Left(.Name, Len(sBeginsWith)) = sBeginsWith Then 
603                  db.Properties.Delete .Name 
604                  iCount = iCount + 1 
605               End If 
606            End With 
607         Next i 
608     
609         Custom_Delete_Properties = iCount 
610         Set prp = Nothing 
611         Set db = Nothing 
612     
613      End Function 
      Goto Top       Goto bas_Crystal_Properties_0806_130410_0429       Goto Index

HideDBWindow (10)

614     
615       '*****************************
616       ' show or Hide the Database Window
617       ' (not related to properties, but it is here anyway )
618       '
619       '~~~~~~~~~~~~~~~~~~~~~ DB Window
620      Sub HideDBWindow() 
621         DoCmd.SelectObject acTable, "tablename", True 
622         RunCommand acCmdWindowHide 
623      End Sub 
      Goto Top       Goto bas_Crystal_Properties_0806_130410_0429       Goto Index

UnHideDBWindow (5)

624     
625      Sub UnHideDBWindow() 
626         DoCmd.SelectObject acTable, "tablename", True 
627      End Sub 
628     
      Goto Top       Goto bas_Crystal_Properties_0806_130410_0429       Goto Index

bas_Crystal_ReLinker_140629_080726_1001 (1250)

PROCEDURES       Goto Top       Goto bas_Crystal_ReLinker_140629_080726_1001       Goto Modules       Goto Index
  1. AddTextToTableDescription (88)
  2. ChangeTableDescriptions_ConnectInfo (133)
  3. Declaration Lines (2)
  4. DeleteAllTableDescriptions (35)
  5. FoundBackEnd (19)
  6. GetPathFromFilename (52)
  7. GetSourceTableDescriptions (105)
  8. GetTableDescription (48)
  9. InStrRev97 (21)
  10. IsBEok (42)
  11. ReLinker (497)
  12. run_ReLinker (119)
  13. SetPathAttachment (35)
  14. Split97 (44)
  15. testSetPathAttachment (10)

Declaration Lines (2)

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

run_ReLinker (119)

3         '
4         '=======================================================
5         '
6         ' module name: bas_Crystal_ReLinker_140629_080726_1001
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, 140629
28        ' ~ Crystal
29        '              * have an awesome day :)
30        '                                                   www.AccessMVP.com/strive4peace
31        ' END LICENSE NOTICE
32        '============================================================
33        '
34        ' uses Split97 code by Brent Spaulding (datAdrenaline)
35        '
36        ' works with Access 97 through Access 2007
37        '
38        ' NEEDS
39        ' Reference to Microsoft DAO Library
40        '
41        ' Do you have multiple back-ends in the same directory ?
42        ' ReLinker re-links all tables it can to files in the specified directory
43        '        (current database directory is used if path is not specified)
44        '
45        ' As a bonus, the table Description is updated to include:
46        '  Path, Filename, Source Table Name, and Date checked
47        '
48        ' Supported back-end types include Access, Excel, Lotus, Exchange,
49        '  Text, Paradox, FoxPro, or dBASE (nothing happens with ODBC tables)
50        '
51        ' Reports # Linked, # Resident, # links changed, # tables ignored,
52        ' # tables ignored (ODBC), # No Change, # tables can't re-link,
53        ' # NEED to be re-linked or deleted because current connect path\file not found
54        '   or if the table was not found
55        '
56        ' Contains:
57        '
58        ' common procedures that are called:
59           ' GetPathFromFilename
60           ' AddTextToTableDescription
61           ' IsPropertyDefined
62           ' InStrRev97
63           ' Split97 (courtesy of Brent Spaulding)
64        '
65        ' main procedures:
66        '
67        ' ReLinker
68        ' ChangeTableDescriptions_ConnectInfo
69        ' DeleteAllTableDescriptions
70        ' GetSourceTableDescriptions
71        '   calls GetTableDescription
72        '
73        ' ReLinker is a multi-back-end relinking program
74        ' ChangeTableDescriptions_ConnectInfo is a linked Table Description Labeler
75        ' DeleteAllTableDescriptions deletes all table descriptions that exist
76        ' GetSourceTableDescriptions gets Table Descriptions defined in the back-end
77        '
78        '=======================================================
79        ' to re-link back-end tables to current database directory
80        '            copy  -->   ReLinker
81        ' into Immediate window (CTRL_G) and press ENTER
82        '
83        ' to re-link back-end tables to current database directory
84        ' Display MsgBox
85        ' AND don't refresh if connect didn't change
86        ' AND skip changing table descriptions
87        ' (this is fastest)
88        '            copy  -->   ReLinker ,,False,True
89        ' into Immediate window and press ENTER
90        '
91        '=======================================================
92        '
93        ' if you have back-ends in multiple locations, call the Relinker for each path
94        '    in that case, you probably want to suppress the MsgBox at the end
95        '    and skip labeling table descriptions
96        '            ReLinker "c:\path", True,False,True
97        '    and, on last call
98        '            ReLinker "path"
99        '    to display MsgBox, refresh all the links, and label table descriptions
100       '=======================================================
101      Sub run_ReLinker() 
102     
103          ' click HERE
104          ' press F5 to Run Relinker
105          '
106          '  unchanged, this will try to change all connections
107          '  to a file in the current database directory
108     
109       '   Dim sPath As String
110     
111          'sPath can be specified
112       '   sPath = "c:\data\DirectoryName"
113     
114          'send desired path to the relinking procedure
115          ' note: we are not testing the return value
116          'ReLinker sPath
117     
118          'if nothing is sent, current database directory is used
119         ReLinker 
120     
121      End Sub 
      Goto Top       Goto bas_Crystal_ReLinker_140629_080726_1001       Goto Index

testSetPathAttachment (10)

122     
123     
124       '=======================================================
125       '=======================================================
126       'Custom PROCEDURES
127       '
128      Public Sub testSetPathAttachment() 
129         Call SetPathAttachment(CurrentProject.Path) 
130         MsgBox Get_Property("local_PathAtt"), , "local_PathAtt" 
131      End Sub 
      Goto Top       Goto bas_Crystal_ReLinker_140629_080726_1001       Goto Index

SetPathAttachment (35)

132     
133      Public Function SetPathAttachment(Optional ByVal psPath As String = "") As Boolean 
134       '131001
135         On Error GoTo Proc_Err 
136     
137         SetPathAttachment = False 
138         Dim sNewPath As String 
139     
140       '   If Not Len(psPath) > 0 Then  '------------- FORCE DIRECTORY to be under FE
141            psPath = CurrentProject.Path 
142       '   End If
143          'make \Attachments\ directory below passed path
144         If Not Right(psPath, 1) = "\" Then 
145            psPath = psPath & "\" 
146         End If 
147         sNewPath = psPath & "Attachments\" 
148         If Not MakeADirectory(sNewPath) Then GoTo Proc_Exit 
149     
150          'set "local_PathAtt"
151         Call Set_Property("local_PathAtt", Left(sNewPath, Len(sNewPath) - 1)) 
152     
153         SetPathAttachment = True 
154     
155      Proc_Exit: 
156         On Error Resume Next 
157         Exit Function 
158     
159      Proc_Err: 
160         MsgBox Err.Description, , _ 
161              "ERROR " & Err.Number _ 
162              & "   SetPathAttachment" 
163     
164         Resume Proc_Exit 
165         Resume 
166      End Function 
      Goto Top       Goto bas_Crystal_ReLinker_140629_080726_1001       Goto Index

FoundBackEnd (19)

167     
168      Public Function FoundBackEnd(psTablename As String) As Boolean 
169       '130902, 1001 strive4peace, 1010
170         Dim boo As Boolean 
171         FoundBackEnd = False 
172         boo = IsBEok(psTablename) 
173         If Not boo Then 
174            Call ReLinker 
175             'check again
176            boo = IsBEok(psTablename) 
177            If Not boo Then 
178               MsgBox "Can't find the Back End (be) database" _ 
179               & vbCrLf & vbCrLf & "Run the Linked Table Manager " _ 
180               & " on the External Data Ribbon" _ 
181               , , "Re-link tables manually" 
182            End If 
183         End If 
184         FoundBackEnd = boo 
185      End Function 
      Goto Top       Goto bas_Crystal_ReLinker_140629_080726_1001       Goto Index

IsBEok (42)

186     
187       '~~~~~~~~~
188      Function IsBEok( _ 
189         psTablename As String _ 
190         , Optional pBooKeepOpen As Boolean = False) As Boolean 
191       '130902, 140629
192         On Error GoTo Proc_Err 
193     
194          'test to see if back-end needs to be relinked
195         Dim db As DAO.Database _ 
196            , rs As DAO.Recordset 
197     
198         Set db = CurrentDb 
199         On Error Resume Next 
200         Err.Clear 
201         Set rs = db.OpenRecordset(psTablename, dbOpenSnapshot)   'ERROR if table not found 
202         If Err.Number > 0 Then 
203            IsBEok = False 
204         Else 
205            IsBEok = True 
206         End If 
207     
208      Proc_Exit: 
209         On Error Resume Next 
210         If Not pBooKeepOpen Then 
211             'release object variables
212            If Not rs Is Nothing Then 
213               rs.Close 
214               Set rs = Nothing 
215            End If 
216         End If 
217         Set db = Nothing 
218         Exit Function 
219     
220      Proc_Err: 
221         MsgBox Err.Description, , _ 
222              "ERROR " & Err.Number _ 
223              & "   IsBEok" 
224     
225         Resume Proc_Exit 
226         Resume 
227      End Function 
      Goto Top       Goto bas_Crystal_ReLinker_140629_080726_1001       Goto Index

ReLinker (497)

228     
229     
230     
231     
232       '=======================================================
233     
234       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ RelinkCurrentPath
235      Function ReLinker( _ 
236         Optional ByVal pPath As String _ 
237         , Optional booSkipMessage As Boolean = False _ 
238         , Optional booRefreshAll As Boolean = True _ 
239         , Optional booSkipTableDescription As Boolean = False _ 
240         ) As Integer 
241       '130902 booGotMessage
242          'Crystal
243          'strive4peace2008 at yahoo.com
244          'June 22, 2008
245     
246          ' put this code into a general (standard) module
247          ' name it --> bas_Crystal_ReLinker
248     
249          ' click HERE
250          ' press F5 to Run
251     
252          'changes each TableDef Connect string to the specified directory
253          ' the table Description is updated to include:
254          ' Path
255          ' Filename
256          ' SourceTableName
257          ' or, for ODBC, the Connect string
258     
259          'CALLS
260          ' GetPathFromFilename
261          ' AddTextToTableDescription
262          '    which calls IsPropertyDefined
263          '  SetPathAttachment
264     
265          '~~~~~~~~~~~~~~~~~~
266             'NEEDS reference to Microsoft DAO Library
267             'or
268             'Microsoft Office ##.0 Access Database Engine Object Library
269          '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
270     
271          'ASSUMPTION: Back-End databases are
272          'in the Current database directory
273          ' if this is not the case, nothing will happen for those tables
274     
275          'Linked Table Types include:
276          ' Access, Excel, Lotus, Exchange, Text, Paradox, FoxPro, or dBASE
277     
278          'no effect on ODBC tables
279     
280          'for more information, look at Debug (Immediate) Window when done CTRL-G
281     
282          'PARAMETERS
283          ' pPath is the path to use without the trailing backslash
284          '   path to the directory to use for back-ends
285          '   (default is Current Project Path)
286          '
287          ' booSkipMessage to skip the MsgBox at the end
288          '   (default = False, show message)
289          '
290          ' booRefreshAll to refresh all links even if connect string not changed
291          '   (default = True, refresh all even if connect string not changed)
292          '
293          ' booSkipTableDescription to skip changing the table description
294          '   (default = False, do change table descriptions to reflext connect info)
295          '
296          'RETURNS:
297          ' number of table links sucessfully changed
298     
299         On Error GoTo Proc_Err 
300     
301         Dim db As DAO.Database _ 
302            , tdf As DAO.TableDef 
303     
304         Dim nCountLinked As Integer _ 
305            , nCountNotLinked As Integer _ 
306            , nCountSuccess As Integer _ 
307            , nCountIgnore As Integer _ 
308            , nCountNoChange As Integer _ 
309            , nCountNewBad As Integer _ 
310            , nCountCurrentBad As Integer _ 
311            , strBad As String 
312     
313         Dim sDescription As String _ 
314            , varConnect As Variant _ 
315            , sPathConnect  As String _ 
316            , sFilename As String _ 
317            , sNewPathFilename As String _ 
318            , sCurrentPathFilename As String _ 
319            , sDbType As String 
320     
321         Dim arrConnect As Variant _ 
322            , i As Integer _ 
323            , sStr As String _ 
324            , booChange As Boolean _ 
325            , booFilenameInDatabaseParm As Boolean _ 
326            , booGotMessage As Boolean _ 
327            , sMsg As String 
328     
329         Dim dtmStart As Date 
330     
331         dtmStart = Now() 
332         sPathConnect = "" 
333     
334          'number of table links changed, nCountSuccess
335         ReLinker = 0 
336         booGotMessage = False 
337     
338         If Len(Trim(Nz(pPath, ""))) = 0 Then 
339             'if Path not specified, use the current database directory
340            pPath = GetPathFromFilename() 
341          '4-17-09
342         ElseIf InStr(pPath, ":") = 0 And Left(pPath, 2) <> "\\" Then 
343             'if path does not contain : then use current database directory
344            pPath = GetPathFromFilename() 
345         Else 
346             'strip training backslash if there ----------------- ?????
347            If Right(pPath, 1) = "\" Then 
348               pPath = Left(pPath, Len(pPath) - 1) 
349            End If 
350         End If 
351     
352         nCountLinked = 0 
353         nCountNotLinked = 0 
354         nCountSuccess = 0 
355         nCountIgnore = 0 
356         nCountNoChange = 0 
357         nCountNewBad = 0 
358         nCountCurrentBad = 0 
359         strBad = "" 
360     
361         Set db = CurrentDb 
362     
363          'loop through all the tables in the current database
364     
365         For Each tdf In db.TableDefs 
366     
367            sDescription = "" 
368     
369             'ignore Microsoft system tables
370            If Left(tdf.Name, 4) = "MSys" Then 
371               GoTo NextTdf 
372            End If 
373     
374            sDbType = "Access" 
375            Debug.Print tdf.Name; 
376     
377             'if table is not linked, go to the next table
378            If Len(Trim(Nz(tdf.SourceTableName, ""))) = 0 Then 
379               Debug.Print " -- NOT Linked" 
380               nCountNotLinked = nCountNotLinked + 1 
381               GoTo NextTdf 
382            End If 
383     
384            nCountLinked = nCountLinked + 1 
385     
386             'look at Connect string - Database Type is the first thing specified
387             ' if Connect string starts with ; nothing is specified so it is Access
388            i = InStr(tdf.Connect, ";") 
389            If i > 1 Then 
390               sDbType = Left(tdf.Connect, i - 1) 
391            End If 
392     
393            Debug.Print " -- Linked " & sDbType 
394            Debug.Print "   Connect: " & tdf.Connect 
395     
396             'initialize the new connect string
397            varConnect = Null 
398     
399             'assume connect string will not be changed
400            booChange = False 
401     
402             ' parse the connect string
403             ' have not used Split(tdf.Connect, ";")
404             ' so this code will be compatible with Access 97
405       'Stop
406            arrConnect = Split97(tdf.Connect, ";") 
407     
408             'loop through all the connect string parameters
409            If IsArray(arrConnect) Then 
410                For i = LBound(arrConnect) To UBound(arrConnect) 
411     
412                   If Left(arrConnect(i), 9) <> "DATABASE=" Then 
413                       'keep this connect string parameter the same
414                      varConnect = (varConnect + ";") & arrConnect(i) 
415                      GoTo NextConnectParameter 
416                   End If 
417     
418                   Select Case True 
419     
420                    'if Access, Excel, Lotus, Exchange, then change path in DATABASE spec
421                   Case Left(sDbType, 5) = "Excel" _ 
422                      , Left(sDbType, 5) = "Lotus" _ 
423                      , Left(sDbType, 8) = "Exchange" _ 
424                      , sDbType = "Access" 
425     
426                      booFilenameInDatabaseParm = True 
427     
428                      sCurrentPathFilename = Mid(arrConnect(i), 10) 
429                      sPathConnect = GetPathFromFilename(sCurrentPathFilename) 
430     
431                      sFilename = Right(arrConnect(i), Len(arrConnect(i)) - Len(sPathConnect) - 10) 
432     
433                      sDescription = sFilename _ 
434                         & " ~ " & tdf.SourceTableName _ 
435                         & " ~ " & pPath 
436     
437                    'for Text, Paradox, FoxPro, or dBASE, replace DATABASE parameter with path
438                    'SourceTableName is filename
439                   Case sDbType = "Text" _ 
440                      , Left(sDbType, 7) = "Paradox" _ 
441                      , Left(sDbType, 6) = "FoxPro" _ 
442                      , Left(sDbType, 5) = "DBASE" 
443     
444                      booFilenameInDatabaseParm = False 
445     
446                      sPathConnect = Mid(arrConnect(i), 10) 
447                      sFilename = tdf.SourceTableName 
448                      sCurrentPathFilename = sPathConnect & "\" & tdf.SourceTableName 
449     
450                      sDescription = tdf.SourceTableName _ 
451                         & " ~ " & pPath 
452     
453                    ' if ODBC or something else, do nothing
454                   Case Else 
455                      booChange = False 
456                      nCountIgnore = nCountIgnore 
457                      Debug.Print tdf.Connect 
458                      Debug.Print "  --> " & sDbType & " is Ignored" 
459                      If booRefreshAll Then GoTo RefreshLink 
460                      GoTo NextTdf 
461     
462                   End Select 
463     
464                   sNewPathFilename = pPath & "\" & sFilename 
465                   Debug.Print "  new path\filename = " & sNewPathFilename 
466     
467                   If Not Len(Dir(sNewPathFilename)) > 0 Then 
468                      'find the BE file --------------------------------------+~+~+~+~+~+~+~+~+~ CUSTOMIZE
469                     sFilename = Dir(pPath & "\*_be_*.accdb") 
470                     If Not Len(sFilename) > 0 Then 
471                        MsgBox "Relinker cannot find the back-end" _ 
472                           , , "Browse to the back-end database" 
473                        GoTo Proc_Exit 
474                     Else 
475     
476                        If Not booGotMessage Then 
477                           MsgBox "Relinking to " & sFilename _ 
478                              , , "Relinker found a different back-end database" 
479                           booGotMessage = True 
480                        End If 
481                        sNewPathFilename = pPath & "\" & sFilename 
482       '                  If Len(sPathConnect) > 0 Then
483       '                     Call SetPathAttachment(sPathConnect & "\Attachments")
484       '                  End If
485                     End If 
486                   End If 
487     
488     
489       'check filename too
490     
491     
492                   If sPathConnect = pPath Then 
493                       'no change in path
494                      If Len(Dir(sNewPathFilename)) > 0 Then 
495                          'file was found
496                         If Not booGotMessage Then 
497                           nCountNoChange = nCountNoChange + 1 
498                           Debug.Print "  --> No Change" 
499                           sDescription = sDescription _ 
500                              & " (" & Format(Date, "mmm-dd-yy") & ")" 
501                           If booRefreshAll Then GoTo RefreshLink 
502                        Else 
503                            'file has already been checked
504                        End If 
505                      Else 
506                          'file was NOT found
507                         nCountCurrentBad = nCountCurrentBad + 1 
508                         Debug.Print "  --> File Not found!" 
509                         sDescription = "FILE NOT FOUND ~ " & sDescription _ 
510                            & " (" & Format(Date, "mmm-dd-yy") & ")" 
511                         strBad = strBad & "  [" & tdf.Name & "]" 
512                         sPathConnect = "" 
513                        GoTo NextTdf 
514                      End If 
515                   End If 
516     
517                   If Len(Dir(sNewPathFilename)) > 0 Then 
518                       'new file was found
519                      booChange = True 
520                      Debug.Print "  --> change path"; 
521                      If booFilenameInDatabaseParm Then 
522                         varConnect = (varConnect + ";") & "DATABASE=" & sNewPathFilename 
523                      Else 
524                         varConnect = (varConnect + ";") & "DATABASE=" & pPath 
525                      End If 
526                      If Len(sPathConnect) > 0 Then 
527                        Call Set_Property("local_PathBE", sPathConnect) 
528                        Call SetPathAttachment(sPathConnect) 
529                     End If 
530                   Else 
531                      'new file was NOT found
532                      nCountNewBad = nCountNewBad + 1 
533                      Debug.Print "  --> PROBLEM: New File Not found"; 
534     
535                       'set description to use current path instead of new one
536                      If booFilenameInDatabaseParm Then 
537                         sDescription = sFilename & " ~ " 
538                      Else 
539                         sDescription = "" 
540                      End If 
541                      sDescription = sDescription & tdf.SourceTableName & " ~ " & sPathConnect 
542     
543                       'test current connection
544                      If Len(Dir(sCurrentPathFilename)) > 0 Then 
545                          'current file found
546                         Debug.Print "; Current File found" 
547                         sDescription = sDescription & _ 
548                            " (" & Format(Date, "mmm-dd-yy") & ")" 
549                         If booRefreshAll Then GoTo RefreshLink 
550                      Else 
551                          'current file NOT found
552                         nCountCurrentBad = nCountCurrentBad + 1 
553                         Debug.Print "  --> Current File NOT found!" 
554                         sDescription = "FILE NOT FOUND ~ " & sDescription & _ 
555                            " (" & Format(Date, "mmm-dd-yy") & ")" 
556                         strBad = strBad & "  [" & tdf.Name & "]" 
557                      End If 
558                      GoTo NextTdf 
559                   End If 
560     
561      NextConnectParameter: 
562                  Next i 
563              End If 
564     
565      TestNewConnectString: 
566             'if the constructed parameter is different, change it
567            If booChange Then 
568               On Error Resume Next 
569               tdf.Connect = varConnect 
570               If Err.Number > 0 Then 
571       '            Stop
572                  nCountCurrentBad = nCountCurrentBad + 1 
573                  strBad = strBad & "  [" & tdf.Name & "]" 
574                  Debug.Print " FAILED TO SET CONNECT STRING" 
575                  sDescription = sDescription & " (FAILED CONNECT " & Format(Date, "mmm-d-yy") & ")" 
576                  GoTo NextTdf 
577               End If 
578     
579            End If 
580     
581            On Error GoTo Proc_Err 
582            sDescription = sDescription & " (" & Format(Date, "mmm-d-yy") & ")" 
583            nCountSuccess = nCountSuccess + 1 
584            Debug.Print " SUCCESSFUL" 
585     
586      RefreshLink: 
587            On Error Resume Next 
588            Err.Number = 0 
589            tdf.RefreshLink 
590            If Err.Number > 0 Then 
591               nCountCurrentBad = nCountCurrentBad + 1 
592               strBad = strBad & "  [" & tdf.Name & "]" 
593               Debug.Print " FAILED TO REFRESH LINK" 
594               sDescription = "FAILED REFRESH ~ " & sDescription _ 
595                  & " (" & Format(Date, "mmm-d-yy") & ")" 
596            End If 
597            On Error GoTo Proc_Err 
598      NextTdf: 
599            If sDescription <> "" Then 
600               If Not booSkipTableDescription Then 
601                  AddTextToTableDescription tdf, sDescription, _ 
602                     , IIf(Left(db.Version, 1) <> "1", True, False)   'if not Access 2007, skip refresh 
603               End If 
604            End If 
605         Next tdf 
606     
607          'return table links changed
608         ReLinker = nCountSuccess 
609     
610         Debug.Print nCountLinked & " Linked tables" 
611         Debug.Print nCountNotLinked & " Resident Tables" 
612         Debug.Print nCountSuccess & " Links changed" 
613         Debug.Print nCountIgnore & " Tables Ignored" 
614         Debug.Print nCountNoChange & " No Change" 
615         Debug.Print nCountNewBad & " Problem Paths, can't change" 
616         Debug.Print nCountCurrentBad & " Tables NEED to be re-linked or deleted " 
617     
618         If Not booSkipTableDescription Then 
619             ' If Access 2007
620            If Left(db.Version, 1) = "1" Then 
621               db.TableDefs.Refresh   'necessary for Access 2007 
622            End If 
623             'make new table descriptions display immediately
624            Application.RefreshDatabaseWindow 
625         End If 
626     
627         If Not booSkipMessage Then 
628            sMsg = "Done Re-Linking Tables to " & sFilename _ 
629            & vbCrLf & vbCrLf & nCountLinked & " Linked Tables" _ 
630               & IIf(nCountNotLinked > 0, vbCrLf & nCountNotLinked _ 
631                  & " Resident Tables", "") _ 
632               & vbCrLf _ 
633               & IIf(nCountSuccess > 0, vbCrLf & nCountSuccess _ 
634                  & " Table Links changed to back-end found in --> " & pPath, "") _ 
635               & IIf(nCountNoChange > 0, vbCrLf & nCountNoChange _ 
636                  & " linked paths have no change", "") _ 
637               & IIf(nCountIgnore > 0, vbCrLf & nCountIgnore _ 
638                  & " tables ignored", "") _ 
639               & vbCrLf _ 
640               & IIf(nCountNewBad > 0, vbCrLf & nCountNewBad _ 
641                  & " tables couldn't be re-linked; new file not found", "") _ 
642               & IIf(nCountCurrentBad > 0, vbCrLf & " ... " _ 
643                  & nCountCurrentBad & " Tables NEED to be re-linked or deleted: " _ 
644                  & strBad _ 
645                  , "") _ 
646               & vbCrLf & vbCrLf & "Elapsed Time: " _ 
647                  & Format((Now() - dtmStart) * 24 * 60 * 60, "0") & " seconds" 
648     
649               MsgBox sMsg, , "Done Re-Linking Tables " 
650         End If 
651     
652      Proc_Exit: 
653     
654         Set tdf = Nothing 
655         Set db = Nothing 
656         Exit Function 
657     
658      Proc_Err: 
659     
660         MsgBox Err.Description, , _ 
661              "ERROR " & Err.Number _ 
662              & "   ReLinker" 
663     
664         Resume Proc_Exit 
665     
666          'if you want to single-step code to find error, CTRL-Break at MsgBox
667          'then set this to be the next statement
668         Resume 
669     
670      End Function 
671     
672       ''------------------------------------ IsPropertyDefined
673       ''
674       '' this is a generic function to see if
675       '' a property is defined
676       '' passed object can be a Table, Field, Database, ...
677       ''
678       'Function IsPropertyDefined( _
679       '   ByVal pPropName As String _
680       '   , Optional obj As Object _
681       '   ) As Boolean
682       '
683       '   'Crystal
684       '   'strive4peace2008 at yahoo.com
685       '   'June 20, 2008
686       '   '
687       '   'PARAMETERS
688       '   ' Obj can be a database, a Tabledef, a Field...
689       '   ' if it is missing, CurrentDb is used
690       '
691       '   On Error GoTo Proc_Err
692       '
693       '   IsPropertyDefined = False
694       '
695       '   Dim prp As DAO.Property
696       '
697       '   If obj Is Nothing Then
698       '      Set obj = CurrentDb
699       '   End If
700       '
701       '   For Each prp In obj.Properties
702       '      If prp.Name = pPropName Then
703       '         IsPropertyDefined = True
704       '         GoTo Proc_Exit
705       '      End If
706       '   Next prp
707       '
708       'Proc_Exit:
709       '   Set prp = Nothing
710       '   Exit Function
711       '
712       '
713       'Proc_Err:
714       '   MsgBox Err.Description, , _
715       '        "ERROR " & Err.Number _
716       '        & "   IsPropertyDefined"
717       '
718       '   Resume
719       '   Resume Proc_Exit
720       '
721       '   'if you want to single-step code to find error, CTRL-Break at MsgBox
722       '   'then set this to be the next statement
723       '
724       'End Function
      Goto Top       Goto bas_Crystal_ReLinker_140629_080726_1001       Goto Index

AddTextToTableDescription (88)

725     
726       '------------------------------------ AddTextToTableDescription
727       '
728       ' define or add information to a Table Description
729       '
730      Sub AddTextToTableDescription(tdf As TableDef _ 
731         , pText As String _ 
732         , Optional pDeli As String = "~~" _ 
733         , Optional booSkipRefresh As Boolean = False _ 
734         ) 
735     
736          'Crystal
737          'strive4peace2008 at yahoo.com
738          'June 22, 2008
739     
740          ' add pDeli and pText to the end of a table description
741          ' if there already is text starting with pDeli
742          '  anything after that is replaced
743          '
744          ' if pText is ZLS or spaces, the table description is deleted
745     
746          'PARAMETERS
747          ' tdf is the tabledef object
748          ' pText is the string to add to the table description
749          ' pDeli is the delimiter before the string that is added
750          '   (and, if the delimiter is already IN the description,
751          '    anything after it will be replaced)
752          ' booSkipRefresh: True to refresh database window when done
753          '    (default is False)
754     
755          'CALLS
756          '  IsPropertyDefined
757          '
758          ' Note: this routine DOES support changes to Microsoft System Objects
759          ' ie:
760          '  AddTextToTableDescription _
761          '       currentdb.TableDefs("MSysIMEXSpecs") _
762          '       ,"Import Specifications - Header"
763     
764          'set up Error Handler
765         On Error GoTo Proc_Err 
766     
767         Dim iPos As Integer _ 
768            , sStr As String 
769     
770         If IsPropertyDefined("Description", tdf) Then 
771     
772            If Len(Trim(pText)) = 0 Then 
773               tdf.Properties.Delete "Description" 
774            Else 
775               sStr = tdf.Properties("Description") 
776     
777               iPos = InStr(sStr, pDeli) 
778     
779               If iPos > 0 Then 
780                  sStr = Left(sStr, iPos - 1) & pDeli & pText 
781               Else 
782                  sStr = sStr & pDeli & pText 
783               End If 
784               tdf.Properties("Description") = Trim(sStr) 
785            End If 
786     
787         Else 
788            If Len(Trim(pText)) > 0 Then 
789               tdf.Properties.Append _ 
790                  tdf.CreateProperty("Description", dbText, pDeli & pText) 
791            End If 
792         End If 
793     
794         If Not booSkipRefresh Then 
795            If Left(CurrentDb.Version, 1) = "1" Then CurrentDb.TableDefs.Refresh: DoEvents 
796            Application.RefreshDatabaseWindow 
797         End If 
798     
799      Proc_Exit: 
800         Exit Sub 
801     
802      Proc_Err: 
803         MsgBox Err.Description, , _ 
804              "ERROR " & Err.Number _ 
805              & "   IsPropertyDefined" 
806     
807         Resume Proc_Exit 
808     
809          'if you want to single-step code to find error, CTRL-Break at MsgBox
810          'then set this to be the next statement
811         Resume 
812      End Sub 
      Goto Top       Goto bas_Crystal_ReLinker_140629_080726_1001       Goto Index

GetPathFromFilename (52)

813     
814       ' ********************************************************
815       '
816       '------------------------------------ GetPathFromFilename
817       ' GetPathFromFilename() without parameters is the same as
818       ' CurrentProject.Path
819       ' ...  used for compatibility with Access 97
820       '
821       ' this function also returns the path of a fully qualified filename
822       ' if the optional parameter is specified
823       '
824      Function GetPathFromFilename( _ 
825         Optional pPathFilename = "" _ 
826         ) As String 
827     
828          'Crystal
829          'strive4peace2008 at yahoo.com
830          'June 20, 2008
831     
832          'PARAMETERS
833          'pPathFilename is the filename to get path from
834          'if not specified, currentdb path is used
835     
836          'EXAMPLE RESULT:
837          ' c:\Path
838     
839          'note: path does NOT end in \
840     
841          ' CALLS
842          ' InStrRev97
843     
844         GetPathFromFilename = "" 
845     
846         Dim sPathFilename As String 
847         Dim i As Integer 
848     
849         If Len(Trim(Nz(pPathFilename, ""))) = 0 Then 
850            sPathFilename = CurrentDb.Name 
851         Else 
852            sPathFilename = pPathFilename 
853         End If 
854     
855     
856         i = InStrRev97(sPathFilename, "\") 
857     
858         If i > 1 Then 
859            GetPathFromFilename = Left(sPathFilename, i - 1) 
860         End If 
861     
862         GetPathFromFilename = Trim(GetPathFromFilename) 
863     
864      End Function 
      Goto Top       Goto bas_Crystal_ReLinker_140629_080726_1001       Goto Index

InStrRev97 (21)

865     
866       '------------------------------------ InStrRev97
867       ' used for compatibility with Access 97
868       '
869      Function InStrRev97(pString As String _ 
870         , pChar As String) As Integer 
871     
872         Dim i As Integer 
873     
874         InStrRev97 = 0 
875     
876         If Len(pString) = 0 Then Exit Function 
877     
878         For i = Len(pString) To 1 Step -1 
879            If Mid(pString, i, 1) = pChar Then 
880               InStrRev97 = i 
881               Exit Function 
882            End If 
883         Next i 
884     
885      End Function 
      Goto Top       Goto bas_Crystal_ReLinker_140629_080726_1001       Goto Index

Split97 (44)

886     
887       '------------------------------------ Split97
888       ' the following function was written by Brent Spaulding,
889       ' and is used for compatibility with Access 97
890       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
891      Public Function Split97(strExpression As String _ 
892         , strDelimiter As String _ 
893         ) As Variant 
894     
895          Dim aElements() As String 
896          Dim strTemp As String 
897          Dim X As Long 
898     
899           'Test for ZLS ... which raises and error in A2000+ Split()
900          On Error Resume Next 
901          If Len(strExpression) = 0 Then 
902              Err.Raise 13 
903              MsgBox "Run-Time Error: '13'" & vbCrLf & vbCrLf & Err.Description, vbExclamation 
904              Err.Clear: Exit Function 
905          End If 
906          On Error GoTo 0 
907     
908           'Initialize
909          strTemp = strExpression 
910          X = -1 
911          ReDim aElements(0) 
912     
913           'Loop the passed expression
914          Do Until X = 0 
915              X = InStr(1, strTemp, strDelimiter, vbTextCompare) 
916              If X > 0 Then 
917                  aElements(UBound(aElements)) = Left(strTemp, X - 1) 
918                  strTemp = Mid(strTemp, X + Len(strDelimiter)) 
919                  ReDim Preserve aElements(UBound(aElements) + 1) 
920              End If 
921          Loop 
922     
923           'Fill the last element
924          aElements(UBound(aElements)) = strTemp 
925     
926           'Return the result
927          Split97 = aElements 
928     
929      End Function 
      Goto Top       Goto bas_Crystal_ReLinker_140629_080726_1001       Goto Index

DeleteAllTableDescriptions (35)

930     
931       '********************************************************************
932       '********************************************************************
933       '------------------------------------ DeleteAllTableDescriptions
934       '
935       ' Delete all table descriptions
936       ' not called in this module ... included for fun 
937       '
938      Sub DeleteAllTableDescriptions() 
939     
940          ' CALLS
941          ' AddTextToTableDescription
942     
943         On Error Resume Next 
944     
945         Dim db As DAO.Database _ 
946            , tdf As DAO.TableDef 
947     
948         Set db = CurrentDb 
949     
950         db.TableDefs.Refresh 
951     
952         For Each tdf In db.TableDefs 
953            AddTextToTableDescription tdf, "", , True 
954         Next tdf 
955     
956         db.TableDefs.Refresh 
957         Application.RefreshDatabaseWindow 
958     
959         Set tdf = Nothing 
960         Set db = Nothing 
961     
962         MsgBox "Done deleting all table descriptions", , "Done" 
963     
964      End Sub 
      Goto Top       Goto bas_Crystal_ReLinker_140629_080726_1001       Goto Index

ChangeTableDescriptions_ConnectInfo (133)

965     
966       '------------------------------------ ChangeTableDescriptions_ConnectInfo
967       '
968       ' specify information from Connect String in Table Description
969       ' Filename ~ SourceTable ~ Path
970       '
971       ' adds information if Table already has a description
972       ' replaces connect info if
973       '
974       ' not called in this module ... included for fun 
975       '
976      Sub ChangeTableDescriptions_ConnectInfo( _ 
977          Optional booSkipRefresh As Boolean = True) 
978     
979          'Crystal
980          'strive4peace2008 at yahoo.com
981          'June 20, 2008
982     
983          'NEEDS
984          ' Reference to Microsoft DAO Library
985     
986          ' click HERE
987          ' press F5 to Run
988     
989          'CALLS
990          '  AddTextToTableDescription
991          '    which calls IsPropertyDefined
992     
993         Dim db As DAO.Database _ 
994            , tdf As DAO.TableDef 
995     
996         Dim sDescription As String _ 
997            , sPathConnect  As String _ 
998            , sFilename As String _ 
999            , sDbType As String _ 
1,000          , arrConnect As Variant _ 
1,001          , i As Integer 
1,002   
1,003       Set db = CurrentDb 
1,004   
1,005        'loop through all the tables in the current database
1,006   
1,007       For Each tdf In db.TableDefs 
1,008   
1,009          sDbType = "" 
1,010          sDescription = "" 
1,011   
1,012           'if the table is not linked, skip it
1,013          If Not tdf.SourceTableName <> "" Then GoTo NextTdf 
1,014   
1,015           'look at Connect string - Database Type is the first thing specified
1,016           ' if Connect string starts with ; nothing is specified so it is Access
1,017          i = InStr(tdf.Connect, ";") 
1,018          If i > 1 Then 
1,019             sDbType = Left(tdf.Connect, i - 1) 
1,020          End If 
1,021   
1,022           'parse the connect string
1,023          arrConnect = Split97(tdf.Connect, ";") 
1,024   
1,025           'loop through all the connect string parameters
1,026          If IsArray(arrConnect) Then 
1,027              For i = LBound(arrConnect) To UBound(arrConnect) 
1,028   
1,029                 If Left(arrConnect(i), 9) <> "DATABASE=" Then 
1,030                    GoTo NextConnectParameter 
1,031                 End If 
1,032   
1,033                 Select Case True 
1,034   
1,035                  'if Access, Excel, Lotus, Exchange, DATABASE specifies Path and Filename
1,036                 Case Left(sDbType, 5) = "Excel" _ 
1,037                    , Left(sDbType, 5) = "Lotus" _ 
1,038                    , Left(sDbType, 8) = "Exchange" _ 
1,039                    , sDbType = "" 
1,040   
1,041                    sPathConnect = GetPathFromFilename(Mid(arrConnect(i), 10)) 
1,042                    sFilename = Right(arrConnect(i), Len(arrConnect(i)) - Len(sPathConnect) - 10) 
1,043   
1,044                    sDescription = sFilename _ 
1,045                       & " ~ " & tdf.SourceTableName _ 
1,046                       & " ~ " & sPathConnect 
1,047   
1,048                  'for Text, Paradox, FoxPro, or dBASE, DATABASE specifies path
1,049                 Case sDbType = "Text" _ 
1,050                    , Left(sDbType, 7) = "Paradox" _ 
1,051                    , Left(sDbType, 6) = "FoxPro" _ 
1,052                    , Left(sDbType, 5) = "DBASE" 
1,053   
1,054                    sPathConnect = Mid(arrConnect(i), 10) 
1,055   
1,056                    sDescription = tdf.SourceTableName _ 
1,057                       & " ~ " & sPathConnect 
1,058   
1,059                  ' if ODBC or something else, show whole connect string
1,060                 Case Else 
1,061                    sDescription = arrConnect(i) 
1,062   
1,063                 End Select 
1,064   
1,065                 AddTextToTableDescription tdf, sDescription, , booSkipRefresh 
1,066                 GoTo NextTdf 
1,067   
1,068    NextConnectParameter: 
1,069              Next i 
1,070        End If 
1,071    NextTdf: 
1,072   
1,073       Next tdf 
1,074   
1,075        'make new table descriptions display immediately
1,076       db.TableDefs.Refresh 
1,077       Application.RefreshDatabaseWindow 
1,078   
1,079       MsgBox "Done adding Connect info to Table Descriptions", , "Done" 
1,080   
1,081    Proc_Exit: 
1,082       Set tdf = Nothing 
1,083       Set db = Nothing 
1,084       Exit Sub 
1,085   
1,086    Proc_Err: 
1,087       MsgBox Err.Description, , _ 
1,088            "ERROR " & Err.Number _ 
1,089            & "   ChangeTableDescriptions_ConnectInfo" 
1,090   
1,091       Resume Proc_Exit 
1,092   
1,093        'if you want to single-step code to find error, CTRL-Break at MsgBox
1,094        'then set this to be the next statement
1,095       Resume 
1,096   
1,097    End Sub 
      Goto Top       Goto bas_Crystal_ReLinker_140629_080726_1001       Goto Index

GetSourceTableDescriptions (105)

1,098   
1,099     '------------------------------------ GetSourceTableDescriptions
1,100     '
1,101     ' change Table Description to whatever is in the back-end
1,102     '
1,103     ' not called in this module ... included for fun 
1,104     '
1,105    Sub GetSourceTableDescriptions() 
1,106   
1,107        'Crystal
1,108        'strive4peace2008 at yahoo.com
1,109        'July 25, 2008
1,110   
1,111        'NEEDS
1,112        ' Reference to Microsoft DAO Library
1,113   
1,114        ' click HERE
1,115        ' press F5 to Run
1,116   
1,117        'CALLS
1,118        '  GetTableDescription
1,119        '  IsPropertyDefined
1,120   
1,121       On Error GoTo Proc_Err 
1,122   
1,123       Dim db As DAO.Database _ 
1,124          , dbLink As DAO.Database _ 
1,125          , tdf As DAO.TableDef 
1,126   
1,127       Dim sPathFilename As String _ 
1,128          , sDescription As String _ 
1,129          , i As Integer 
1,130   
1,131       Set db = CurrentDb 
1,132   
1,133        'loop through all the tables in the current database
1,134   
1,135       For Each tdf In db.TableDefs 
1,136   
1,137   
1,138           'if the table is not linked, skip it
1,139          If Not tdf.SourceTableName <> "" Then GoTo NextTdf 
1,140   
1,141           'look at Connect string - Database Type is the first thing specified
1,142           ' if Connect string starts with ;
1,143           ' then nothing is specified so it is Access
1,144           ' skip tables that are not connected to an Access back-end
1,145          If InStr(tdf.Connect, ";") > 1 Then 
1,146             GoTo NextTdf 
1,147          End If 
1,148   
1,149   
1,150          i = InStr(tdf.Connect, "DATABASE=") 
1,151   
1,152          sPathFilename = Mid(tdf.Connect, i + 9) 
1,153   
1,154          If Len(Trim(Dir(sPathFilename))) = 0 Then 
1,155             GoTo NextTdf 
1,156          End If 
1,157   
1,158          Set dbLink = OpenDatabase(sPathFilename) 
1,159   
1,160          sDescription = GetTableDescription(tdf.SourceTableName, dbLink) 
1,161   
1,162          If sDescription <> "" Then 
1,163             If IsPropertyDefined("Description", tdf) Then 
1,164                tdf.Properties("Description") = sDescription 
1,165             Else 
1,166                tdf.Properties.Append _ 
1,167                tdf.CreateProperty("Description", dbText, sDescription) 
1,168             End If 
1,169          End If 
1,170   
1,171    NextTdf: 
1,172   
1,173       Next tdf 
1,174   
1,175        'make new table descriptions display immediately
1,176       db.TableDefs.Refresh 
1,177       Application.RefreshDatabaseWindow 
1,178   
1,179       MsgBox "Done changing Table Descriptions to SourceTable Description", , "Done" 
1,180   
1,181    Proc_Exit: 
1,182       Set tdf = Nothing 
1,183       Set db = Nothing 
1,184       If Not dbLink Is Nothing Then 
1,185          dbLink.Close 
1,186          Set dbLink = Nothing 
1,187       End If 
1,188       Exit Sub 
1,189   
1,190    Proc_Err: 
1,191   
1,192       MsgBox Err.Description, , _ 
1,193            "ERROR " & Err.Number _ 
1,194            & "   GetSourceTableDescriptions" 
1,195   
1,196       Resume Proc_Exit 
1,197   
1,198        'if you want to single-step code to find error, CTRL-Break at MsgBox
1,199        'then set this to be the next statement
1,200       Resume 
1,201   
1,202    End Sub 
      Goto Top       Goto bas_Crystal_ReLinker_140629_080726_1001       Goto Index

GetTableDescription (48)

1,203   
1,204     '------------------------------------ GetTableDescription
1,205     '
1,206    Function GetTableDescription( _ 
1,207       ByVal pTablname As String _ 
1,208       , dbObj As DAO.Database _ 
1,209       ) As String 
1,210   
1,211        'Crystal
1,212        'strive4peace2008 at yahoo.com
1,213        'July 25, 2008
1,214        '
1,215        'PARAMETERS
1,216        ' pTablname is the name of the table
1,217        ' dbObj is a database object
1,218   
1,219        'RETURNS
1,220        ' Table Description if defined
1,221        ' an empty string (ZLS) if not
1,222        '
1,223       On Error GoTo Proc_Err 
1,224   
1,225       GetTableDescription = "" 
1,226   
1,227       Dim prp As DAO.Property 
1,228   
1,229       For Each prp In dbObj.TableDefs(pTablname).Properties 
1,230          If prp.Name = "Description" Then 
1,231             GetTableDescription = prp 
1,232             GoTo Proc_Exit 
1,233          End If 
1,234       Next prp 
1,235   
1,236    Proc_Exit: 
1,237       Set prp = Nothing 
1,238       Exit Function 
1,239   
1,240   
1,241    Proc_Err: 
1,242       MsgBox Err.Description, , _ 
1,243            "ERROR " & Err.Number _ 
1,244            & "   GetTableDescription" 
1,245   
1,246       Resume Proc_Exit 
1,247       Resume 
1,248   
1,249    End Function 
1,250   
      Goto Top       Goto bas_Crystal_ReLinker_140629_080726_1001       Goto Index

bas_Crystal_RunSQL_130522 (336)

PROCEDURES       Goto Top       Goto bas_Crystal_RunSQL_130522       Goto Modules       Goto Index
  1. Declaration Lines (49)
  2. EndTime (21)
  3. GetElapsedTime (27)
  4. ReportElapsedTime (62)
  5. reportProgress (11)
  6. ResetStuff (10)
  7. rSql (141)
  8. StartTime (15)

Declaration Lines (49)

1         'Attribute VB_Name = "bas_Crystal_RunSQL_130501"
2        Option Compare Database 
3        Option Explicit 
4         '
5         '=======================================================
6         ' bas_Crystal_RunSQL_130417
7         ' ANALYZER: licensed to you for non-commercial use
8         '============================================================ LICENSE NOTICE -- must not be modified
9         ' This software is licensed to you under CC BY-NC-SA 3.0
10        '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
11        ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
12        '
13        ' You are free to:
14        '    Share — copy and redistribute the material in any medium or format
15        '    Adapt — remix, transform, and build upon the material
16        ' The licensor cannot revoke these freedoms as long as you follow these terms:
17        '    Attribution — You must give appropriate credit, provide a link to the license,
18        '                   and indicate if changes were made.
19        '                   You may do so in any reasonable manner,
20        '                   but not in any way that suggests the licensor endorses you or your use.
21        '    NonCommercial — You may not use the material for commercial purposes.
22        '    ShareAlike — If you remix, transform, or build upon the material,
23        '                 you must distribute your contributions under the same license as the original.
24        '
25        ' many procedures and module names contain author or controbitor names that must be left intact
26        ' if you make changes, add your name, date, and descriptive information to the comments
27        '
28        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629
29        ' ~ Crystal
30        '              * have an awesome day :)
31        '                                                   www.AccessMVP.com/strive4peace
32        ' END LICENSE NOTICE
33        '============================================================
34        '
35        'modified 3-8-08
36        '100321 ReportElapsedTime
37        '130410
38      
39        '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
40        'dimension this at the top of the module
41       Dim mDtmStartr As Single _ 
42          , mDtmStart As Date _ 
43          , mNumSQL As Long 
44      
45       Dim m_db As DAO.Database _ 
46          , m_rsSQL As DAO.Recordset 
47      
48        'set the to True to turn on capture of SQL statements to usys_SQL table
49       Const WRITESQL = False 
      Goto Top       Goto bas_Crystal_RunSQL_130522       Goto Index

ResetStuff (10)

50      
51        '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
52       Function ResetStuff() 
53        '11-15-08
54          DoCmd.Echo True 
55          DoCmd.SetWarnings True 
56          DoCmd.Hourglass False 
57          SysCmd acSysCmdClearStatus 
58          MsgBox "Done Resetting Echo, Warnings, Hourglass, and Status Bar", , "Done" 
59       End Function 
      Goto Top       Goto bas_Crystal_RunSQL_130522       Goto Index

StartTime (15)

60      
61        'call this at the beginning of your program:
62        '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
63       Sub StartTime(Optional pMsg) 
64          On Error Resume Next 
65          mDtmStartr = Timer() 
66          mDtmStart = Now() 
67          mNumSQL = 0 
68          DoCmd.Hourglass True 
69           'if you are writing the statements
70           'figure out the last ID used
71        '   pFirstSQL = Nz(DMax("id", "usys_sql"), 0) + 1
72          If IsMissing(pMsg) Then Exit Sub 
73          Debug.Print "--- START-------------" & pMsg & " ----- " & CStr(mDtmStart) 
74       End Sub 
      Goto Top       Goto bas_Crystal_RunSQL_130522       Goto Index

EndTime (21)

75      
76        ' call this in exit code
77        '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
78       Sub EndTime() 
79           'this should run in the Exit code when ReportElapsedTime is used
80           ' ReportElapsedTime ran
81          If Nz(mDtmStart, 0) < 0 Then Exit Sub 
82      
83          On Error Resume Next 
84          DoCmd.Hourglass False 
85          SysCmd acSysCmdClearStatus 
86          Debug.Print "End " & Format(Now(), "h:nn") & " ----" & mNumSQL & " SQL Statements" 
87          On Error Resume Next 
88          If WRITESQL = True Then 
89             If Not m_rsSQL Is Nothing Then 
90                m_rsSQL.Close 
91                Set m_rsSQL = Nothing 
92             End If 
93          End If 
94          If Not m_db Is Nothing Then Set m_db = Nothing 
95       End Sub 
      Goto Top       Goto bas_Crystal_RunSQL_130522       Goto Index

reportProgress (11)

96      
97        'if you want to report progress to the user periodically:
98        '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
99       Sub reportProgress(Optional pMsg As String = "") 
100         If Len(pMsg) > 0 Then 
101            SysCmd acSysCmdSetStatus, pMsg & "..." 
102         Else 
103            SysCmd acSysCmdClearStatus 
104         End If 
105       '   Debug.Print pMsg
106      End Sub 
      Goto Top       Goto bas_Crystal_RunSQL_130522       Goto Index

ReportElapsedTime (62)

107     
108       'tell the user how long everything took
109       'this is called when execution was good
110       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
111      Function ReportElapsedTime( _ 
112         Optional ByVal pMessage As String = "" _ 
113         , Optional ByVal pTitle As String = "" _ 
114         , Optional ByVal pBooSkipMessage As Boolean = False _ 
115         ) As Single 
116       ' Crystal (strive4peace)
117     
118       '100321, 130410, 17, 120522
119     
120         On Error Resume Next 
121     
122         ReportElapsedTime = -1 
123         DoCmd.Hourglass False 
124         SysCmd acSysCmdClearStatus 
125     
126         Dim mNumSeconds As Single 
127     
128         If pMessage <> "" Then 
129            pMessage = pMessage _ 
130               & vbCrLf & "-------------" _ 
131               & vbCrLf 
132            Debug.Print "-------------" & pMessage & " ----- " & mNumSQL & " SQL steps" 
133         End If 
134     
135         If Date = CDate(mDtmStart) Then 
136            mNumSeconds = (Timer() - mDtmStartr) 
137         Else 
138             'assume just one day has passed
139             'seconds from yesterday + seconds today
140            mNumSeconds = ((24 * 60 * 60) - mDtmStartr) + Timer() 
141         End If 
142     
143         pMessage = pMessage & "Start Time: " & Format(mDtmStart, "hh:nn:ss") & vbCrLf _ 
144            & "End Time: " & Format(Now(), "hh:nn:ss") & "     --> " _ 
145            & "     Elapsed Time: " & Format(mNumSeconds, "#,##0.##") & " seconds" 
146     
147         If Not pBooSkipMessage Then 
148            MsgBox pMessage, , IIf(pTitle <> "", "Time to execute         ", pTitle) 
149               '& CStr(Nz(pFirstSQL, -1))
150         End If 
151         If Len(pTitle) > 0 Then 
152            Debug.Print "Time to execute         ", pTitle 
153         End If 
154     
155         Debug.Print pMessage 
156         mDtmStart = -99 
157     
158         ReportElapsedTime = mNumSeconds 
159     
160         On Error Resume Next 
161         If WRITESQL = True Then 
162            If Not m_rsSQL Is Nothing Then 
163               m_rsSQL.Close 
164               Set m_rsSQL = Nothing 
165            End If 
166         End If 
167         If Not m_db Is Nothing Then Set m_db = Nothing 
168      End Function 
      Goto Top       Goto bas_Crystal_RunSQL_130522       Goto Index

rSql (141)

169     
170       '~~~~~~~~~~~~~~~~~~~~~~~~ rSql
171       ' Apr 2010
172       ' After/During your code runs, check the debug window (CTRL-G).
173       ' If any of the statements do not have a time line below them,
174       '    they did not execute properly if IsAggregateUpdate was not specified
175       ' You can copy the SQL to a query to figure out why.
176      Function rSql( _ 
177         ByVal pSQL As String _ 
178         , Optional pMsg As String = "" _ 
179         , Optional IsAggregateUpdate As Boolean = False _ 
180         , Optional NoDebug As Boolean = False _ 
181         , Optional booCount As Boolean = True _ 
182         , Optional pDb As DAO.Database _ 
183         ) As Long 
184       'crystal 100412, 130410, 130417, 130501, 130522
185       'be sure to run EndTime or ReportElapsedTime to cleanup
186       '130908 pass pDB -- not tested
187     
188          'execute an SQL string with CurrentDb.execute
189          'unless IsAggregateUpdateIsAggregateUpdate is True
190          ' ... in that case, use DoCmd.RunSQL
191     
192          'parameters
193          ' pSQL --> SQL to execute
194          ' pMsg --> optional, message to write to StatusBar
195          ' IsAggregateUpdate --> optional, true - ie: if SQL has aggregate function and doesn't work with CurrentDb.Execute
196          ' NoDebug --> optional, True to skip output to debug window
197          ' NoCount --> optional, True : don't count this SQL statement
198     
199          'EXAMPLES
200          ' rSql strSQL
201          ' rSQL strSQL, "update changed records in Parts"
202          ' Dim nNumRecords as long, strSQL as string
203          '     strSQL = "UPDATE ..."
204          '     nNumRecords = rSQL(strSQL, "message")
205          '
206          ' if you send messages to the SQL, you have to remember to do:
207          ' SysCmd acSysCmdClearStatus
208          ' or run EndTime or ReportElapsedTime if you are batching statements
209          '
210         On Error GoTo Proc_Err 
211     
212         If m_db Is Nothing Then 
213            If Not pDb Is Nothing Then 
214               Set m_db = pDb 
215            Else 
216               Set m_db = CurrentDb 
217            End If 
218         End If 
219     
220         Dim nTimer As Single _ 
221            , nSeconds As Single _ 
222            , sTime As String _ 
223            , nNumRecs As Long 
224     
225          'returns a negative number if SQL could not be executed
226         nNumRecs = -1 
227     
228         nTimer = Timer()   'use Timer so fractional seconds can be reported 
229     
230         If Len(pMsg) > 0 Then 
231             'sometimes I turn this on
232       '      Debug.Print "---------- " & pMsg
233            SysCmd acSysCmdSetStatus, pMsg & "..." 
234         End If 
235     
236         If booCount Then 
237             'count the SQL statement
238            mNumSQL = mNumSQL + 1 
239         End If 
240     
241         If Not NoDebug Then 
242            If booCount Then 
243                'report statement number if it is being counted
244               Debug.Print mNumSQL & ")  "; 
245            End If 
246            Debug.Print Trim(pSQL) 
247         End If 
248     
249         If IsAggregateUpdate Then 
250            DoCmd.Echo False 
251            DoCmd.SetWarnings False 
252            DoCmd.RunSQL pSQL 
253            DoCmd.Echo True 
254            DoCmd.SetWarnings True 
255             'can't count records when this method is used
256            nNumRecs = 0 
257         Else 
258            With m_db 
259               .Execute pSQL 
260               nNumRecs = .RecordsAffected 
261            End With 
262         End If 
263         nSeconds = (Timer() - nTimer) 
264         If nSeconds > 60 Then 
265            sTime = Format(nSeconds / 60, "#,##0.###") & " minutes"   'minutes 
266         Else 
267            sTime = Format(nSeconds, "#,##0.###") & " seconds"    'seconds 
268         End If 
269         rSql = nNumRecs 
270         If Not NoDebug Then 
271            Debug.Print _ 
272               " -- " & sTime _ 
273               & " --- " & nNumRecs _ 
274               & " --- " & IIf(IsMissing(pMsg), "", pMsg) 
275         End If 
276     
277          'write information to a table
278         If WRITESQL = True Then 
279            If m_rsSQL Is Nothing Then 
280               Set m_rsSQL = m_db.OpenRecordset("usys_SQL", dbOpenDynaset, dbAppendOnly) 
281            End If 
282            With m_rsSQL 
283               .AddNew 
284                  !memSql = pSQL 
285                  If Len(pMsg) > 0 Then !Msg = pMsg 
286                  !NumSec = nSeconds 
287                  !numrecs = nNumRecs 
288               .Update 
289            End With   'm_rsSQL 
290         End If   'WRITESQL 
291     
292         m_db.TableDefs.Refresh 
293         DoEvents 
294     
295      Proc_Exit: 
296         On Error Resume Next 
297         rSql = nNumRecs 
298         Exit Function 
299     
300      Proc_Err: 
301       'Stop
302         If IsAggregateUpdate Then 
303            DoCmd.Echo True 
304            DoCmd.SetWarnings True 
305         End If 
306     
307         Resume Proc_Exit 
308     
309      End Function 
      Goto Top       Goto bas_Crystal_RunSQL_130522       Goto Index

GetElapsedTime (27)

310       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
311      Function GetElapsedTime(Optional ByVal pStartTime As Date = -99 _ 
312         , Optional ByVal pTimer As Single = -99 _ 
313         ) As String 
314     
315       '100827, 30
316     
317         If pTimer = -99 Then 
318            pStartTime = mDtmStart 
319            pTimer = mDtmStartr 
320         End If 
321     
322         If DateValue(pStartTime) = DateValue(Now) And Not pTimer < 0 Then 
323            GetElapsedTime = _ 
324               IIf(Timer() - mDtmStartr < 60 _ 
325                  , Format(Timer() - pTimer, "0.###") & " Sec" _ 
326                  , Format((Timer() - pTimer) \ 60, "0.#") & " Min" _ 
327               ) 
328         Else 
329            GetElapsedTime = Format((Now() - pStartTime) * 24 * 60 * 60, "0") & " Sec" 
330         End If 
331     
332       '   Debug.Print GetElapsedTime
333     
334      End Function 
335     
336     
      Goto Top       Goto bas_Crystal_RunSQL_130522       Goto Index

bas_PleaseWait (47)

PROCEDURES       Goto Top       Goto bas_PleaseWait       Goto Modules       Goto Index
  1. ClosePleaseWait (7)
  2. Declaration Lines (2)
  3. PleaseWaitMsg (6)
  4. ShowPleaseWait (32)

Declaration Lines (2)

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

ShowPleaseWait (32)

3         '
4         ' Crystal 5-17-08
5         ' strive4peace2012@yahoo.com
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, 140630
27        ' END LICENSE NOTICE
28        '============================================================
29        '
30        '------------------  open the PleaseWait form
31       Sub ShowPleaseWait() 
32          DoCmd.OpenForm "f_PleaseWait" 
33          Forms!f_PleaseWait.Repaint 
34       End Sub 
      Goto Top       Goto bas_PleaseWait       Goto Index

ClosePleaseWait (7)

35        '
36        '------------------  close the PleaseWait form
37       Sub ClosePleaseWait() 
38          If CurrentProject.AllForms("f_PleaseWait").IsLoaded Then 
39             DoCmd.Close acForm, "f_PleaseWait", acSaveNo 
40          End If 
41       End Sub 
      Goto Top       Goto bas_PleaseWait       Goto Index

PleaseWaitMsg (6)

42        '
43        '------------------  change the PleaseWait message
44       Sub PleaseWaitMsg(Optional pMsg As String = "PleaseWait...") 
45          Forms!f_PleaseWait.Msg.Caption = pMsg 
46          Forms!f_PleaseWait.Repaint 
47       End Sub 
      Goto Top       Goto bas_PleaseWait       Goto Index

bas_RenameControls_ActiveFormReport (172)

PROCEDURES       Goto Top       Goto bas_RenameControls_ActiveFormReport       Goto Modules       Goto Index
  1. Declaration Lines (29)
  2. RenameControls_ActiveFormReport (123)
  3. runRenameControls_ActiveFormReport (20)

Declaration Lines (29)

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

runRenameControls_ActiveFormReport (20)

30      
31        'this code:
32        '
33        '     renames controls to match the ControlSource for bound controls
34        '     renames labels to include controlname. Associated labels are named with the controlname first and unassociated labels have 'Label_' first.
35        '
36        'FORM:
37        '
38        '    must be in design view
39        '    must be active
40        '
41        'REPORT:
42        '  use optional parameter to send name
43        '
44       Public Sub runRenameControls_ActiveFormReport() 
45        '140317
46          Dim sReportname As String 
47          sReportname = " a_r_ControlRowSources" 
48          Call RenameControls_ActiveFormReport("") 
49       End Sub 
      Goto Top       Goto bas_RenameControls_ActiveFormReport       Goto Index

RenameControls_ActiveFormReport (123)

50      
51       Public Sub RenameControls_ActiveFormReport(Optional psReportname As String = "") 
52        '131112, strive4peace, 140317
53      
54           'FORM MUST BE IN DESIGN VIEW AND ACTIVE
55      
56           'RENAME
57           '  bound controls to match ControlSource
58           '  labels:
59           '     associated: controlname_Label
60           '     unassociated: Label_controlname
61      
62           'Click HERE and press F5 to Run!
63      
64          On Error GoTo Proc_Err 
65      
66          Dim ctl As Control _ 
67             , ctl2 As Control _ 
68             , obj As Object _ 
69             , rpt As Report _ 
70             , frm As Form 
71      
72          Dim sControlSource As String _ 
73             , sLabelName As String _ 
74             , sLabelName2 As String _ 
75             , iCountName As Integer _ 
76             , iCountLabel As Integer 
77      
78          iCountName = 0 
79          iCountLabel = 0 
80      
81           '----------------------------- CUSTOMIZE
82          If psReportname <> "" Then 
83             DoCmd.OpenReport psReportname, acViewDesign, , , acHidden 
84             Set rpt = Reports(psReportname) 
85          Else 
86             Set obj = Screen.ActiveForm 
87          End If 
88      
89      
90          With obj 
91             If MsgBox(.Name _ 
92                & vbCrLf & vbCrLf & "Rename bound controlnames to be the field they are bound to? " _ 
93                & vbCrLf & vbCrLf & "... and associated Label controlnames to Controlname_Label?" _ 
94                & vbCrLf & "... and unassociated Label controlnames to Label_Controlname?" _ 
95                , vbYesNo, "Rename Controls on " & .Name & "?") = vbNo Then Exit Sub 
96      
97              For Each ctl In .Controls 
98                If ctl.ControlType <> acLabel Then 
99                   sControlSource = Nz(Get_Property("controlsource", ctl), "") 
100                  If Len(sControlSource) > 0 Then 
101                     If Left(sControlSource, 1) <> "=" Then 
102                        If ctl.Name <> sControlSource Then 
103                           ctl.Name = sControlSource 
104                           iCountName = iCountName + 1 
105                        End If 
106                        sLabelName = sControlSource & "_Label"   'associated 
107                        sLabelName2 = "Label_" & sControlSource   'unassociated 
108                     Else 
109                        sLabelName = ctl.Name & "_Label" 
110                        sLabelName2 = "Label_" & ctl.Name   'unassociated 
111                        sControlSource = ctl.Name 
112                     End If 
113                     If ctl.Controls.Count > 0 Then 
114                        With ctl.Controls(0) 
115                           If .ControlType = acLabel Then 
116                              If .Name <> sLabelName Then 
117                                 .Name = sLabelName 
118                                 iCountLabel = iCountLabel + 1 
119                              End If 
120                           End If 
121                        End With 
122                     Else 
123                         'no associated label
124                         'look for a label whose caption is the control source
125                        For Each ctl2 In .Controls 
126                           If ctl2.ControlType = acLabel Then 
127                              If ctl2.Caption = sControlSource Then 
128                                 If ctl2.Name <> sLabelName2 Then 
129                                    ctl2.Name = sLabelName2 
130                                    iCountLabel = iCountLabel + 1 
131                                 End If 
132                              End If 
133                           End If 
134                        Next ctl2 
135                     End If 
136                  End If   'Len(sControlSource) > 0 
137               End If   'not a label 
138             Next ctl 
139         End With 
140     
141         MsgBox "Renamed " & iCountName & " controls, " _ 
142            & iCountLabel & " Labels" _ 
143            , , "Done" 
144     
145      Proc_Exit: 
146         On Error Resume Next 
147          'release object variables
148         Set ctl = Nothing 
149         Set ctl2 = Nothing 
150       '   If psReportname <> "" Then
151          'leave in design view
152         Set rpt = Nothing 
153         Set obj = Nothing 
154         Exit Sub 
155     
156      Proc_Err: 
157          'err 2451 - report isn't open or doesn't exist
158          'err 2104 'name already in use -- fix this manually or modify this code
159         MsgBox Err.Description, , _ 
160              "ERROR " & Err.Number _ 
161              & "   RenameControls_ActiveFormReport" 
162     
163         Resume Proc_Exit 
164         Resume 
165      End Sub 
166     
167     
168     
169     
170     
171     
172     
      Goto Top       Goto bas_RenameControls_ActiveFormReport       Goto Index

mod_crystal_DataDICTIONARY_DisplayControl (613)

PROCEDURES       Goto Top       Goto mod_crystal_DataDICTIONARY_DisplayControl       Goto Modules       Goto Index
  1. dd_CanGet_ObjectProperty (45)
  2. dd_CanGet_PropertyValue (61)
  3. dd_ClearList (20)
  4. dd_GetControlType (40)
  5. dd_GetDataType (55)
  6. dd_GetPropertyValue (27)
  7. dd_SetDisplayControlCheckbox (66)
  8. dd_SetDisplayControlTextbox (69)
  9. Declaration Lines (33)
  10. Get_CorrectName (134)
  11. GetTableFlags (33)
  12. IsExclusive (5)
  13. IsHidden (5)
  14. IsLinked (5)
  15. IsODBC (5)
  16. IsSavePW (5)
  17. IsSystem (5)

Declaration Lines (33)

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

GetTableFlags (33)

34      
35        '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
36       Function GetTableFlags(pAttribute As Long) As String 
37        '130426 Crystal
38      
39          Dim varFlags As Variant 
40      
41          varFlags = Null 
42      
43          If (pAttribute And -2147483646) Then 
44             varFlags = (varFlags + ", ") & "System" 
45          End If 
46          If (pAttribute And 1) Then 
47             varFlags = (varFlags + ", ") & "Hidden" 
48          End If 
49      
50          If (pAttribute And 65536) Then 
51             varFlags = (varFlags + ", ") & "Exclusive" 
52          End If 
53          If (pAttribute And 131072) Then 
54             varFlags = (varFlags + ", ") & "SavePW" 
55          End If 
56      
57          If (pAttribute And 536870912) Then 
58             varFlags = (varFlags + ", ") & "ODBC" 
59          End If 
60          If (pAttribute And 1073741824) Then 
61             varFlags = (varFlags + ", ") & "Linked" 
62          End If 
63      
64          GetTableFlags = Nz(varFlags, "") 
65      
66       End Function 
      Goto Top       Goto mod_crystal_DataDICTIONARY_DisplayControl       Goto Index

IsSystem (5)

67      
68       Function IsSystem(pAttribute As Long) As Boolean 
69        '130426 Crystal
70          IsSystem = pAttribute And -2147483646 
71       End Function 
      Goto Top       Goto mod_crystal_DataDICTIONARY_DisplayControl       Goto Index

IsHidden (5)

72      
73       Function IsHidden(pAttribute As Long) As Boolean 
74        '130426 Crystal
75          IsHidden = pAttribute And 1 
76       End Function 
      Goto Top       Goto mod_crystal_DataDICTIONARY_DisplayControl       Goto Index

IsExclusive (5)

77      
78       Function IsExclusive(pAttribute As Long) As Boolean 
79        '130426 Crystal
80          IsExclusive = pAttribute And 65536 
81       End Function 
      Goto Top       Goto mod_crystal_DataDICTIONARY_DisplayControl       Goto Index

IsSavePW (5)

82      
83       Function IsSavePW(pAttribute As Long) As Boolean 
84        '130426 Crystal
85          IsSavePW = pAttribute And 131072 
86       End Function 
      Goto Top       Goto mod_crystal_DataDICTIONARY_DisplayControl       Goto Index

IsODBC (5)

87      
88       Function IsODBC(pAttribute As Long) As Boolean 
89        '130426 Crystal
90          IsODBC = pAttribute And 536870912 
91       End Function 
      Goto Top       Goto mod_crystal_DataDICTIONARY_DisplayControl       Goto Index

IsLinked (5)

92      
93       Function IsLinked(pAttribute As Long) As Boolean 
94        '130426 Crystal
95          IsLinked = pAttribute And 1073741824 
96       End Function 
      Goto Top       Goto mod_crystal_DataDICTIONARY_DisplayControl       Goto Index

Get_CorrectName (134)

97      
98        '~~~~~~~~~~~~~~~~~~~~~~~~~~ Get_CorrectName
99       Public Function Get_CorrectName( _ 
100         ByVal pName As String _ 
101         , Optional ByVal pDontStartWithNumber As Boolean = False _ 
102         , Optional ByVal pBooHasExtension As Boolean = False _ 
103         , Optional ByVal pBooDateStamp As Boolean = False _ 
104         ) As String 
105     
106     
107          'crystal
108          'strive4peace2012@yahoo.com
109          '...130427
110     
111          'PARAMETERS
112          'pName is the string you want to correct
113          'pDontStartWithNumber: true : dont allow the first character to be numeric
114          'pBooHasExtension : true : passed string is a file with an extension (last period is ok)
115          'pBooDateStamp (optional) adds date and time to end (before extension)
116     
117          'EXAMPLE USEAGE
118          '  on the AfterUpdate event of a control
119          '  =Get_CorrectName([controlname])
120          '
121          'in a query:
122          'field --> NewFieldname: Get_CorrectName([strFieldname])
123     
124          'EXAMPLE
125          ' ? Get_CorrectName("as(,48209j@##@!")
126          ' --> as_48209j_
127          ' ? Get_CorrectName("as(,48209j@##@!", , , true)
128          ' --> as_48209j_070511_301pm
129     
130          'NOTE: RECURSIVE: this procedure may call itself
131     
132         Dim i As Integer _ 
133            , sName As String _ 
134            , cChar As String * 1 _ 
135            , cLastChar As String * 1 _ 
136            , cNewChar As String * 1 _ 
137            , sExt As String _ 
138            , iPos As Integer _ 
139            , booHasGoodChar As Boolean _ 
140            , sDateFormat As String _ 
141            , sCharactersToReplace As String 
142     
143         Get_CorrectName = "" 
144     
145          '========================================== 'change to whatever suits you!
146         sDateFormat = "yymmdd_hnnam/pm" 
147         sCharactersToReplace = "`!@#$%^&*()+=|\:;""'<>,.?/"" " 
148       '   sCharactersToReplace = "`!@#$%^&*()+=|\:;""'<>,.?/""" ' allow spaces in the middle
149          '==========================================
150     
151     
152         If Len(Nz(pName)) < 1 Then Exit Function 
153         pName = Trim(pName) 
154     
155         cLastChar = "" 
156     
157          'see if this is a file with an extension to preserve
158         If pBooHasExtension Then 
159            iPos = InStrRev(pName, ".") 
160            sExt = "" 
161     
162            If iPos > 0 Then 
163               sExt = Mid(pName, iPos + 1) 
164               sExt = "." & Get_CorrectName(sExt) 
165               pName = Trim(Left(pName, iPos - 1)) 
166            End If 
167         End If 
168     
169          'strip leading numbers
170         If pDontStartWithNumber Then 
171            Do While IsNumeric(Left(pName, 1)) 
172               If Len(pName) = 1 Then 
173                  Exit Function 
174               End If 
175               pName = Trim(Mid(pName, 2)) 
176            Loop 
177         End If 
178     
179         booHasGoodChar = False 
180     
181         For i = 1 To Len(pName) 
182            cChar = Mid(pName, i, 1) 
183     
184             'see if character is ok
185            If InStr(sCharactersToReplace, cChar) > 0 Then 
186               If i <> Len(pName) Then 
187                  cNewChar = "_" 
188               End If 
189            Else 
190               cNewChar = cChar   'character is not in list to replace 
191            End If 
192     
193            If (cLastChar = "_" And cNewChar = "_") Then 
194                'leave the same for multiple characters to replace in a row
195                ' or if this is the last character
196            Else 
197               sName = sName & cNewChar 
198               booHasGoodChar = True 
199            End If 
200     
201             'remember the last character
202            cLastChar = cNewChar 
203         Next i 
204     
205         If Not booHasGoodChar Then 
206             'nothing in the name beside illegal characters
207            Exit Function 
208         End If 
209     
210         Do While Right(sName, 1) = "_" 
211            sName = Trim(Left(sName, Len(sName) - 1)) 
212         Loop 
213     
214         If Len(sName) = 0 Then 
215             'name is not valid
216            Exit Function 
217         End If 
218     
219         If pBooDateStamp Then 
220            If Right(sName, 1) <> "_" Then 
221               sName = sName & "_" 
222            End If 
223            sName = sName & Format(Now(), sDateFormat) 
224         End If 
225     
226         sName = sName & sExt 
227     
228         Get_CorrectName = sName 
229     
230      End Function 
      Goto Top       Goto mod_crystal_DataDICTIONARY_DisplayControl       Goto Index

dd_SetDisplayControlTextbox (69)

231     
232       '=================================================================
233       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
234      Public Function dd_SetDisplayControlTextbox( _ 
235          psTblName As String _ 
236         , Optional psFieldname As String = "" _ 
237         , Optional psMsg As String = "" _ 
238         ) As String 
239       '8-26-07 Crystal (strive4peace), 130425
240     
241          'set the DisplayControl property to Textbox where
242          'DisplayControl = combobox or listbox
243          'Tablename must be specified
244     
245          'All fields checked and changed if fieldname not specified
246     
247             'NEEDS reference to Microsoft DAO Library
248             'or
249             'Microsoft Office ##.0 Access Database Engine Object Library
250     
251          'psMsg is designed to be a return value
252     
253         Dim db As DAO.Database _ 
254            , tdf As DAO.TableDef _ 
255            , fld As DAO.Field 
256     
257     
258         On Error GoTo Proc_Err 
259     
260         Set db = CurrentDb 
261     
262         Set tdf = db.TableDefs(psTblName) 
263         Set fld = tdf.Fields(psFieldname) 
264     
265         psMsg = psMsg & vbCrLf & Space(3) & psFieldname 
266     
267         With fld.Properties("DisplayControl") 
268            If .Value = acComboBox Then 
269               psMsg = psMsg & " -- changed from ComboBox" 
270            ElseIf .Value = acListBox Then 
271               psMsg = psMsg & " -- changed from ListBox" 
272            ElseIf .Value = acCheckBox Then 
273               psMsg = psMsg & " -- changed from CheckBox" 
274            Else 
275               If .Value = acTextBox Then 
276                  psMsg = psMsg & " -- no change" 
277                  GoTo Proc_Exit 
278               End If 
279               psMsg = psMsg & " -- changed from " & .Value 
280            End If 
281            .Value = acTextBox 
282         End With   'DisplayControl 
283     
284      Proc_Exit: 
285        On Error Resume Next 
286         dd_SetDisplayControlTextbox = psMsg 
287         Set tdf = Nothing 
288         Set fld = Nothing 
289         Exit Function 
290     
291      Proc_Err: 
292         psMsg = psMsg & " -- ERROR!" 
293         Resume Proc_Exit 
294         MsgBox Err.Description, , _ 
295              "ERROR " & Err.Number _ 
296              & "   dd_SetDisplayControlTextbox" 
297     
298         Resume 
299      End Function 
      Goto Top       Goto mod_crystal_DataDICTIONARY_DisplayControl       Goto Index

dd_SetDisplayControlCheckbox (66)

300       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
301       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
302      Public Function dd_SetDisplayControlCheckbox( _ 
303          psTblName As String _ 
304         , Optional psFieldname As String = "" _ 
305         , Optional psMsg As String = "" _ 
306         ) As String 
307       '8-26-07 Crystal strive4peace), 130425
308     
309          'set the DisplayControl property to Checkbox where Data Type = Integer
310          'Tablename must be specified
311          'All fields checked and changed if fieldname not specified
312     
313          'psMsg is designed to be a return value
314     
315             'NEEDS reference to Microsoft DAO Library
316             'or
317             'Microsoft Office ##.0 Access Database Engine Object Library
318     
319         Dim db As DAO.Database _ 
320            , tdf As DAO.TableDef _ 
321            , fld As DAO.Field 
322     
323         On Error GoTo Proc_Err 
324     
325         Set db = CurrentDb 
326     
327         Set tdf = db.TableDefs(psTblName) 
328         Set fld = tdf.Fields(psFieldname) 
329     
330         psMsg = psMsg & vbCrLf & Space(3) & psFieldname 
331     
332         With fld 
333       '      If .Type = dbBoolean Then
334       '         psMsg = psMsg & " -- changed datatype to integer"
335       '         .Type = dbInteger 'Can't change Type this way
336       '         .Properties("DisplayControl") = acCheckBox
337       '      End If
338            If .Type = dbInteger Then 
339               With .Properties("DisplayControl") 
340                  If .Value <> acCheckBox Then 
341                      'CInt(acCheckBox) = 106
342                     .Value = acCheckBox 
343                     psMsg = psMsg & ", changed to checkbox" 
344                  End If 
345               End With   'DisplayControl 
346            End If   'Integer 
347         End With   ' Fld 
348     
349      Proc_Exit: 
350        On Error Resume Next 
351         dd_SetDisplayControlCheckbox = psMsg 
352         Set tdf = Nothing 
353         Set fld = Nothing 
354         Set db = Nothing 
355         Exit Function 
356     
357      Proc_Err: 
358         psMsg = psMsg & " -- Error!" 
359         Resume Proc_Exit 
360         MsgBox Err.Description, , _ 
361              "ERROR " & Err.Number _ 
362              & "   dd_SetDisplayControlCheckbox" 
363     
364         Resume 
365      End Function 
      Goto Top       Goto mod_crystal_DataDICTIONARY_DisplayControl       Goto Index

dd_CanGet_ObjectProperty (45)

366     
367      Function dd_CanGet_ObjectProperty( _ 
368         pObj As Object _ 
369         , psPropName As String _ 
370         , pValueRETURN As Variant _ 
371         , Optional ByVal pDatTypN As Integer = 0 _ 
372         , Optional ByVal pMaxLength As Integer = 0 _ 
373         ) As Boolean 
374       '130426 Crystal
375     
376          'PARAMETERS
377          '  pObj = object to get value of
378          '  psPropName = name of property
379          '  pValueRETURN = RETURN Value
380          '  pDatTypN (optional) = data type to return (text is only special case)
381          '  pMaxLength (optional) = maximum length (for text only)
382     
383          'CALLS
384          '  dd_CanGet_PropertyValue
385     
386         On Error GoTo Proc_Err 
387     
388         dd_CanGet_ObjectProperty = False 
389         pValueRETURN = Null 
390     
391         Dim prop As DAO.Property 
392     
393         Dim varValue As Variant 
394     
395         Set prop = pObj.Properties(psPropName) 
396         dd_CanGet_ObjectProperty = True 
397     
398         If IsNull(prop.Value) Then 
399            Exit Function 
400         End If 
401         Call dd_CanGet_PropertyValue(prop, pValueRETURN, pDatTypN, pMaxLength) 
402     
403      Proc_Exit: 
404         On Error Resume Next 
405         Set prop = Nothing 
406         Exit Function 
407     
408      Proc_Err: 
409         Resume Proc_Exit 
410      End Function 
      Goto Top       Goto mod_crystal_DataDICTIONARY_DisplayControl       Goto Index

dd_CanGet_PropertyValue (61)

411     
412      Function dd_CanGet_PropertyValue( _ 
413         pProp As DAO.Property _ 
414         , pValueRETURN As Variant _ 
415         , Optional ByVal pDatTypN As Integer = 0 _ 
416         , Optional ByVal pMaxLength As Integer = 0 _ 
417         ) As Boolean 
418       '130419 Crystal
419     
420          'PARAMETERS
421          '  pProp = property
422          '  pValueRETURN = RETURN Value
423          '  pDatTypN (optional) = data type to return (text is only special case)
424          '  pMaxLength (optional) = maximum length (for text only)
425     
426         On Error GoTo Proc_Err 
427     
428         dd_CanGet_PropertyValue = False 
429     
430         Dim varValue As Variant 
431     
432         If IsNull(pProp.Value) Then 
433            Exit Function 
434         End If 
435     
436         If pDatTypN = 10 Then   'text is desired 
437     
438            If pProp.Type <> 10 Then   'property value is not text - convert 
439                'not text
440               varValue = CStr(pProp.Value) 
441            Else 
442               varValue = pProp.Value 
443            End If 
444     
445            If Not Len(Trim(varValue & "")) > 0 Then 
446                'don't store ZLS or only spaces
447               Exit Function 
448            End If 
449     
450            If pMaxLength > 0 Then 
451               varValue = Left(CStr(varValue), pMaxLength) 
452            Else 
453               varValue = CStr(varValue) 
454            End If 
455            pValueRETURN = varValue 
456     
457         Else 
458             'future: write conversion code for rest of data types
459            pValueRETURN = pProp.Value 
460         End If   'text 
461     
462         dd_CanGet_PropertyValue = True 
463     
464      Proc_Exit: 
465         On Error Resume Next 
466         Exit Function 
467     
468      Proc_Err: 
469         Resume Proc_Exit 
470     
471      End Function 
      Goto Top       Goto mod_crystal_DataDICTIONARY_DisplayControl       Goto Index

dd_GetPropertyValue (27)

472     
473      Function dd_GetPropertyValue( _ 
474         pObj As Object _ 
475         , psPropName As String _ 
476         ) As Variant 
477       '130419 Crystal
478     
479          'PARAMETERS
480          '  pProp = prorperty object to get value of
481          '  pValueRETURN = RETURN Value
482          '  pDatTypN (optional) = data type to return (text is only special case)
483          '  pMaxLength (optional) = maximum length (for text only)
484     
485         On Error GoTo Proc_Err 
486     
487         dd_GetPropertyValue = Null 
488     
489         dd_GetPropertyValue = pObj.Properties(psPropName) 
490     
491      Proc_Exit: 
492         On Error Resume Next 
493         Exit Function 
494     
495      Proc_Err: 
496         Resume Proc_Exit 
497     
498      End Function 
      Goto Top       Goto mod_crystal_DataDICTIONARY_DisplayControl       Goto Index

dd_GetDataType (55)

499     
500     
501       '~~~~~~~~~~~~~~~~~~~~~~~~~~ dd_GetDataType  -- use DataTypes table instead of this in queries
502      Function dd_GetDataType(ByVal pDataTypN As Long _ 
503         , Optional pBooShort As Boolean = False _ 
504         ) As String 
505     
506       '100310
507     
508         dd_GetDataType = "" 
509         On Error Resume Next 
510     
511         Switch 
512         Select Case Nz(pDataTypN) 
513            Case 1: dd_GetDataType = IIf(pBooShort, "YN", "Boolean") 
514            Case 2: dd_GetDataType = IIf(pBooShort, "Byt", "Byte") 
515            Case 3: dd_GetDataType = IIf(pBooShort, "Int", "Integer") 
516            Case 4: dd_GetDataType = IIf(pBooShort, "Lng", "Long") 
517            Case 5: dd_GetDataType = IIf(pBooShort, "Cur", "Currency") 
518            Case 6: dd_GetDataType = IIf(pBooShort, "Sgl", "Single") 
519            Case 7: dd_GetDataType = IIf(pBooShort, "Dbl", "Double") 
520            Case 8: dd_GetDataType = IIf(pBooShort, "DatT", "DateTime") 
521            Case 10: dd_GetDataType = IIf(pBooShort, "Txt", "Text") 
522            Case 12: dd_GetDataType = IIf(pBooShort, "Mem", "Memo") 
523     
524            Case 9: dd_GetDataType = IIf(pBooShort, "Bin", "Binary") 
525            Case 11: dd_GetDataType = IIf(pBooShort, "Ole", "Ole BinBMP") 
526     
527            Case 15: dd_GetDataType = IIf(pBooShort, "Guid", "GUID") 
528            Case 16: dd_GetDataType = IIf(pBooShort, "BigInt", "Big Integer") 
529            Case 17: dd_GetDataType = IIf(pBooShort, "BinVar", "Binary Variable") 
530     
531       '      Case 16: mStr = "Auto"
532     
533            Case 18: dd_GetDataType = IIf(pBooShort, "TxtFix", "Fixed Text") 
534     
535            Case 19: dd_GetDataType = IIf(pBooShort, "oNum", "Numeric odbc") 
536            Case 20: dd_GetDataType = IIf(pBooShort, "oDec", "Decimal odbc") 
537            Case 21: dd_GetDataType = IIf(pBooShort, "oFlo", "Float odbc") 
538            Case 22: dd_GetDataType = IIf(pBooShort, "oTime", "Time odbc") 
539            Case 23: dd_GetDataType = IIf(pBooShort, "oDatT", "DateTime odbc") 
540     
541            Case 101: dd_GetDataType = IIf(pBooShort, "att", "Attachment") 
542            Case 102: dd_GetDataType = IIf(pBooShort, "mvByt", "Byte MV") 
543            Case 103: dd_GetDataType = IIf(pBooShort, "mvInt", "Integer MV") 
544            Case 104: dd_GetDataType = IIf(pBooShort, "mvLng", "Long Integer MV") 
545            Case 105: dd_GetDataType = IIf(pBooShort, "mvSgl", "Single MV") 
546            Case 106: dd_GetDataType = IIf(pBooShort, "mvDbl", "Double MV") 
547            Case 107: dd_GetDataType = IIf(pBooShort, "mvGuid", "Guid MV") 
548            Case 108: dd_GetDataType = IIf(pBooShort, "mvDec", "Decimal MV") 
549            Case 109: dd_GetDataType = IIf(pBooShort, "mvTxt", "Text MV") 
550     
551            Case Else: dd_GetDataType = Format(Nz(pDataTypN), "0") 
552         End Select 
553      End Function 
      Goto Top       Goto mod_crystal_DataDICTIONARY_DisplayControl       Goto Index

dd_GetControlType (40)

554     
555     
556      Function dd_GetControlType( _ 
557         ByVal piControlType As Integer _ 
558         , Optional pBooShort As Boolean = False _ 
559         ) As String 
560       '130426 Crystal
561         dd_GetControlType = "" 
562         On Error Resume Next 
563     
564         Select Case piControlType 
565            Case 0: dd_GetControlType = "" 
566            Case 100: dd_GetControlType = IIf(pBooShort, "Lbl", "Label") 
567            Case 101: dd_GetControlType = IIf(pBooShort, "Rect", "Rectangle") 
568            Case 102: dd_GetControlType = IIf(pBooShort, "Lin", "Line") 
569            Case 103: dd_GetControlType = IIf(pBooShort, "Img", "Image") 
570            Case 104: dd_GetControlType = IIf(pBooShort, "Cmd", "CommandButton") 
571            Case 105: dd_GetControlType = IIf(pBooShort, "OBtn", "OptionButton") 
572            Case 106: dd_GetControlType = IIf(pBooShort, "Chk", "CheckBox") 
573            Case 107: dd_GetControlType = IIf(pBooShort, "OptG", "OptionGroup") 
574            Case 108: dd_GetControlType = IIf(pBooShort, "BObj", "BoundObjectFrame") 
575            Case 109: dd_GetControlType = IIf(pBooShort, "Txt", "TextBox") 
576            Case 110: dd_GetControlType = IIf(pBooShort, "Lst", "ListBox") 
577            Case 111: dd_GetControlType = IIf(pBooShort, "Cbo", "ComboBox") 
578            Case 112: dd_GetControlType = IIf(pBooShort, "Sbf", "Subform") 
579            Case 114: dd_GetControlType = IIf(pBooShort, "Obj", "ObjectFrame") 
580            Case 118: dd_GetControlType = IIf(pBooShort, "PgBk", "PageBreak") 
581            Case 119: dd_GetControlType = IIf(pBooShort, "Cust", "CustomControl") 
582            Case 122: dd_GetControlType = IIf(pBooShort, "Tog", "ToggleButton") 
583            Case 123: dd_GetControlType = IIf(pBooShort, "Tab", "TabCtl") 
584            Case 124: dd_GetControlType = IIf(pBooShort, "Pg", "Page") 
585            Case 126: dd_GetControlType = IIf(pBooShort, "Att", "Attachment") 
586            Case 127: dd_GetControlType = IIf(pBooShort, "Emp", "EmptyCell") 
587            Case 128: dd_GetControlType = IIf(pBooShort, "WebB", "WebBrowser") 
588            Case 129: dd_GetControlType = IIf(pBooShort, "NavC", "NavigationControl") 
589            Case 130: dd_GetControlType = IIf(pBooShort, "NBtn", "NavigationButton") 
590            Case Else: dd_GetControlType = piControlType 
591         End Select 
592     
593      End Function 
      Goto Top       Goto mod_crystal_DataDICTIONARY_DisplayControl       Goto Index

dd_ClearList (20)

594     
595       '~~~~~~~~~~~~~~~~~~~~~~~~~~ dd_ClearList
596      Function dd_ClearList( _ 
597         ctl As Control _ 
598         ) As Boolean 
599       ' Crystal (strive4peace)
600       '4-4-09
601       'clear listbox items selected
602       'CALLED BY code behind ANALYZER a_f_DisplayControl form
603         On Error Resume Next 
604         dd_ClearList = False 
605         Dim varItem As Variant 
606         For Each varItem In ctl.ItemsSelected 
607             ctl.Selected(varItem) = False 
608             dd_ClearList = True 
609         Next varItem 
610      End Function 
611     
612     
613     
      Goto Top       Goto mod_crystal_DataDICTIONARY_DisplayControl       Goto Index

mod_crystal_GetFile_Browse (157)

PROCEDURES       Goto Top       Goto mod_crystal_GetFile_Browse       Goto Modules       Goto Index
  1. Declaration Lines (32)
  2. GetFile_Browse (125)

Declaration Lines (32)

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

GetFile_Browse (125)

33      
34       Function GetFile_Browse( _ 
35           Optional psTitle As String = "" _ 
36          , Optional psFilters As String = "" _ 
37          , Optional psPathFile As String = "" _ 
38          , Optional psDirectory As String = "" _ 
39          ) As String 
40      
41        '130325, 28, 130813
42        ' Crystal strive4peace
43        '
44           'NEEDS REFERENCE
45           '  Microsoft Office #.0 Object Library
46           '
47           'PARAMETERS
48           '
49           ' psTitle = Titlebar of the dialog box
50           ' psFilters -- If len(psFilters) < 5 then single-letter codes are assumed.
51           '        A = Access Files
52           '        W = Workgroup file
53           ' psPathFile -- if sent, will be parsed for the start directory
54           ' psDirectory -- if psPathFile not sent, specifies start directory. default is the FE directory.
55           '
56           ' all parameters are optional.
57           '
58           'EXAMPLES
59           '
60           ' sPathFile = GetFile_Browse()
61           ' sPathFile = GetFile_Browse( "Pick a Document", "*.txt;*.doc;*.docx")
62           ' sPathFile = GetFile_Browse( "Pick an Access File", "A", sPathFile)
63           '
64           '
65      
66          On Error GoTo Proc_Err 
67      
68          Dim fDialog As Office.FileDialog   '  Microsoft Office #.0 Object Library 
69          Dim varFile As Variant 
70      
71          Dim sPathFile As String _ 
72             , sStr As String _ 
73             , iPos As Integer 
74      
75          If Len(psPathFile) > 0 Then 
76              'get the directory from psPathFile
77             iPos = InStrRev(psPathFile, "\") 
78             If iPos > 0 Then 
79                psDirectory = Left(psPathFile, iPos) 
80             End If 
81          Else 
82             If Len(psDirectory & "") > 0 Then 
83                 'starting directory was specified, psDirectory
84                sPathFile = psDirectory 
85             Else 
86                 'psDirectory not specified, use \Attachment\ directory
87                sPathFile = Get_Property("local_PathAtt") & "\"  ' ie: CurrentProject.Path & "\Attachments" 
88             End If 
89          End If 
90      
91          With Application.FileDialog(3)   'msoFileDialogFilePicker 
92             .Filters.Clear 
93             If Len(psFilters) < 5 Then 
94                If InStr(psFilters, "A") > 0 Then 
95                    'Access databases that can be analyzed
96                    ' accdb - client or hybrid
97                    ' accdw - extension of Access database on SharePoint server
98                    ' mdb
99                    ' accde, mde - compiled versions
100                   ' accdt - Access Database Template
101                   ' accdr - runtime mode
102                   ' mda, accda - library databases      .Filters.Clear
103                  .Filters.Add "Access Files" _ 
104                           , "*.accdb;*.accde;*.accdt;*.accdr;*.accda;*.mdb;*.mda;*.mde" 
105               ElseIf InStr(psFilters, "W") > 0 Then 
106                   'Workgroup Files
107                  .Filters.Add "Workgroup Files", "*.mdw" 
108               End If 
109            Else 
110               .Filters.Add "Specified Files", psFilters 
111            End If 
112            .Filters.Add "All Files", "*.*" 
113     
114            If Len(psTitle) > 0 Then 
115               sStr = psTitle 
116            Else 
117               sStr = "Pick a File" 
118            End If 
119            .Title = sStr 
120            .InitialFileName = sPathFile 
121            .AllowMultiSelect = False 
122     
123            If .Show = True Then 
124               sPathFile = .SelectedItems(1) 
125            Else 
126               Exit Function 
127            End If 
128     
129         End With   'fDialog 
130     
131       '' optional check for length
132       '   If Len(sPathFile) > 255 Then
133       '      MsgBox "File path and name is " & Len(sPathFile) & " characters." _
134       '         & " The limit is 255." _
135       '         & vbCrLf & vbCrLf _
136       '         & sPathFile _
137       '         & vbCrLf & vbCrLf _
138       '         & "Move file to a place with a shorter path or give it a shorter name" _
139       '         , , "Cannot process this file"
140       '      Resume Proc_Exit
141       '   End If
142     
143         GetFile_Browse = sPathFile 
144     
145      Proc_Exit: 
146         On Error Resume Next 
147         Exit Function 
148     
149      Proc_Err: 
150         MsgBox Err.Description, , _ 
151              "ERROR " & Err.Number _ 
152              & "   GetFile_Browse" 
153     
154         Resume Proc_Exit 
155         Resume 
156      End Function 
157     
      Goto Top       Goto mod_crystal_GetFile_Browse       Goto Index

mod_DocumentQueryCalculatedFields_Crystal (284)

PROCEDURES       Goto Top       Goto mod_DocumentQueryCalculatedFields_Crystal       Goto Modules       Goto Index
  1. Declaration Lines (2)
  2. DocumentQueryCalculatedFields (282)

Declaration Lines (2)

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

DocumentQueryCalculatedFields (282)

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 Sub DocumentQueryCalculatedFields() 
30        '140519, 20, 21 strive4peace
31        'based on code originally written by NateO
32      
33          On Error GoTo Proc_Err 
34      
35           'Dimension object variables
36          Dim rs As Object _ 
37                , xlApp As Object _ 
38                , xlWb As Object 
39      
40           'Dimension regular variables
41          Dim sSQL As String _ 
42                , nRow As Long _ 
43                , nCol As Long _ 
44                , nFields As Long _ 
45                , nRecords As Long _ 
46                , sFilename As String _ 
47                , sPathFileWithoutExtension As String _ 
48                , sPathFileThere As String _ 
49                , sSheetname As String _ 
50                , i As Integer _ 
51                , booMsg As Boolean _ 
52                , nTimerStart As Single 
53      
54           'Dimension Array for Fieldnames
55          Dim asFieldname() As String 
56      
57          nTimerStart = Timer() 
58          sFilename = "QryCalcFields_" _ 
59             & Replace(Replace(CurrentProject.Name, ".", "-"), " ", "_") 
60      
61          sSheetname = CurrentProject.Name 
62           'truncate database name to first word
63          i = InStr(sSheetname, " ") 
64          If i > 0 Then 
65             sSheetname = Trim(Left(sSheetname, i)) 
66          End If 
67      
68          sSheetname = Left(sSheetname & "_" & "QryCalcFields", 30) 
69      
70          booMsg = False   'give message that workbook was created 
71        'here is the SQL, easy to uncomment and paste into a query if you want it:
72        '   SELECT mQ.Name1 AS FieldName
73        '      , mo.Name AS QryName
74        '      , mQ.Expression
75        '    FROM MSysObjects AS mo
76        '      INNER JOIN MSysQueries AS mQ
77        '         ON mo.Id = mQ.ObjectId
78        '    WHERE ( (mQ.Name1 Is Not Null)
79        '      AND (left(mo.Name,1) Not IN ("~","{"))
80        '      AND (mQ.Expression Is Not Null)
81        '      AND (mQ.Attribute=6) )
82        '    ORDER BY mQ.Name1
83        '      , mo.Name;
84      
85          sSQL = "SELECT mQ.Name1 AS FieldName, mo.Name AS QryName, mQ.Expression" _ 
86                & " FROM MSysObjects AS mo " _ 
87                & " INNER JOIN MSysQueries AS mQ ON mo.Id = mQ.ObjectId" _ 
88                & " WHERE ( (mQ.Name1 Is Not Null) " _ 
89                & " AND (left(mo.Name,1) Not IN (""~"",""{"")) " _ 
90                & " AND (mQ.Expression Is Not Null) " _ 
91                & " AND (mQ.Attribute=6) )" _ 
92                & " ORDER BY mQ.Name1, mo.Name;" 
93      
94           'Open an ADODB.Recordset
95          Set rs = CreateObject("ADODB.Recordset") 
96          With rs 
97             .CursorLocation = 3   'adUseClient 
98              'adOpenStatic = 3
99              'adLockReadOnly = 1
100            rs.Open sSQL _ 
101                  , CodeProject.Connection _ 
102                  , 3 _ 
103                  , 1 
104     
105             'count records and fields
106            nFields = .Fields.Count 
107            nRecords = .RecordCount 
108         End With 
109     
110         If Not nRecords > 0 Then 
111            MsgBox "there is no data to write to Excel", , "Aborting" 
112            GoTo Proc_Exit 
113         End If 
114     
115          'create a new instance of an Excel application
116         Set xlApp = CreateObject("Excel.Application") 
117     
118         With xlApp 
119            .Visible = True   'let user see what is happening 
120            .EnableEvents = False 'don't run any code 
121             'Add a new Workbook with one Worksheet
122            Set xlWb = .Workbooks.Add(1) 
123         End With 
124     
125          'Stack a String Array with the Field Names
126         ReDim asFieldname(1 To nFields) 
127         With rs 
128            For nCol = 1 To nFields 
129               Let asFieldname(nCol) = .Fields(nCol - 1).Name 
130            Next nCol 
131         End With   'rs 
132     
133          'Time to Pass some Data to Excel!
134          'Worksheets Collection is 1-based
135         With xlWb.Worksheets.Item(1) 
136     
137             'Write Label names from Field Name array
138             'stretched to the Right for number of Elements in the array (number of columns)
139            Let .Range("a1").Resize(, nFields).Value = asFieldname 
140     
141             'Copy our Current Recordset to A2
142            .Range("a2").CopyFromRecordset rs 
143     
144             'Rename Individual Worksheet
145            .Name = sSheetname 
146     
147            sPathFileWithoutExtension = CurrentProject.Path & "\" & sFilename      '---- extension will be added 
148     
149            With .Cells.Font 
150               .Name = "Calibri" 
151               .Size = 10 
152            End With 
153     
154             'label row
155            With .Range(.Cells(1, 1), .Cells(1, nFields)) 
156               .Font.Size = 8 
157               With .Interior 
158                  .Color = RGB(225, 225, 225) 
159               End With 
160            End With 
161     
162             'xlDiagonalDown 5
163             'xlDiagonalUp 6
164             'xlEdgeLeft 7
165             'xlEdgeTop 8
166             'xlEdgeBottom 9
167             'xlEdgeRight 10
168             'xlInsideVertical 11
169             'xlInsideHorizontal 12
170     
171             'all data
172            With .Range(.Cells(1, 1), .Cells(nRecords, nFields)) 
173               For i = 7 To 12 
174                  With .Borders(i) 
175                     .LineStyle = 1   'xlContinuous 
176                     .Color = RGB(150, 150, 150) 
177                     .Weight = 2   'xlThin 
178                  End With 
179               Next i 
180               .VerticalAlignment = -4108   'xlCenter 
181            End With 
182     
183             'format when value changes in Column A
184            For nRow = 2 To nRecords + 1 
185                ' if the value in the first column changed,
186                ' bold the first cell and add a line above
187               If .Cells(nRow, 1) <> .Cells(nRow - 1, 1) Then 
188                  With .Range(.Cells(nRow, 1), .Cells(nRow, nFields)) 
189                     With .Borders(8) 
190                        .LineStyle = 1   'xlContinuous 
191                        .Color = RGB(100, 100, 100) 
192                        .Weight = 3   'xlThick=4 
193                     End With 
194                  End With 
195                  .Cells(nRow, 1).Font.Bold = True 
196               End If 
197            Next nRow 
198     
199             'best-fit columns
200            .Range(.Columns(1), .Columns(nFields)).EntireColumn.AutoFit 
201     
202            For nCol = 1 To nFields 
203                'if any column widths > 60, reduce it.  Wrap Text
204               If .Columns(nCol).ColumnWidth > 60 Then 
205                  .Columns(nCol).ColumnWidth = 60 
206                  .Columns(nCol).WrapText = True 
207               End If 
208            Next nCol 
209     
210             'set margins, orientation, header
211            With .PageSetup 
212              .PrintTitleRows = "1:1" 
213              .PrintTitleColumns = "A:A" 
214              .RightHeader = "&""Times New Roman,Italic""&10&A - " & Now() & " - &P/&N" 
215              .LeftMargin = xlApp.InchesToPoints(0.5) 
216              .RightMargin = xlApp.InchesToPoints(0.5) 
217              .TopMargin = xlApp.InchesToPoints(0.5) 
218              .BottomMargin = xlApp.InchesToPoints(0.5) 
219              .HeaderMargin = xlApp.InchesToPoints(0.3) 
220              .FooterMargin = xlApp.InchesToPoints(0.3) 
221              .CenterHorizontally = True 
222              .Orientation = 2   'xlLandscape 
223            End With 
224     
225            .Range("B2").Select 
226     
227         End With     'Worksheet 
228     
229          'freeze panes and turn on the auto filter
230         xlApp.ActiveWindow.FreezePanes = True 
231         xlApp.Selection.AutoFilter 
232     
233          'delete file if it already exists
234         sPathFileThere = Dir(sPathFileWithoutExtension & ".xl*") 
235         If sPathFileThere <> "" Then 
236            sPathFileThere = CurrentProject.Path & "\" & sPathFileThere 
237            On Error Resume Next 
238            Kill sPathFileThere 'hopefully this won't get the wrong file! 
239            DoEvents 
240            On Error GoTo Proc_Err 
241         End If 
242     
243          'save and close workbook
244         With xlWb 
245            .Close True, sPathFileWithoutExtension 
246         End With 
247     
248         booMsg = True 
249     
250      Proc_Exit: 
251         On Error Resume Next 
252         If Not rs Is Nothing Then 
253            rs.Close 
254            Set rs = Nothing 
255         End If 
256         If Not booMsg Then 
257            xlWb.Close False 
258            Set xlWb = Nothing 
259         End If 
260     
261         If TypeName(xlApp) <> "Nothing" Then 
262            xlApp.Quit 
263            Set xlApp = Nothing 
264         End If 
265         If booMsg Then 
266            MsgBox sPathFileWithoutExtension _ 
267               & vbCrLf & vbCrLf & " has been created for current version of Excel" _ 
268               & vbCrLf & vbCrLf & nRecords & " Records" _ 
269               & vbCrLf & vbCrLf & "Time to execute: " _ 
270               & Format(Timer - nTimerStart, "#,###.##") & " seconds" _ 
271               , , "Done" 
272         End If 
273     
274         Exit Sub 
275     
276      Proc_Err: 
277         MsgBox Err.Description _ 
278               , , "ERROR " & Err.Number _ 
279               & "   DocumentQueryCalculatedFields" 
280     
281         Resume Proc_Exit 
282         Resume 
283      End Sub 
284     
      Goto Top       Goto mod_DocumentQueryCalculatedFields_Crystal       Goto Index

mod_helper_HTMLcalendar (653)

PROCEDURES       Goto Top       Goto mod_helper_HTMLcalendar       Goto Modules       Goto Index
  1. CorrectCase (20)
  2. CorrectFilename (25)
  3. GetDataType (608)

CorrectFilename (25)

1         'Option Compare Database
2         'Option Explicit
3         '
4        Function CorrectFilename(pName) As String 
5           Dim i As Integer, mChar As String * 1, mName As String, mLastChar As String * 1 
6           Dim mNewChar As String 
7           If IsNull(pName) Then Exit Function 
8           pName = LTrim(Trim(pName)) 
9           For i = 1 To Len(pName) 
10             mChar = Mid(pName, i, 1) 
11        '      use this line if you also want to replaces spaces
12             If InStr("`!@#$%^&*()+=|\:;""'<>,.?/ ", mChar) > 0 Then 
13        '      If InStr("`!@#$%^&*()+=|\:;""'<>,.?/", mChar) > 0 Then
14                mNewChar = "_" 
15             Else 
16                mNewChar = mChar 
17             End If 
18             If mLastChar = "_" And mNewChar = "_" Then 
19             Else 
20                mName = mName & mNewChar 
21             End If 
22             mLastChar = mNewChar 
23          Next i 
24          CorrectFilename = mName 
25       End Function 
      Goto Top       Goto mod_helper_HTMLcalendar       Goto Index

CorrectCase (20)

26      
27       Function CorrectCase() 
28          On Error Resume Next 
29      
30         Dim c As Control, mStr As String 
31         Set c = Screen.ActiveControl 
32         mStr = c 
33          'if control is a textbox or combobox, capitalize the first letter of each word
34         Select Case Screen.ActiveControl.ControlType 
35         Case acTextBox, acComboBox 
36           c = StrConv(Nz(c, vbNull), vbProperCase) 
37           Exit Function 
38         End Select 
39         On Error Resume Next 
40          'if combo and entry is already in the list...choose list
41         If c = c.Column(0) Then 
42           c = c.Column(0) 
43         End If 
44      
45       End Function 
      Goto Top       Goto mod_helper_HTMLcalendar       Goto Index

GetDataType (608)

46      
47       Function GetDataType(ByVal pDatType As String) As String 
48          GetDataType = "" 
49          On Error Resume Next 
50          Select Case Nz(pDatType) 
51             Case 1: GetDataType = "Boolean" 
52             Case 2: GetDataType = "Byte" 
53             Case 3: GetDataType = "Integer" 
54             Case 4: GetDataType = "Long" 
55             Case 5: GetDataType = "Currency" 
56             Case 6: GetDataType = "Single" 
57             Case 7: GetDataType = "Double" 
58             Case 8: GetDataType = "Date" 
59             Case 10: GetDataType = "Text" 
60             Case 12: GetDataType = "Memo" 
61             Case Else: GetDataType = Format(Nz(pDatType), "0") 
62          End Select 
63       End Function 
64      
65      
66        ''Crystal
67        ''strive4peace2004@yahoo.ca
68        ''1-2-05 ReportElapsedTime
69        ''4-11-06 SysCmd acSysCmdClearStatus
70        ''5-15-06 checked against cc_ReportElapsedTime
71        '
72        'Const gCREATEQUERY = False
73        'Dim gStartTime As Date, gLineNumber As Integer
74        '
75        'Sub EndTime()
76        '   Debug.Print "--- END-------------" & DateDiff("s", gStartTime, Now()) & " seconds"
77        '   DoCmd.Hourglass False
78        '   SysCmd acSysCmdClearStatus
79        'End Sub
80        '
81        'Sub StartTime(Optional pMsg, Optional pLineNumber)
82        '   On Error Resume Next
83        '   gStartTime = Now()
84        '   DoCmd.Hourglass True
85        ''   pFirstSQL = Nz(DMax("id", "usys_sql"), 0) + 1
86        '   If IsMissing(pMsg) Then Exit Sub
87        '
88        '   'inialize debugger action counter
89        '
90        '   If IsMissing(pLineNumber) Then
91        '      gLineNumber = 1
92        '   Else
93        '      If pLineNumber < 0 Then
94        '         gLineNumber = Null
95        '      Else
96        '         gLineNumber = pLineNumber
97        '      End If
98        '   End If
99        '
100       ''   If IsMissing(pForm) Then gForm = Screen.ActiveForm.Name Else gForm = pForm
101       '
102       '   Debug.Print "--- START-------------" & pMsg & " ----- " & CStr(gStartTime)
103       'End Sub
104       '
105       'Function GetElapsedSeconds()
106       '   Dim mSeconds As Long
107       '   mSeconds = CLng(DateDiff("s", gStartTime, Now()))
108       '   If mSeconds < 60 Then
109       '      GetElapsedSeconds = Format(mSeconds, "#,##0") & " seconds   "
110       '   Else
111       '      GetElapsedSeconds = Format(DateDiff("n", gStartTime, Now()), "#,##0") & " minutes   "
112       '   End If
113       'End Function
114       '
115       'Sub ReportElapsedTime(Optional pMessage As String, Optional pTitle As String)
116       '
117       '   On Error Resume Next
118       '   Dim m As String, mEndTime As Date, mSec As Double
119       '   mEndTime = Now()
120       '   DoCmd.Hourglass False
121       '   If IsMissing(pMessage) Then
122       '      m = ""
123       '   Else
124       '      m = pMessage & vbCrLf & "-------------" & vbCrLf
125       '      Debug.Print "-------------" & pMessage & " ----- "
126       '   End If
127       '
128       '   m = m & "Start Time: " & Format(gStartTime, "hh:nn:ss") & vbCrLf _
129       '      & "End Time: " & Format(mEndTime, "hh:nn:ss") & "     --> "
130       '
131       '   mSec = (mEndTime - gStartTime) * 24 * 60 * 60
132       '
133       '   If mSec >= 60 Then
134       '      m = m & "     Elapsed Time: " & Format(mSec / 60, "0.####") & " minutes"
135       '   Else
136       '      m = m & "     Elapsed Time: " & Format(mSec, "0") & " seconds"
137       '   End If
138       '
139       '   MsgBox m, , IIf(IsMissing(pTitle), "Time to execute         ", pTitle)
140       '      '& CStr(Nz(pFirstSQL, -1))
141       '   SysCmd acSysCmdClearStatus
142       '
143       'End Sub
144       '
145       'Sub newProgram(Optional pLineNumber, Optional pForm)
146       '   'inialize debugger action counter
147       '   'if form is not LosReports, then pForm is the form name with the statusbar to update message in
148       '
149       '   If IsMissing(pLineNumber) Then gLineNumber = 0 Else gLineNumber = pLineNumber
150       ''   If IsMissing(pForm) Then gForm = Screen.ActiveForm.Name Else gForm = pForm
151       '
152       'End Sub
153       '
154       'Sub endProgram()
155       '   'inialize debugger action counter
156       ''   If gDEBUG Then Set rcode = Nothing
157       ''   gForm = ""
158       'End Sub
159       '
160       'Sub reportProgress(Optional m)
161       '   On Error Resume Next
162       '   If IsMissing(m) Then
163       '      m = ""
164       '      Application.SysCmd acSysCmdClearStatus
165       '   Else
166       '      If Len(Trim(m)) > 0 Then
167       '         Application.SysCmd acSysCmdSetStatus, m & " ..."
168       '      Else
169       '         Application.SysCmd acSysCmdClearStatus
170       '      End If
171       '   End If
172       ''On Error Resume Next
173       ''   Screen.ActiveForm!reportProgress = m
174       ''   DoEvents
175       'End Sub
176       '
177       'Sub reportProgressToScreen(Optional m, Optional IncludeElapsedSeconds)
178       '   On Error Resume Next
179       '   If IsMissing(m) Then
180       '      m = " "
181       '      Application.SysCmd acSysCmdClearStatus
182       '   Else
183       '      If Not IsMissing(IncludeElapsedSeconds) Then
184       '         If IncludeElapsedSeconds Then m = GetElapsedSeconds() & "  " & m
185       '      End If
186       '      m = m & " ..."
187       '   End If
188       'On Error Resume Next
189       '   Screen.ActiveForm!reportProgress = m
190       '   DoEvents
191       'End Sub
192       '
193       'Sub rSql(pSQL, Optional pMsg _
194       '   , Optional IsAggregateUpdate As Boolean _
195       '   , Optional RptToScreen As Boolean)
196       '   DoEvents
197       '   On Error GoTo rSQL_Error
198       '
199       '   Dim db As DAO.Database
200       '
201       '   Set db = CurrentDb 'dbengine(0)(0)
202       '
203       '   Dim mTime As Date
204       '   If gCREATEQUERY Then
205       '      If Nz(gLineNumber, 0) > 0 Then
206       '         MakeQuery pSQL, "usys_Step " & Format(gLineNumber, "000")
207       '      End If
208       '   End If
209       '   mTime = Now()
210       '   If Not IsMissing(RptToScreen) Then
211       '      On Error Resume Next
212       '      If RptToScreen Then reportProgressToScreen pMsg, True
213       '      On Error GoTo rSQL_Error
214       '   End If
215       '
216       '   If Not IsMissing(pMsg) Then
217       '      Debug.Print "~~~~~~~~~~~~~~ " & pMsg
218       '      SysCmd acSysCmdSetStatus, pMsg & "..."
219       '   End If
220       '   Debug.Print pSQL
221       '   If Not IsMissing(IsAggregateUpdate) Then
222       '      If IsAggregateUpdate Then
223       '         DoCmd.Echo False
224       '         DoCmd.SetWarnings False
225       '         DoCmd.RunSQL pSQL
226       '         DoCmd.Echo True
227       '         DoCmd.SetWarnings True
228       '      Else
229       '         db.Execute pSQL
230       '      End If
231       '   Else
232       '         CurrentDb.Execute pSQL
233       '   End If
234       '   Debug.Print " --- " & Format((Now() - mTime) * 24 * 60 * 60, "#,##0") & " seconds" & " --- "
235       '   If Nz(gLineNumber, 0) > 0 Then gLineNumber = gLineNumber + 1
236       '
237       ''MsgBox pSQL, , Nz(pMsg, "")
238       ''Stop
239       'Proc_Exit:
240       '   On Error Resume Next
241       '   Set db = Nothing
242       '   Exit Sub
243       '
244       'rSQL_Error:
245       '   DoCmd.Echo True
246       '   DoCmd.SetWarnings True
247       '
248       'End Sub
249       '
250       '
251       ''------------------------------------ MakeQuery
252       '
253       'Sub MakeQuery(ByVal pSQL As String, ByVal qName As String)
254       '   'Make a query OR change a query that is already made
255       '   'example useage: call from a report menu form before processing report
256       '   ' MakeQuery "SELECT Lname, Fname FROM People ORDER BY Lname;","qry_AddressList"
257       '   On Error GoTo MakeQuery_error
258       '
259       '   Dim mStr As String, booMake As Boolean
260       '
261       '   'if query already exists, update the SQL
262       '   'if not, create the query
263       '
264       '   booMake = True
265       '
266       '   DoCmd.Echo False
267       '   DoCmd.SetWarnings False
268       '   On Error Resume Next
269       '   Err.Number = 0
270       '   mStr = CurrentDb.QueryDefs(qName).Name
271       '   'if we were able to assign the query name to a string, it already exists
272       '   If Err.Number = 0 Then booMake = False
273       '   On Error GoTo MakeQuery_error
274       '   DoCmd.Echo True
275       '   DoCmd.SetWarnings True
276       '
277       '   If booMake Then
278       '      CurrentDb.CreateQueryDef qName, pSQL
279       '   Else
280       '      CurrentDb.QueryDefs(qName).SQL = pSQL
281       '   End If
282       '
283       'MakeQuery_exit:
284       '   CurrentDb.QueryDefs.Refresh
285       '   DoEvents
286       '   Exit Sub
287       '
288       'MakeQuery_error:
289       '   MsgBox Err.Description, , "ERROR " & Err.Number & "  MakeQuery"
290       '   DoCmd.Echo True
291       '   DoCmd.SetWarnings True
292       '   Stop
293       '   'Press F8 to step through code and find problem
294       '   'comment out when program is debugged
295       '   Resume
296       '   Resume MakeQuery_exit
297       'End Sub
298       '
299       '
300       '
301       '
302       ''~~~~~~~~~~~~~~~~~~~~~~~~~~ BoldMe
303       'Function BoldMe(Optional pF As Form _
304       '   , Optional pControlname As String = "" _
305       '   , Optional pNumOptions As Integer = 0 _
306       '   , Optional pValue As Variant _
307       '   ) As Byte
308       ''9-9-08,12-4-09
309       ''3-26-10 modify attached label if available. reversed naming convention
310       ''100330 nz
311       '
312       '   'Crystal
313       '   'strive4peace
314       '
315       '   'Bold the label is the option is chosen or value is true
316       '   'remove Bold is the value is not true or the option is not chosen
317       '
318       '   ' --------------------------------------------------------
319       '   'PARAMETERS
320       '   '  pF = form reference
321       '   '       if in code behind a form, this is
322       '   '                   Me
323       '   '
324       '   '  pControlName is name of control to test
325       '   '               if not specified, ActiveControl will be used
326       '   '
327       '   '  pNumOptions is the number of options in the frame (group)
328       '   '              must be specified for option frame
329       '   '
330       '   '  pValue is the comparison value for deciding Bold
331       '   '         if parameter is passed
332       '   '         then the opn frame will not be tested
333       '   '
334       '   '               Unattached Labels MUST be named like this:
335       '   '               Controlname_Label
336       '   '
337       '   '               NOTE: the "label" control
338       '   '                         does not have to be a label ControlType
339       '   '                     It can be, for instance, a textbox
340       '   ' --------------------------------------------------------
341       '   ' NOTES
342       '   '
343       '   ' for checkboxes and toggle buttons
344       '   '
345       '   '               if checkbox Name = MyCheckbox
346       '   '                  then label Name = MyCheckbox_Label
347       '   '               if the label is attached, it can be named anything
348       '   '
349       '   ' for options in a frame
350       '   '
351       '   '    if Frame Name = MyOptionFrame
352       '   '
353       '   '    then Frame Option Buttons are Named:
354       '   '          MyOptionFrame1, MyOptionFrame2, etc
355       '   '
356       '   '    Labels for Frame Option Buttons are Named:
357       '   '          MyOptionFrame1_Label, MyOptionFrame2__Label, etc
358       '   '          if the labels are attached, they can be named anything
359       '   '
360       '   '    Numbers in the name correspond to the Option Order
361       '   '
362       '   '    Option Values can be any number
363       '   '
364       '
365       '   ' --------------------------------------------------------
366       '   'USEAGE
367       '   '   BoldMe Me
368       '   '       Bold the label of the
369       '   '         active checkbox or toggle control
370       '   '       if the control value = True
371       '   '
372       '   '   BoldMe Me, "Mycheckbox_controlname"
373       '   '       Bold the label of the
374       '   '         specified checkbox or toggle control
375       '   '       if the control value = True
376       '   '
377       '   '   BoldMe Me, "Mycheckbox_controlname",,True
378       '   '       Bold the label of the
379       '   '         specified checkbox or toggle control
380       '   '
381       '   '   BoldMe Me, "MyFrame_controlname", 4
382       '   '       Bold the label of the option
383       '   '            in the specified frame control
384       '   '            if the Option Value = the Frame Value
385       '   '       where there are 4 options to pick from
386       '   '
387       '   '   BoldMe Me, "MyFrame_controlname", 4, 999
388       '   '       Bold the label of the option
389       '   '            in the specified frame control
390       '   '            if the Option Value = 999
391       '   '       where there are 4 options to pick from
392       '   '
393       '
394       '
395       '   'On Error GoTo Proc_Err
396       '
397       '   If pF Is Nothing Then Set pF = Screen.ActiveForm
398       '
399       '   Dim mBoo As Boolean _
400       '      , mControlName As String _
401       '      , mControlNameLabel As String _
402       '      , mControlnameOption As String
403       '
404       '   If Len(pControlname) > 0 Then
405       '      mControlName = pControlname
406       '   Else
407       '      mControlName = pF.ActiveControl.Name
408       '   End If
409       '
410       '   If IsMissing(pValue) Then
411       '      pValue = pF(mControlName).Value
412       '   End If
413       '
414       '   ' use WITH to minimize the number of times
415       '   ' this code has to access the object
416       '
417       '   'checkbox or toggle button
418       '   With pF(mControlName)
419       '
420       '      Select Case .ControlType
421       '      Case acCheckBox, acToggleButton
422       '
423       '         If IsMissing(pValue) Then
424       '            mBoo = Nz(.Value, False)
425       '         Else
426       '            'note: Null cannot be compared
427       '            mBoo = Nz(pValue)
428       '         End If
429       '
430       '         If pF(mControlName).Controls.Count > 0 Then
431       '            mControlNameLabel = pF(mControlName).Controls(0).Name
432       '         Else
433       '            mControlNameLabel = mControlName & "_Label"
434       '         End If
435       '
436       '         With pF(mControlNameLabel)
437       '            ' see if Bold is already right
438       '            If .FontBold <> mBoo Then
439       '               ' Bold needs to change
440       '               .FontBold = mBoo
441       '            End If
442       '         End With
443       '
444       '         GoTo Proc_Exit
445       '
446       '      'option box - MUST SPECIFY pNumOptions
447       '      Case acOptionGroup
448       '
449       '         Dim i As Integer
450       '
451       '         For i = 1 To pNumOptions
452       '            mControlnameOption = mControlName & Format(i, "0")
453       '            If IsNull(pValue) Then
454       '               ' if the comparison is blank
455       '               ' no option will be bolded
456       '               mBoo = False
457       '            Else
458       '               ' if the option value = the comparison value
459       '               ' then mBoo = TRUE
460       '               mBoo = IIf( _
461       '               pF(mControlnameOption).OptionValue = pValue, True, False)
462       '            End If
463       '
464       '            If pF(mControlnameOption).Controls.Count > 0 Then
465       '               mControlNameLabel = pF(mControlnameOption).Controls(0).Name
466       '            Else
467       '               mControlNameLabel = mControlnameOption & "_Label"
468       '            End If
469       '
470       '            With pF(mControlNameLabel)
471       '               If .FontBold <> mBoo Then
472       '                  .FontBold = mBoo
473       '               End If
474       '            End With
475       '
476       '         Next i
477       '
478       '         GoTo Proc_Exit
479       '
480       '      End Select
481       '
482       '   End With
483       '
484       'Proc_Exit:
485       '   On Error Resume Next
486       '   pF.Repaint
487       '   Exit Function
488       '
489       'Proc_Err:
490       '   MsgBox Err.Description _
491       '      , , "ERROR " & Err.Number & "  BoldMe " & mControlName
492       '
493       '   Resume Proc_Exit
494       '
495       '   'if you want to single-step code to find error, CTRL-Break at MsgBox
496       '   'then set this to be the next statement
497       '   Resume
498       '
499       'End Function
500       '
501       ''------------------------------------ Open_Form
502       'Function open_Form(pFormName As String, Optional pOpenArgs As String)
503       '   'Open the the passed Form, optionally send pOpenArgs as Open Arguments
504       '   'for instance, you may have a form where the user can pick an Address
505       '   'maybe what they want is not on the list, so you can open the Addresses form
506       '   'The code behind the Addresses form would:
507       '   '  capture the ActiveForm.Name in the Open event with a global variable
508       '   '  requery the passed controlname on the captured formname and fill it out automatically
509       '   'example useage: OnClick event of an option on a menu (command button, label, etc)
510       '   ' = Open_Form("Addresses")
511       '   ' = Open_Form("Addresses", "AddrID")
512       '   On Error GoTo Open_Form_error
513       '   If IsMissing(pOpenArgs) Then
514       '      DoCmd.OpenForm pFormName
515       '   Else
516       '      DoCmd.OpenForm pFormName, , , , , , pOpenArgs
517       '      End If
518       '   Exit Function
519       'Open_Form_error:
520       '   MsgBox Err.Number & " " & Err.Description, , "Cannot open " & pFormName
521       'End Function
522       '
523       ''------------------------------------ RequeryMe
524       'Function RequeryMe()
525       '   'used to rebuild combo box and listbox lists
526       '   'put on the double-click event of a combobox
527       '   '=RequeryMe()
528       '   On Error GoTo RequeryMe_error
529       '   Screen.ActiveControl.Requery
530       ''   MsgBox "Rebuilt List for " & Screen.ActiveControl.Name, , "RequeryMe"
531       '   Exit Function
532       'RequeryMe_error:
533       '   MsgBox Err.Number & " " & Err.Description, , "Cannot Requery control right now"
534       'End Function
535       '
536     
537       '
538       ''------------------------------------ SetReportFilter
539       'Sub SetReportFilter( _
540       '   pReportName As String _
541       '   , pvFilter As Variant)
542       '
543       '   'Save a filter to the specified report
544       '   'You can do this before you send a report in an email message
545       '   'You can use this to filter subreports instead of putting criteria in the recordset
546       '
547       '   ' USEAGE:
548       '   ' example: in code that processes reports for viewing, printing, or email
549       '   ' SetReportFilter "MyReportname","someID=1000"
550       '   ' SetReportFilter "MyAppointments","City='Denver' AND dt_appt=#9/18/05#"
551       '
552       '   ' written by Crystal
553       '   ' Strive4peace2004@yahoo.ca
554       '
555       '   ' PARAMETERS:
556       '   ' pReportName is the name of your report
557       '   ' pvFilter is a valid filter string or null
558       '
559       '   On Error GoTo SetReportFilter_error
560       '
561       '   '---------- declare variables
562       '   Dim rpt As Report
563       '
564       '   '----------  open design view of report and set the report object variable
565       '   DoCmd.OpenReport pReportName, acViewDesign
566       '   Set rpt = Reports(pReportName)
567       '
568       '   '---------- set report filter and turn it on
569       '   If Not IsNull(pvFilter) Then
570       '      rpt.Filter = pvFilter
571       '      rpt.FilterOn = True
572       '   Else
573       '      rpt.FilterOn = False
574       '   End If
575       '
576       '   '---------- save and close the changed report
577       '   DoCmd.Save acReport, pReportName
578       '   DoCmd.Close acReport, pReportName, acSaveNo
579       '
580       '   '----------  Release object variable
581       '   Set rpt = Nothing
582       '
583       '   Exit Sub
584       '
585       'SetReportFilter_error:
586       '   Resume Next
587       '
588       '   MsgBox Err.Description, , "ERROR " & Err.Number & "  SetReportFilter"
589       '   'press F8 to step thru code and fix problem
590       '   Stop
591       '   Resume
592       '   'next line will be the one with the error
593       'End Sub
594       '
595       '
596       ''================================================================= Email
597       ''SendObject
598       ''[objecttype]
599       ''[, objectname]
600       ''[, outputformat]
601       ''[, to]
602       ''[, cc]
603       ''[, bcc]
604       ''[, subject]
605       ''[, messagetext]
606       ''[, editmessage]
607       ''[, templatefile]
608       '
609       ''------------------------------------ EMailReport
610       'Sub EMailReport(pReportName As String, pEmailAddress As String, pFriendlyName As String _
611       '   , pBooEditMessage As Boolean, pWhoFrom As String)
612       '
613       '   'Email a report to someone and construct the subject and message
614       '   'SNAPSHOT Format
615       '
616       '   'example useage: on the command button code to process a report
617       '   ' EMailReport "rptSonglist", "anyone@mymailbox.com", _
618       '         "A List of the Original Songs from an upcoming Star", _
619       '         false, "Susan Manager"
620       '
621       '   'PARAMETERS
622       '   'pReportName --> "rptSonglist"
623       '   'pEmailAddress --> "anyone@mymailbox.com"
624       '   'pFriendlyName --> "A List of the Original Songs from an upcoming Star"
625       '   'pBooEditMessage --> true if you want to edit the message before mail is sent
626       '   '                --> false if you want it to get sent automatically
627       '   'pWhoFrom --> "Susan Manager"
628       '
629       '   On Error GoTo EMailReport_error
630       '   On Error Resume Next
631       '
632       '   '----------------------- RTF FORMAT
633       '  DoCmd.SendObject acSendReport, pReportName, acFormatRTF, pEmailAddress _
634       '   , , , pFriendlyName & Format(Now(), " ddd m-d-yy h:nn am/pm"), _
635       '   pFriendlyName & " is attached  ---    " _
636       '   & "Regards, " & pWhoFrom, pBooEditMessage
637       '
638       '   '----------------------- SNAPSHOT FORMAT -- commented out
639       ''  DoCmd.SendObject acSendReport, pReportName, acFormatSNP, pEmailAddress _
640       '   , , , pFriendlyName & Format(Now(), " ddd m-d-yy h:nn am/pm"), _
641       '   pFriendlyName & " is attached  ---    " _
642       '   & "Regards, " & pWhoFrom, pBooEditMessage
643       '
644       '   Exit Sub
645       '
646       'EMailReport_error:
647       '   MsgBox Err.Description, , "ERROR " & Err.Number & "  EMailReport"
648       '   'press F8 to find problem and fix -- comment out next 2 lines when code is done
649       '   Stop
650       '   Resume
651       '
652       'End Sub
653     
      Goto Top       Goto mod_helper_HTMLcalendar       Goto Index

mod_local_Anywhere (880)

PROCEDURES       Goto Top       Goto mod_local_Anywhere       Goto Modules       Goto Index
  1. AttachNote (269)
  2. Declaration Lines (2)
  3. FindRecordNsub (28)
  4. Form_Current (23)
  5. GetAttachmentPath (51)
  6. GetMax (32)
  7. GetMin (36)
  8. GetNameFromURL (48)
  9. GetTheURL (16)
  10. GetWholePathFile (45)
  11. PopAttachments (24)
  12. popNotes (43)
  13. run_SaveAttachmentsToFiles (20)
  14. SaveAttachmentsToFiles (200)
  15. testGetNameFromURL (43)

Declaration Lines (2)

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

testGetNameFromURL (43)

3       
4       
5         '=======================================================
6         '
7         'Helper code for Anywhere Notes and Anywhere Attachments by Crystal
8         '
9         '============================================================ LICENSE NOTICE -- must not be modified
10        ' This software is licensed to you under CC BY-NC-SA 3.0
11        '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
12        ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
13        '
14        ' You are free to:
15        '    Share — copy and redistribute the material in any medium or format
16        '    Adapt — remix, transform, and build upon the material
17        ' The licensor cannot revoke these freedoms as long as you follow these terms:
18        '    Attribution — You must give appropriate credit, provide a link to the license,
19        '                   and indicate if changes were made.
20        '                   You may do so in any reasonable manner,
21        '                   but not in any way that suggests the licensor endorses you or your use.
22        '    NonCommercial — You may not use the material for commercial purposes.
23        '    ShareAlike — If you remix, transform, or build upon the material,
24        '                 you must distribute your contributions under the same license as the original.
25        '
26        ' many procedures and module names contain author or controbitor names that must be left intact
27        ' if you make changes, add your name, date, and descriptive information to the comments
28        '
29        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629
30        ' ~ Crystal
31        '              * have an awesome day :)
32        '                                                   www.AccessMVP.com/strive4peace
33        ' END LICENSE NOTICE
34        '============================================================
35        'NEEDS PROPERTIES:
36        '   "local_TID"
37        '   "local_RecordID"
38      
39        '  ++  ADD property functions
40        '______________________________________________________ ATTACHMENTS
41      
42       Sub testGetNameFromURL() 
43          Dim sExtension As String 
44          MsgBox (GetNameFromURL("http://www.accessmvp.com", sExtension)), , sExtension 
45       End Sub 
      Goto Top       Goto mod_local_Anywhere       Goto Index

GetNameFromURL (48)

46      
47       Public Function GetNameFromURL( _ 
48          ByVal psLink As String _ 
49          , Optional psExtension As String _ 
50          ) As String 
51        '130917, 141006
52      
53          Dim iPos As Integer _ 
54             , iPos2 As Integer _ 
55             , iPos3 As Integer _ 
56             , iLength As Integer _ 
57             , sName As String 
58      
59          sName = "" 
60          psExtension = "" 
61      
62          If Right(psLink, 1) = "/" Then 
63             psLink = Left(psLink, Len(psLink) - 1) 
64          End If 
65      
66          iPos = InStrRev(psLink, "/") 
67      
68          If iPos > 0 Then 
69             iPos2 = InStrRev(psLink, "#") 
70             iPos3 = InStrRev(psLink, "?") 
71             iLength = GetMax(Array( _ 
72                Nz(GetMin(False, Array(iPos2, iPos3)), -1) - iPos _ 
73                , Len(psLink) - iPos - 1 _ 
74                )) 
75      
76             If iLength < 0 Then iLength = 50 
77      
78             sName = Mid(psLink, iPos + 1, iLength) 
79      
80             If Left(sName, 4) = "www." Then 
81                sName = Mid(sName, 5) 
82             End If 
83      
84             iPos = InStrRev(sName, ".") 
85             If iPos > 0 Then 
86                psExtension = Mid(sName, iPos) 
87        '         sName = Left(sName, iPos - 1)
88             End If 
89          End If 
90      
91          GetNameFromURL = sName 
92      
93       End Function 
      Goto Top       Goto mod_local_Anywhere       Goto Index

GetMin (36)

94      
95      
96       Public Function GetMin(booZeroOK As Boolean _ 
97          , arrValues As Variant) As Variant 
98        '130917 Crystal
99           'return the minimum value in an array
100          ' can be called like this: GetMin(array(1,2,99,-9))
101     
102         Dim i As Integer _ 
103            , vMin As Variant 
104     
105         On Error GoTo Proc_Err 
106         GetMin = Null 
107         If IsNull(arrValues) Then Exit Function 
108         vMin = arrValues(LBound(arrValues)) 
109         For i = LBound(arrValues) To UBound(arrValues) 
110            If Not booZeroOK And vMin = 0 Then 
111               vMin = arrValues(i) 
112            ElseIf vMin > arrValues(i) Then 
113               vMin = arrValues(i) 
114            End If 
115         Next i 
116         GetMin = vMin 
117     
118      Proc_Exit: 
119         On Error Resume Next 
120         Exit Function 
121     
122      Proc_Err: 
123         MsgBox Err.Description, , _ 
124              "ERROR " & Err.Number _ 
125              & "   GetMin" 
126     
127         Resume Proc_Exit 
128         Resume 
129      End Function 
      Goto Top       Goto mod_local_Anywhere       Goto Index

GetMax (32)

130     
131      Public Function GetMax(arrValues As Variant) As Variant 
132       '130917 Crystal
133          'return the maximum value in an array
134          ' can be called like this: GetMax(array(1,2,99,-9))
135     
136         Dim i As Integer _ 
137            , vMax As Variant 
138     
139         On Error GoTo Proc_Err 
140         GetMax = Null 
141         If IsNull(arrValues) Then Exit Function 
142         vMax = arrValues(LBound(arrValues)) 
143         For i = LBound(arrValues) To UBound(arrValues) 
144            If vMax < arrValues(i) Then 
145               vMax = arrValues(i) 
146            End If 
147         Next i 
148         GetMax = vMax 
149     
150      Proc_Exit: 
151         On Error Resume Next 
152         Exit Function 
153     
154      Proc_Err: 
155         MsgBox Err.Description, , _ 
156              "ERROR " & Err.Number _ 
157              & "   GetMax" 
158     
159         Resume Proc_Exit 
160         Resume 
161      End Function 
      Goto Top       Goto mod_local_Anywhere       Goto Index

GetAttachmentPath (51)

162     
163     
164      Public Function GetAttachmentPath( _ 
165          Optional psPathUnder As String = "" _ 
166         ) As String 
167       '130916 -- 131009 -- DEFAULT to CurrentProject.Path & \Attachments
168     
169         Dim sPath As String _ 
170            , sPathAttachment As String 
171     
172     
173          'ALWAYS returns CurrentProject.Path & \Attachments
174         GetAttachmentPath = CurrentProject.Path & "\Attachments\" 
175      Exit Function 
176     
177     
178         If Len(psPathUnder) > 0 Then 
179     
180         Else 
181     
182     
183         End If 
184     
185         sPath = Trim(Get_Property("local_PathAtt")) 
186     
187         sPathAttachment = sPath 
188         If Left(sPathAttachment, 1) = "\" Then 
189             'relative path
190            sPathAttachment = CurrentProject.Path & sPathAttachment 
191         End If 
192     
193         If Not Len(sPathAttachment) > 0 Then 
194            sPathAttachment = CurrentProject.Path & "\Attachments" 
195     
196            If Not Len(Dir(sPathAttachment, vbDirectory)) > 0 Then 
197               MkDir sPathAttachment 
198            End If 
199         End If 
200     
201          ' trailing \
202         If Right(sPathAttachment, 1) <> "\" Then 
203            sPathAttachment = sPathAttachment & "\" 
204         End If 
205     
206         If sPath <> sPathAttachment Then 
207            Call Set_Property("local_PathAtt", sPathAttachment) 
208         End If 
209     
210         GetAttachmentPath = sPathAttachment 
211     
212      End Function 
      Goto Top       Goto mod_local_Anywhere       Goto Index

GetWholePathFile (45)

213     
214      Public Function GetWholePathFile( _ 
215         vRelativePathFile As Variant _ 
216         , Optional booImageOnly As Boolean = False _ 
217         ) As String 
218     
219         On Error GoTo Proc_Err 
220         GetWholePathFile = "" 
221     
222         Dim sPathFile As String _ 
223            , sPathAttachments As String 
224     
225         sPathAttachments = GetAttachmentPath() 
226     
227         If IsNull(vRelativePathFile) Then Exit Function 
228     
229         If booImageOnly Then 
230            Select Case Right(vRelativePathFile, 4) 
231               Case ".jpg", ".png", ".bmp" 
232               Case Else 
233                  Exit Function 
234            End Select 
235         End If 
236     
237         If InStr(vRelativePathFile, "\") = 0 And InStr(vRelativePathFile, "/") = 0 Then 
238            sPathFile = sPathAttachments & vRelativePathFile 
239         ElseIf Len(Dir(vRelativePathFile)) > 0 Then 
240            sPathFile = vRelativePathFile 
241         End If 
242     
243         GetWholePathFile = sPathFile 
244     
245     
246      Proc_Exit: 
247         On Error Resume Next 
248         Exit Function 
249     
250      Proc_Err: 
251       '   MsgBox Err.Description, , _
252               "ERROR " & Err.Number _
253               & "   GetWholePathFile"
254     
255         Resume Proc_Exit 
256         Resume 
257      End Function 
      Goto Top       Goto mod_local_Anywhere       Goto Index

GetTheURL (16)

258     
259      Public Function GetTheURL( _ 
260         vRelativePathFile As Variant _ 
261         ) As String 
262     
263         GetTheURL = "" 
264     
265         If IsNull(vRelativePathFile) Then Exit Function 
266     
267         If InStr(vRelativePathFile, "tp:/") > 0 Then 
268            GetTheURL = vRelativePathFile 
269         Else 
270             'need more code
271         End If 
272     
273      End Function 
      Goto Top       Goto mod_local_Anywhere       Goto Index

PopAttachments (24)

274       '~~~~~~~~~~~~~~~~~ popup:
275      Public Function PopAttachments(pF As Form _ 
276         , nTID As Long _ 
277         , vRecordID As Variant _ 
278         , Optional pnRolliD As Long = -99 _ 
279         ) As Boolean 
280       '130909
281         On Error Resume Next 
282         PopAttachments = False 
283         If IsNull(vRecordID) Then Exit Function 
284     
285         With pF 
286            If .Dirty Then .Dirty = False 
287            If Not .NewRecord Then 
288               Call Set_Property("local_TID", nTID) 
289               Call Set_Property("local_RecordID", vRecordID) 
290               If Not pnRolliD = -99 Then Call Set_Property("local_RolliD", pnRolliD) 
291               DoCmd.OpenForm "fc_AnywhereAttachments", , , , , acDialog 
292            End If 
293         End With   'passed form 
294     
295         PopAttachments = True 
296     
297      End Function 
      Goto Top       Goto mod_local_Anywhere       Goto Index

Form_Current (23)

298     
299     
300       '~~~~~~~~~~~~~~~~~ subform:
301       'change rowsource in listbox
302       'to lookup records when the parent record is changed
303     
304      Public Sub Form_Current(pF As Form _ 
305         , nTID As Long _ 
306         , vRecordID As Variant) 
307       '130909
308         On Error Resume Next 
309         If IsNull(vRecordID) Then Exit Sub 
310     
311         With pF 
312            If .Dirty Then .Dirty = False 
313            If Not .NewRecord Then 
314               Call Set_Property("local_TID", nTID) 
315               Call Set_Property("local_RecordID", vRecordID) 
316               Call .fc_AnywhereAttachments.Form.Rowsource_ListDocs(nTID, vRecordID) 
317            End If 
318         End With   'passed form with DocPics as a subform 
319     
320      End Sub 
      Goto Top       Goto mod_local_Anywhere       Goto Index

FindRecordNsub (28)

321     
322       '~~~~~~~~~~~~~~~~~ find attachment on subform:
323      Public Sub FindRecordNsub(pF As Form _ 
324         , nTID As Long _ 
325         , vRecordID As Variant _ 
326         , sKeyName1 As String _ 
327         , vDocID As Variant _ 
328         , sKeyName2 As String _ 
329         , Optional sFocusControlname As String = "" _ 
330         ) 
331       '130909
332         On Error Resume Next 
333         If IsNull(vRecordID) Then Exit Sub 
334     
335         Call FindRecordN(pF, sKeyName1, , vRecordID, True) 
336     
337         With pF.fc_AnywhereAttachments 
338     
339            .SetFocus 
340            Call .Form.Rowsource_ListDocs(nTID, vRecordID) 
341     
342            If Not IsNull(vDocID) Then 
343               Call FindRecordN( _ 
344                  .Form, sKeyName2, sFocusControlname, vDocID) 
345            End If 
346         End With   'pF 
347     
348      End Sub 
      Goto Top       Goto mod_local_Anywhere       Goto Index

popNotes (43)

349     
350       '______________________________________________________ NOTES
351     
352      Public Function popNotes(pF As Form _ 
353         , nTID As Long _ 
354         , vRecordID As Variant _ 
355         , Optional vRollID As Variant = -99 _ 
356         ) As Boolean 
357     
358         On Error GoTo Proc_Err 
359         popNotes = False 
360         If IsNull(vRecordID) Then Exit Function 
361     
362       '130912, 140928
363     
364         Dim sWhere As String 
365     
366         With pF 
367            If .Dirty Then .Dirty = False 
368            If Not .NewRecord Then 
369               Call Set_Property("local_TID", nTID) 
370               Call Set_Property("local_RecordID", Nz(vRecordID, -99)) 
371               Call Set_Property("local_RollID", Nz(vRollID, -99)) 
372               sWhere = "TID=" & nTID & " AND RecordID=" & vRecordID 
373               If Nz(vRollID, -99) > 0 Then Call Set_Property("local_CID", vRollID) 
374               DoCmd.OpenForm "fc_AnywhereNotes", , , sWhere, , acDialog 
375            End If 
376         End With   'passed form 
377     
378         popNotes = True 
379     
380      Proc_Exit: 
381         On Error Resume Next 
382         Exit Function 
383     
384      Proc_Err: 
385         MsgBox Err.Description, , _ 
386              "ERROR " & Err.Number _ 
387              & "   popNotes" 
388     
389         Resume Proc_Exit 
390         Resume 
391      End Function 
      Goto Top       Goto mod_local_Anywhere       Goto Index

AttachNote (269)

392     
393     
394      Public Function AttachNote( _ 
395          pnTID As Long _ 
396         , pnRecordID As Long _ 
397         , Optional pnCID As Long = -99 _ 
398         , Optional pnTopicID As Long = -99 _ 
399         ) 
400     
401     
402         Call Set_Property("local_TID", pnTID) 
403         Call Set_Property("local_RecordID", pnRecordID) 
404     
405     
406         Call Set_Property("local_TopicID", pnTopicID) 
407     
408       '   DoEvents
409     
410         DoCmd.OpenForm "fc_AnywhereNotes", , , , , acDialog 
411     
412      End Function 
413     
414     
415       '
416       ''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ FormBeforeUpdate
417       'Function FormBeforeUpdate( _
418       '    pF As Form _
419       '   , Optional bUpdateParentToo As Boolean = False) As Boolean
420       ''121116
421       '   On Error GoTo Proc_Err
422       '   FormBeforeUpdate = False
423       '
424       '   Dim nUserID As Long
425       '   nUserID = CurrentDb.Properties("local_UserID")
426       '
427       '    If bUpdateParentToo Then
428       '      pF.Parent.dtmEdit = Now()
429       '      pF.Parent!IDedit = nUserID
430       '   End If
431       '   If pF.NewRecord Then
432       '      pF!IDadd = nUserID
433       '      Exit Function
434       '   End If
435       '   pF!dtmEdit = Now()
436       '   pF!IDedit = nUserID
437       '
438       '   FormBeforeUpdate = True
439       '
440       'Proc_Exit:
441       '   On Error Resume Next
442       '   Exit Function
443       '
444       'Proc_Err:
445       '   MsgBox Err.Description, , _
446       '        "ERROR " & Err.Number _
447       '        & "   FormBeforeUpdate"
448       '
449       '   Resume Proc_Exit
450       '   Resume
451       'End Function
452       '
453       '
454       ''~~~~~~~~~~~~~~~~~~~~~~~~~~ RecordNew
455       'Function RecordNew(pF As Form _
456       '   , Optional pFirstControlName As String = "" _
457       '   , Optional pUnlockDataTag As String = "" _
458       '   ) As Byte
459       ''3-20-09, 2-4-10 pUnlockDataTag
460       '
461       '   'example useage: Click [Event Procedure] for a New Record command button
462       '   ' RecordNew
463       '   ' RecordNew Me
464       '   ' RecordNew Me, "Controlname"
465       '   ' RecordNew Me, "Controlname", "~Data~"
466       '
467       '   On Error Resume Next
468       '   If pF.Dirty Then pF.Dirty = False
469       '
470       '   On Error GoTo Proc_Err
471       '
472       '   If Not pF.NewRecord Then
473       '      If Not pF.AllowAdditions Then
474       '         pF.AllowAdditions = True
475       '      End If
476       '      pF.Recordset.AddNew
477       '   End If
478       '
479       ''   If pUnlockDataTag <> "" Then
480       ''      'Lock controls and set back style to transparent
481       ''      LockUnlockControls pF, True, pUnlockDataTag, True '"~Data~"
482       ''   End If
483       '
484       '   On Error Resume Next
485       '   If pFirstControlName <> "" Then
486       '      pF(pFirstControlName).SetFocus
487       '   End If
488       '
489       '   DoEvents
490       '
491       'Proc_Exit:
492       '   Exit Function
493       'Proc_Err:
494       '   If Err.Number = 2046 Then
495       '      ' already on a new record
496       '      Exit Function
497       '   End If
498       '   MsgBox Err.Description, , _
499       '     "ERROR " & Err.Number & "   RecordNew"
500       '
501       '   Resume Proc_Exit
502       '   Resume
503       '
504       'End Function
505       '
506       '
507       '
508       ''~~~~~~~~~~~~~~~~~~~~ IsSubform
509       'Function IsSubform(pForm As Form) As Boolean
510       '   Dim mStr As String
511       '   On Error Resume Next
512       '   mStr = pForm.Parent.Name
513       '   If Err.Number > 0 Then
514       '      IsSubform = False
515       '   Else
516       '      IsSubform = True
517       '   End If
518       'End Function
519       '
520       '
521       ''~~~~~~~~~~~~~~~~~~~~~~~~~~ FindRecordN
522       '' usually used by Find combos on forms
523       '' find record given a numeric fieldname and value
524       '
525       'Function FindRecordN(pF As Form _
526       '   , pKeyFieldname As String _
527       '   , Optional pCtrlName_SetFocus As String = "" _
528       '   , Optional pRecordID = 0 _
529       '   , Optional pbClear As Boolean = True _
530       '   , Optional pbChkIsLoaded As Boolean = False _
531       '   ) As Boolean
532       ''8-17-08, 8-22 pbChkIsLoaded, 12-19-08 comments, 4-5-09 comments
533       '
534       '   'Crystal (strive4peace)
535       '
536       '  'PARAMETERS
537       '  'pF --> form reference
538       '  'pKeyFieldname = name of numeric key field
539       '  'pCtrlName_SetFocus -- name of control to set focus to
540       '  'pRecordID = numeric value of key field to look up
541       '  'pbClear -- set control = Null after finding (default = true)
542       '  'pbChkIsLoaded -- check if form is loaded (default = false)
543       '
544       '   'USEAGE
545       '   '  on the AfterUpdate [Event Procedure] of a control to find a record (ie: combo or listbox)
546       '   '   FindRecordN Me, "SoftwareID", "SoftwareName"
547       '   '
548       '   ' if you are searching a subform:
549       '   '   FindRecordN Me.subform_controlname.form, "SoftwareID", "SoftwareName"
550       '   '
551       '   ' if you want to find a record, such as you got the ID in code:
552       '   '   FindRecordN Me, "SoftwareID", "SoftwareName", lngSoftwareID
553       '   '       by default, if you specify an ID to find,
554       '   '       the procedure will not attempt to clear any controls
555       '   '
556       '   ' if you are finding a record on a form that may not be open:
557       '   '    FindRecordN Forms!People, "PeopleID", "LastName",,,True
558       '   '
559       '   ' if you are want to send a value of the field to search:
560       '   '   FindRecordN Me, "PID", "Lastname", lngPID
561       '   '      note: if you are sending a value, the control will not be cleared
562       '   '
563       '
564       '   'set up Error Handler
565       '   On Error GoTo Proc_Err
566       '
567       '   FindRecordN = False
568       '
569       '   If pbChkIsLoaded Then
570       '      If Not IsLoadedForm(pF.Name) Then
571       '         Exit Function
572       '      End If
573       '   End If
574       '
575       '   If pRecordID = 0 Then
576       '      'if nothing is picked in the active control, exit
577       '      If IsNull(pF.ActiveControl) Then Exit Function
578       '      'set value to look up by what is selected
579       '      pRecordID = pF.ActiveControl
580       '      'clear the choice to find
581       '      If pbClear Then pF.ActiveControl = Null
582       '   End If
583       '
584       '   'make sure form is open
585       '
586       '   'save current record if changes were made
587       '   If pF.Dirty Then pF.Dirty = False
588       '
589       '   'find the first value that matches
590       '   pF.RecordsetClone.FindFirst pKeyFieldname _
591       '      & "= " _
592       '      & pRecordID
593       '
594       '   'if a matching record was found, then move to it
595       '   If Not pF.RecordsetClone.NoMatch Then
596       '      pF.Bookmark = pF.RecordsetClone.Bookmark
597       '      DoEvents
598       '   Else
599       ''~~CL~~ need to test this
600       '      pF.FilterOn = False
601       '      DoEvents
602       '      pF.Requery
603       '      pF.RecordsetClone.FindFirst pKeyFieldname _
604       '         & "= " _
605       '         & pRecordID
606       '      pF.Bookmark = pF.RecordsetClone.Bookmark
607       '   End If
608       '
609       '   If pCtrlName_SetFocus <> "" Then
610       '      'this fails if controlname is not correctly specified
611       '      pF(pCtrlName_SetFocus).SetFocus
612       '   End If
613       '
614       '   FindRecordN = True
615       '
616       'Proc_Exit:
617       '   Exit Function
618       '
619       'Proc_Err:
620       '   MsgBox Err.Description, , _
621       '        "ERROR " & Err.Number & "   FindRecordN"
622       '
623       '   Resume Proc_Exit
624       '
625       '   'if you want to single-step code to find error, CTRL-Break at MsgBox
626       '   'then set this to be the next statement
627       '   Resume
628       '
629       'End Function
630       '
631       '
632       '
633       ''~~~~~~~~~~~~~~~~~~~~~~~~~~ IsLoadedForm
634       'Function IsLoadedForm(pFormname As String) As Boolean
635       '' Crystal (strive4peace)
636       '
637       '   'This function returns  TRUE if the passed form is loaded  FALSE if it is not
638       '   'example useage: call before opening a form
639       '   ' If IsLoadedForm("Formname") Then DoCmd.SelectObject acForm, "Formname"
640       '   IsLoadedForm = False
641       '   '  True if the specified form is open not in Design view
642       '   If CurrentProject.AllForms(pFormname).IsLoaded Then
643       '      If Forms(pFormname).CurrentView <> 0 Then IsLoadedForm = True
644       '   End If
645       '   Exit Function
646       '
647       '   'for Access 97
648       '   IsLoadedForm = False
649       '   Dim i As Integer
650       '   Err.Number = 0
651       '   On Error GoTo Proc_Exit
652       '   For i = 0 To Forms.Count - 1
653       '      If pFormname = Forms(i).Name Then
654       '         IsLoadedForm = True
655       '         Exit Function
656       '      End If
657       '   Next i
658       'Proc_Exit:
659       'End Function
660       '
      Goto Top       Goto mod_local_Anywhere       Goto Index

run_SaveAttachmentsToFiles (20)

661     
662     
663      Sub run_SaveAttachmentsToFiles() 
664       '130117, 913
665         Dim sTablename As String _ 
666         , sFieldName_Att As String _ 
667         , sFieldName_ID As String _ 
668         , sPath As String _ 
669         , nTID As Long 
670     
671         sTablename = "COMPLETED PROJECTS" 
672         sFieldName_Att = "Attachments" 
673         sFieldName_ID = "ID" 
674       '   sPath
675         nTID = 399 
676     
677         Custom_SetDefaultProperties 
678     
679         SaveAttachmentsToFiles sTablename, sFieldName_Att, sFieldName_ID, nTID 
680      End Sub 
      Goto Top       Goto mod_local_Anywhere       Goto Index

SaveAttachmentsToFiles (200)

681     
682      Sub SaveAttachmentsToFiles( _ 
683         ByVal psTablename As String _ 
684         , ByVal psFld_Attachment As String _ 
685         , ByVal psFld_ID As String _ 
686         , ByVal pnTID As Long _ 
687         , Optional ByVal psPathAttachments As String = "" _ 
688         ) 
689          'USES
690          '  local_PathAtt
691     
692       '130117 Crystal strive4peace, ...130913
693          'PARAMETERS
694          ' psTableName = name of table with attachment field
695          ' psFld_Attachment = name of attachment field
696          ' psFld_ID = name of PK
697          ' psPathAttachments - optional. If not specified, written to c:\CurrentDbPath\Attachments or value of :
698          '  local_PathAtts
699          '   WRITE CHILD RECORDS
700          '   assumption: FK = psFld_ID (same as parent table) if sFieldNameChild_ID not specified
701     
702          On Error GoTo Proc_Err 
703     
704          Dim db As DAO.Database _ 
705            , rs As DAO.Recordset _ 
706            , rsFilename As DAO.Recordset _ 
707            , rs2 As DAO.Recordset2 _ 
708            , fld2 As DAO.Field2 
709     
710         Dim sPathFile As String _ 
711            , sFilename As String _ 
712            , sFileExtension As String _ 
713            , iPos As Integer _ 
714            , nRecordID As Long _ 
715            , nAttLinkID As Long _ 
716            , nNumFilesCreated As Long _ 
717            , sSQL As String 
718     
719         nNumFilesCreated = 0 
720     
721         If psPathAttachments = "" Then 
722            psPathAttachments = Get_Property("local_PathAtt") 
723            If Not Len(Trim(psPathAttachments)) > 0 Then 
724               psPathAttachments = CurrentProject.Path & "\Attachments\" 
725               Call Set_Property("local_PathAtt", psPathAttachments) 
726            End If 
727         Else 
728            If Right(psPathAttachments, 1) <> "\" Then psPathAttachments = psPathAttachments & "\" 
729            Call Set_Property("local_PathAtt", psPathAttachments) 
730         End If 
731     
732         If Dir(psPathAttachments, vbDirectory) = "" Then 
733            MkDir psPathAttachments 
734            DoEvents 
735         End If 
736     
737         Set db = CurrentDb 
738         Set rs = db.OpenRecordset(psTablename, dbOpenDynaset) 
739     
740         Set rsFilename = db.OpenRecordset("c_AttLinks", dbOpenDynaset) 
741     
742         Do While Not rs.EOF 
743            nRecordID = rs(psFld_ID).Value 
744     
745            Set rs2 = rs.Fields(psFld_Attachment).Value 
746     
747            nAttLinkID = -99 
748     
749     
750            Do While Not rs2.EOF 
751     
752               sFilename = rs2.Fields("FileName").Value 
753     
754                'see if fiilename is already in attachment directory
755               With rsFilename 
756                  .FindFirst "AttLink=""" & sFilename & """" 
757                  If Not .NoMatch Then 
758                     If MsgBox(sFilename & " is already in the Attachments Directory" _ 
759                           & vbCrLf & vbCrLf & "YES = Use the existing attachment for record " & nRecordID _ 
760                           & vbCrLf & " No = make a new filename for the attachment" _ 
761                           , vbYesNoCancel, "Is Same File  linked to another record") = vbYes Then 
762                        nAttLinkID = !AttLinkID 
763                     Else 
764                         'constuct different filename
765                        iPos = InStrRev(sFilename, ".") 
766     
767                        sFileExtension = Mid(sFilename, iPos) 
768                        sFilename = Left(sFilename, iPos - 1) 
769     
770                        sFilename = sFilename & "_" & psTablename & "_" & nRecordID & sFileExtension 
771     
772                        sPathFile = psPathAttachments & sFilename 
773     
774                        If Len(Dir(sPathFile)) > 0 Then 
775                            ' set attribute to Normal in case it is ReadOnly
776                            ' VBA.SetAttr sPathFile, vbNormal
777     
778                           If MsgBox("You already have this file attached -- do you want to replace it?" _ 
779                                 , vbYesNo, "Replace attachment for record " & nRecordID & "?") <> vbYes Then 
780                              GoTo NextAttachment 
781                           End If 
782     
783                            'could compare file sizes, modification dates, ...
784                            '-- this may not be what you want to do ... maybe rename: x_ filename
785                           Kill sPathFile 
786                           DoEvents 
787                           DoEvents 
788                           DoEvents 
789                        End If 
790                     End If 
791                  Else 
792                      'file is not in Attachments directory yet
793                     iPos = InStrRev(sFilename, ".") 
794                     sFileExtension = Mid(sFilename, iPos) 
795                     sPathFile = psPathAttachments & sFilename 
796                  End If 
797     
798                  If nAttLinkID = -99 Then 
799     
800     
801                     .AddNew 
802                     !AttLink = sFilename 
803                     !AttExt = sFileExtension 
804                     Select Case sFileExtension 
805                     Case ".jpg", "png", ".bmp" 
806                        !AttTypID = 2   'image file 
807                     Case Else 
808                        !AttTypID = 1   'file 
809                     End Select 
810                     .Update 
811                     .Bookmark = .LastModified 
812                     nAttLinkID = !AttLinkID 
813                  End If 
814               End With   'rsFilename 
815     
816     
817               Set fld2 = rs2.Fields("FileData") 
818               fld2.SaveToFile sPathFile 
819               nNumFilesCreated = nNumFilesCreated + 1 
820     
821               sSQL = "INSERT INTO c_Attachments " _ 
822                  & "(TID, RecordID, AttLinkID, AttName)" _ 
823                  & " SELECT " & pnTID _ 
824                  & ", " & nRecordID _ 
825                  & ", " & nAttLinkID _ 
826                  & ", """ & sFilename & """" _ 
827                  & ";" 
828     
829               With db 
830                  Debug.Print sSQL 
831                 .Execute sSQL 
832                 Debug.Print "------------ " & .RecordsAffected 
833                 If Not .RecordsAffected > 0 Then 
834                    If MsgBox("Error creating Attachment Record for " _ 
835                       & sPathFile, vbOKCancel, "Error -- continue anyway") = vbCancel Then 
836                          GoTo Proc_Exit 
837                    End If 
838                 End If 
839               End With 
840     
841      NextAttachment: 
842               rs2.MoveNext 
843            Loop   'rs2 
844            rs2.Close 
845     
846            rs.MoveNext 
847         Loop   'rs 
848     
849         MsgBox "Created " & nNumFilesCreated & " Files from Attachments" _ 
850            , , "Done" 
851     
852      Proc_Exit: 
853         On Error Resume Next 
854          'release object variables
855         Set fld2 = Nothing 
856         If Not rs Is Nothing Then 
857            rs.Close 
858            Set rs = Nothing 
859         End If 
860         If Not rsFilename Is Nothing Then 
861            rsFilename.Close 
862            Set rsFilename = Nothing 
863         End If 
864         If Not rs2 Is Nothing Then 
865            rs2.Close 
866            Set rs2 = Nothing 
867         End If 
868         Set db = Nothing 
869         Exit Sub 
870     
871      Proc_Err: 
872         MsgBox Err.Description, , _ 
873              "ERROR " & Err.Number _ 
874              & "   SaveAttachmentsToFiles" 
875     
876         Resume Proc_Exit 
877         Resume 
878     
879      End Sub 
880     
      Goto Top       Goto mod_local_Anywhere       Goto Index

mod_local_Contacts (463)

PROCEDURES       Goto Top       Goto mod_local_Contacts       Goto Modules       Goto Index
  1. Declaration Lines (2)
  2. DeleteRecords (68)
  3. GetAddressFromForm (22)
  4. GetAddressShort (18)
  5. GetAge (13)
  6. GetAgeYMD (26)
  7. GetBirthdayNext (26)
  8. GetBirthdayThisYr (16)
  9. GetCategoryOrder (45)
  10. GetFullName (95)
  11. PutTextOnClipboard (132)

Declaration Lines (2)

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

GetFullName (95)

3       
4         'GetFullName(MainName,NameA,NameB,NickName,Sufx, "FA",IsActiv)
5         'GetFullName(c.MainName,c.NameA,c.NameB,c.NickName,c.Sufx, "FA",c.IsActiv, c_.MainName)
6         'GetFullName("Smith","Joe","Q","Jack","Dr", "FA",true)
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, 140629
28        ' ~ Crystal
29        '              * have an awesome day :)
30        '                                                   www.AccessMVP.com/strive4peace
31        ' END LICENSE NOTICE
32        '============================================================
33       Function GetFullName( _ 
34           Optional pLastname As Variant _ 
35          , Optional pFirstname As Variant _ 
36          , Optional pMidname As Variant _ 
37          , Optional pNickName As Variant _ 
38          , Optional pSufx As Variant _ 
39          , Optional pTypeFL As String = "F" _ 
40          , Optional pIsActive As Variant = False _ 
41          , Optional pCompanyName As Variant = "" _ 
42          ) As Variant 
43        '140213, 17, 140421, 140616, 141009
44           'PARAMETERS
45           '  pTypeFL
46           '     F = First Last
47           '     L = Last, First
48           '     A = mark Inactive
49      
50          Dim varName As Variant _ 
51             , varLast As Variant 
52      
53          GetFullName = "" 
54      
55          varName = Null 
56          varLast = Null 
57      
58          If Not (IsMissing(pLastname) Or IsNull(pLastname)) Then 
59             varLast = pLastname 
60          End If 
61          If Not (IsMissing(pSufx) Or IsNull(pSufx)) Then 
62             varLast = varLast & ", " & pSufx 
63          End If 
64      
65          If Not (IsMissing(pFirstname) Or IsNull(pFirstname)) Then 
66             varName = pFirstname 
67          End If 
68          If Not (IsMissing(pNickName) Or IsNull(pNickName)) Then 
69             varName = varName & " (" + pNickName + ")" 
70          End If 
71          If Not (IsMissing(pMidname) Or IsNull(pMidname)) Then 
72             varName = varName & (" " + pMidname + " ") 
73          End If 
74      
75          If InStr(pTypeFL, "F") > 0 Then 
76             varName = varName _ 
77                  & (" " + varLast) 
78          Else 
79             varName = varLast _ 
80                  & (", " + varName) 
81          End If 
82      
83          varName = Trim(Nz(varName, "")) 
84      
85          If Len(Nz(pCompanyName, "")) > 0 Then 
86             varName = varName & " - " & pCompanyName 
87          End If 
88           'Active
89          If Len(Trim(Nz(varName))) > 0 Then 
90             If InStr(pTypeFL, "A") > 0 _ 
91                And Nz(pIsActive, False) <> True Then 
92                varName = varName & " (Inactive)" 
93             End If 
94          End If 
95      
96          GetFullName = varName 
97       End Function 
      Goto Top       Goto mod_local_Contacts       Goto Index

GetAddressFromForm (22)

98      
99       Public Function GetAddressFromForm( _ 
100         pF As Form _ 
101         , Optional psDelimiter As String = ", " _ 
102         ) As String 
103       '141006
104         Dim sText As String 
105     
106         With pF 
107            sText = Trim((.Addr1 + psDelimiter) _ 
108               & (.Addr2 + psDelimiter) _ 
109               & (.City + ", ") & .St & "  " _ 
110               & .Zip & ("-" + .Zip2) _ 
111               & psDelimiter & "   " & .Ctry) 
112         End With   'pF 
113         If Right(sText, Len(psDelimiter)) = psDelimiter Then 
114            sText = Trim(Left(sText, Len(sText) - Len(psDelimiter))) 
115         End If 
116     
117         GetAddressFromForm = sText 
118     
119      End Function 
      Goto Top       Goto mod_local_Contacts       Goto Index

GetAddressShort (18)

120     
121      Public Function GetAddressShort( _ 
122         pF As Form _ 
123         ) As String 
124       '141006
125         Dim sText As String 
126     
127         With pF 
128            sText = Trim( _ 
129                (", " + .City) & (", " + .St) & (", " + .Zip) & (", " + .Ctry)) 
130         End With   'pF 
131         If Len(sText) > 0 Then 
132            sText = Trim(Mid(sText, 3)) 
133         End If 
134     
135         GetAddressShort = sText 
136     
137      End Function 
      Goto Top       Goto mod_local_Contacts       Goto Index

PutTextOnClipboard (132)

138     
139     
140      Public Function PutTextOnClipboard( _ 
141         pF As Form _ 
142         , pWhat_APEWL As String _ 
143         ) As String 
144       '141006
145          'CALLS
146          '  ClipBoard_SetText
147          '
148          'REFERENCES
149          '  controls on the calling forms, specified by pWhat_APEWL
150          '
151         On Error GoTo Proc_Err 
152     
153         PutTextOnClipboard = False 
154     
155         Dim sTitle As String _ 
156            , sText As String _ 
157            , nRecordID As Long _ 
158            , sSQL As String _ 
159            , nNum As Long 
160     
161         Dim db As DAO.Database _ 
162            , rs As DAO.Recordset 
163     
164         With pF 
165             If .Dirty Then .Dirty = False 
166            If .NewRecord Then 
167               MsgBox "You are not on a current record", , "Cannot copy" 
168               Exit Function 
169            End If 
170     
171            Select Case Left(pWhat_APEWL, 1) 
172            Case "A"   'Address 
173               sTitle = "Address" 
174               If IsSubform(pF) Then 
175                  sText = .Parent.ContactName + vbCrLf 
176               Else 
177                  sText = "" 
178               End If 
179     
180               sText = Trim(sText & GetAddressFromForm(pF, vbCrLf)) 
181     
182       '         sText = Trim(sText _
183       '            & (.Addr1 + vbCrLf) _
184       '            & (.Addr2 + vbCrLf) _
185       '            & (.City + ", ") & .St & "  " _
186       '            & .Zip & ("-" + .Zip2) _
187       '            & vbCrLf & "   " & .Ctry)
188     
189            Case "P"   'Phone 
190               sTitle = "Phone number" 
191               sText = (.Parent.ContactName + vbCrLf) _ 
192                  & Nz(.Phone, "No " & sTitle) _ 
193                  & (" ext. " + .phoExt) 
194     
195            Case "E"   'Email Address 
196               sTitle = "Email Address" 
197               sText = (.Parent.ContactName + vbCrLf) _ 
198                  & Nz(.eAdr, "No " & sTitle) 
199     
200            Case "W"   'Website 
201               sTitle = "Website" 
202               sText = (.Parent.ContactName + vbCrLf) _ 
203                  & Nz(.URL, "No URL for " & sTitle) 
204     
205       '      Case "M" 'Members of what lists
206       '         sTitle = "Website"
207       '         sText = (.Parent.ContactName + vbCrLf) _
208       '            & Nz(.URL, "No URL for " & sTitle)
209     
210            Case "L"   'List 
211               sTitle = "List Name and Members" 
212               sText = Nz(.ListName, "No " & sTitle) 
213               nRecordID = .ListID 
214     
215                'get list members
216               Set db = CurrentDb 
217               nRecordID = .ListID 
218               sSQL = "SELECT qC.ContactAC " _ 
219                  & " FROM c_ListMbr AS L " _ 
220                  & " INNER JOIN qContact AS qC  " _ 
221                  & " ON L.CID = qC.CID " _ 
222                  & " WHERE (L.ListID = " & nRecordID & ") " _ 
223                  & " ORDER BY qC.NameA, qC.MainName;" 
224     
225               Set rs = db.OpenRecordset(sSQL, dbOpenSnapshot) 
226     
227               With rs 
228                  .MoveLast 
229                  nNum = .RecordCount 
230                  sText = sText & " (" & Format(nNum, "#,##0") & " members)" & vbCrLf 
231                  .MoveFirst 
232                  Do While Not .EOF 
233                     sText = sText & Space(5) & "- " & !ContactAC & vbCrLf 
234                     .MoveNext 
235                  Loop 
236                  .Close 
237               End With 
238            End Select 
239         End With 
240     
241         Set rs = Nothing 
242     
243         If Len(Trim(sText)) > 0 Then 
244     
245            Call ClipBoard_SetText(sText) 
246            MsgBox sTitle & " copied to Clipboard.  You may now Paste", , "Done" 
247            PutTextOnClipboard = True 
248         Else 
249            MsgBox "Nothing to Copy", , "Cannot copy" 
250         End If 
251     
252     
253      Proc_Exit: 
254         On Error Resume Next 
255         If Not rs Is Nothing Then 
256            rs.Close 
257            Set rs = Nothing 
258         End If 
259         If Not db Is Nothing Then Set db = Nothing 
260         Exit Function 
261     
262      Proc_Err: 
263         MsgBox Err.Description, , _ 
264              "ERROR " & Err.Number _ 
265              & "   PutTextOnClipboard" 
266     
267         Resume Proc_Exit 
268         Resume 
269      End Function 
      Goto Top       Goto mod_local_Contacts       Goto Index

GetCategoryOrder (45)

270     
271      Public Function GetCategoryOrder(pCID As Long, pCCatID As Long) As Long 
272       '140615
273         On Error GoTo Proc_Err 
274         Dim db As DAO.Database _ 
275            , rs As DAO.Recordset 
276     
277         Dim sSQL As String 
278     
279         GetCategoryOrder = 99999 
280     
281         If pCID = 0 Then 
282            pCID = Get_Property("local_CID") 
283         End If 
284     
285         sSQL = "SELECT clng(nz(cCatc.OrdrCCat, 900 + asc(left(ucase(cCategory),1)))) as CatOrder " _ 
286            & " FROM c_CtcCat as cCatc " _ 
287            & " WHERE CID = " & pCID _ 
288            & " AND cCatID = " & pCCatID _ 
289            & ";" 
290         Set db = CurrentDb 
291         Set rs = db.OpenRecordset(sSQL, dbOpenSnapshot) 
292      Debug.Print sSQL 
293      Stop 
294         With rs 
295            If Not .EOF Then 
296               GetCategoryOrder = !CatOrder 
297            Else 
298               GetCategoryOrder = 99999 
299             End If 
300            .Close 
301         End With 
302         Set rs = Nothing 
303     
304      Proc_Exit: 
305         On Error Resume Next 
306         If Not rs Is Nothing Then 
307            rs.Close 
308            Set rs = Nothing 
309         End If 
310         Set db = Nothing 
311      Proc_Err: 
312         Resume Proc_Exit 
313     
314      End Function 
      Goto Top       Goto mod_local_Contacts       Goto Index

DeleteRecords (68)

315     
316      Function DeleteRecords() As Long 
317       '141005
318         On Error GoTo Proc_Err 
319     
320         If MsgBox("Warning! this will delete data in your tables." _ 
321            & vbCrLf & vbCrLf & "Do you want to continue?" _ 
322            , vbYesNo + vbDefaultButton2 _ 
323            , "DELETE DATA?") <> vbYes Then Exit Function 
324     
325         Dim sSQL As String _ 
326            , nNum As Long _ 
327            , nSumNum As Long _ 
328            , nTables As Long 
329     
330         Dim db As DAO.Database _ 
331            , rs As DAO.Recordset 
332     
333         sSQL = "SELECT Tbl.Tbl, Tbl.TAlias " _ 
334            & " FROM c_Tables AS Tbl" _ 
335            & " WHERE (Tbl.OrdrDel > 0) " _ 
336            & " ORDER BY Tbl.OrdrDel, Tbl.Tbl;" 
337     
338         Set db = CurrentDb 
339         Set rs = db.OpenRecordset(sSQL, dbOpenSnapshot) 
340     
341         nSumNum = 0 
342         With rs 
343            Do While Not .EOF 
344               sSQL = "DELETE " & !TAlias & ".*" _ 
345                  & " FROM [" & !Tbl & "];" 
346               nNum = rSql(sSQL) 
347               If nNum > 0 Then 
348                  nSumNum = nSumNum + nNum 
349               End If 
350               .MoveNext 
351            Loop 
352            nTables = .RecordCount 
353            .Close 
354     
355         End With 
356         Set rs = Nothing 
357     
358         MsgBox "DELETED " & Format(nSumNum, "#,##0") & " records" _ 
359            & vbCrLf & " from " & Format(nTables, "#,##0") & " Tables" _ 
360            & vbCrLf & vbCrLf & "Be sure to Compact/Repair the Back-End" _ 
361            , , "Done" 
362     
363         DeleteRecords = nSumNum 
364     
365      Proc_Exit: 
366         On Error Resume Next 
367          'release object variables
368         If Not rs Is Nothing Then 
369            rs.Close 
370            Set rs = Nothing 
371         End If 
372         If Not db Is Nothing Then Set db = Nothing 
373         Exit Function 
374     
375      Proc_Err: 
376         MsgBox Err.Description, , _ 
377              "ERROR " & Err.Number _ 
378              & "   DeleteRecords" 
379     
380         Resume Proc_Exit 
381         Resume 
382      End Function 
      Goto Top       Goto mod_local_Contacts       Goto Index

GetBirthdayThisYr (16)

383     
384     
385      Function GetBirthdayThisYr(pDOB As Date _ 
386         , Optional pCurrentDate As Date _ 
387         ) As Date 
388       ' Crystal (strive4peace)
389         If IsMissing(pCurrentDate) Then 
390            pCurrentDate = Date 
391         End If 
392     
393         GetBirthdayThisYr = DateSerial( _ 
394            Year(pCurrentDate) _ 
395            , Month(pDOB) _ 
396            , Day(pDOB)) 
397     
398      End Function 
      Goto Top       Goto mod_local_Contacts       Goto Index

GetBirthdayNext (26)

399     
400      Function GetBirthdayNext(pDOB As Date _ 
401            , Optional pCurrentDate As Date _ 
402            ) As Variant 
403       ' Crystal (strive4peace) 141006
404     
405         Dim nDate As Date 
406     
407         GetBirthdayNext = Null 
408     
409         If IsMissing(pCurrentDate) Then 
410            pCurrentDate = Date 
411         End If 
412     
413         nDate = DateSerial( _ 
414               Year(pCurrentDate) _ 
415               , Month(pDOB) _ 
416               , Day(pDOB)) 
417     
418         If nDate < pCurrentDate Then 
419            nDate = DateAdd("yyyy", 1, nDate) 
420     
421            GetBirthdayNext = nDate 
422         End If 
423     
424      End Function 
      Goto Top       Goto mod_local_Contacts       Goto Index

GetAgeYMD (26)

425     
426      Public Function GetAgeYMD(piDOByr As Variant _ 
427         , piDOBmo As Variant _ 
428         , piDOBda As Variant _ 
429         , Optional pCurrentDate As Date _ 
430         ) As Variant 
431     
432         Dim nDOB As Date 
433     
434         If pCurrentDate = 0 Then 
435            pCurrentDate = Date 
436         End If 
437     
438         GetAgeYMD = Null 
439     
440         If Nz(piDOByr, 0) = 0 _ 
441            Or Nz(piDOBmo, 0) = 0 _ 
442            Or Nz(piDOBda, 0) = 0 Then Exit Function 
443     
444         nDOB = DateSerial(piDOByr, piDOBmo, piDOBda) 
445     
446          'optionally subtract 1: True = -1
447         GetAgeYMD = DateDiff("yyyy", nDOB, pCurrentDate) _ 
448            + (pCurrentDate < DateSerial(Year(pCurrentDate), piDOBmo, piDOBda)) 
449     
450      End Function 
      Goto Top       Goto mod_local_Contacts       Goto Index

GetAge (13)

451     
452      Function GetAge(pDOB As Date, Optional pDate As Date = 0) As Integer 
453         GetAge = 0 
454         If Nz(pDOB, 0) = 0 Then Exit Function 
455         If pDate = 0 Then pDate = Date 
456     
457          'optionally subtract 1: True = -1
458         GetAge = DateDiff("yyyy", pDOB, pDate) _ 
459            + (pDate < DateSerial(Year(pDate), Month(pDOB), Day(pDOB))) 
460      End Function 
461     
462     
463     
      Goto Top       Goto mod_local_Contacts       Goto Index

mod_local_ui (266)

PROCEDURES       Goto Top       Goto mod_local_ui       Goto Modules       Goto Index
  1. Declaration Lines (33)
  2. NotInList_Aircraft_fromPrj (67)
  3. SetCriteria4AC (166)

Declaration Lines (33)

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       Public gvCrit_4AC As Variant _ 
31          , gvCrit As Variant _ 
32          , gvFriendly As Variant 
33       Dim msValue As String 
      Goto Top       Goto mod_local_ui       Goto Index

SetCriteria4AC (166)

34      
35       Public Function SetCriteria4AC( _ 
36          pF As Form _ 
37          , psField As String _ 
38          , Optional psCtrlPrefix As String = "" _ 
39          , Optional pBooUseAircrafts As Boolean = True _ 
40          , Optional pBooIgnoreAirline As Boolean = False _ 
41          ) 
42        '131015, 1022, 1023
43      
44           'PARAMETERS
45           '  psField -- field that is getting criteria
46           '     MakeID
47           '     ModelID
48           '     FleetID
49           '     AirlineID
50           '     "" -- consider all (don't ignore any fields)
51      
52          Dim sPattern As String _ 
53             , sFriendly As String _ 
54             , sCrit As String _ 
55             , nRecordID As Long _ 
56             , vCritACtemp As Variant _ 
57             , vCritMMS As Variant 
58      
59          gvCrit_4AC = Null   'criteria for the aircrafts table 
60          gvCrit = Null   'criteria for control that needs it 
61          vCritACtemp = Null   'criteria for control that needs it using a subquery with Aircrafts table as ACtemp 
62          vCritMMS = Null   'criteria for control that needs it using a subquery with usys_MakeModelSeries as MMS 
63          gvFriendly = Null   'friendly criteria 
64      
65          If Not pBooIgnoreAirline Then 
66                With pF(psCtrlPrefix & "AirlineID") 
67                If Not IsNull(.Column(0)) And Not IsNull(.Value) Then 
68                   nRecordID = .Value 
69                   sFriendly = .Column(1) 
70                   gvFriendly = (gvFriendly + ", ") & sFriendly 
71      
72                   gvCrit_4AC = (gvCrit_4AC + " AND ") _ 
73                      & "AC.AirlineID = " & nRecordID 
74      
75                    'Airline criteria for other controls
76                   If psField <> "AirlineID" Then 
77                      vCritACtemp = (vCritACtemp + " AND ") _ 
78                                  & "ACtemp.AirlineID = " & nRecordID 
79                       'no gvCrit ... criteria needs a subquery
80                   End If 'psField <> "AirlineID" 
81                End If   'has value 
82             End With   'Mach_AirlineID 
83          End If 
84      
85          With pF(psCtrlPrefix & "MakeID") 
86             If Not IsNull(.Column(0)) And Not IsNull(.Value) Then 
87                nRecordID = .Value 
88                sFriendly = .Column(1) 
89                gvFriendly = (gvFriendly + ", ") & sFriendly 
90      
91                gvCrit_4AC = (gvCrit_4AC + " AND ") _ 
92                    & "AC.MakeID = " & nRecordID 
93      
94                 'Make criteria for other controls
95                If psField <> "MakeID" Then 
96                   Select Case psField 
97      
98                   Case "AirlineID" 
99                      vCritACtemp = (vCritACtemp + " AND ") _ 
100                                 & "ACtemp.MakeID = " & nRecordID 
101     
102                  Case Else ' ModelID, FleetID, "" 
103                     gvCrit = (gvCrit + " AND ") _ 
104                        & "Mdl.MakeID = " & nRecordID 
105     
106                  End Select 
107               End If 'psField <> "MakeID" 
108            End If   'has value 
109         End With   'Mach_MakeID 
110     
111     
112         With pF(psCtrlPrefix & "ModelID") 
113            If Not IsNull(.Column(0)) And Not IsNull(.Value) Then 
114               nRecordID = .Value 
115               sFriendly = .Column(1) 
116               gvFriendly = (gvFriendly + ", ") & sFriendly 
117     
118               gvCrit_4AC = (gvCrit_4AC + " AND ") _ 
119                   & "AC.ModelID = " & nRecordID 
120     
121                'Model criteria for other controls
122               If psField <> "ModelID" Then 
123     
124                  Select Case psField 
125                  Case "AirlineID", "MakeID" 
126                     vCritACtemp = (vCritACtemp + " AND ") _ 
127                                 & "ACtemp.ModelID= " & nRecordID 
128     
129                  Case Else '"FleetID" 
130                     gvCrit = (gvCrit + " AND ") _ 
131                        & "Mdl.ModelID = " & nRecordID 
132     
133                  End Select 
134               End If 'psField <> "ModelID" 
135            End If   'has value 
136         End With   'Mach_ModelID 
137     
138         With pF(psCtrlPrefix & "FleetID") 
139            If Not IsNull(.Column(0)) And Not IsNull(.Value) Then   'make sure value is showing 
140               nRecordID = .Value 
141               sFriendly = .Column(1) 
142               gvFriendly = (gvFriendly + ", ") & sFriendly 
143     
144               gvCrit_4AC = (gvCrit_4AC + " AND ") _ 
145                   & "AC.FleetID = " & nRecordID 
146     
147                'Fleet criteria for other controls
148               If psField <> "FleetID" Then 
149                   ' "AirlineID", "MakeID", "ModelID"
150                  If pBooUseAircrafts Then 
151                     vCritACtemp = (vCritACtemp + " AND ") _ 
152                                 & "ACtemp.FleetID= " & nRecordID 
153                  Else 
154                     vCritMMS = (vCritMMS + " AND ") _ 
155                                   & "MMS.FleetID= " & nRecordID 
156                  End If 
157               End If 'psField <> "FleetID" 
158     
159            End If   'has value 
160         End With   'Mach_FleetID 
161     
162         If pBooUseAircrafts = True Then 
163            With pF.Mach_Reg_pattern 
164               If Not IsNull(.Value) Then 
165                  sPattern = "*" & .Value & "*" 
166                  gvFriendly = (gvFriendly + ", ") & sPattern 
167     
168                   'registration pattern criteria
169                  sCrit = "(AC.RegNum Like '" & sPattern & "' " _ 
170                     & " OR AC.RegPart Like '" & sPattern & "' " _ 
171                     & " OR AC.RegPrev Like '" & sPattern & "' " _ 
172                     & " OR cstr(nz(AC.TailNo,0)) Like '" & sPattern & "') " 
173     
174                  gvCrit_4AC = (gvCrit_4AC + " AND ") & sCrit 
175                   ' AirlineID, MakeID, ModelID, FleetID, ""
176                  vCritACtemp = (vCritACtemp + " AND ") _ 
177                                 & Replace(sCrit, "AC.", "ACtemp.") 
178               End If 
179            End With 
180            If Not IsNull(vCritACtemp) Then 
181                  gvCrit = (gvCrit + " AND ") _ 
182                                 & psField & " IN (" _ 
183                                 & " SELECT ACtemp." & psField _ 
184                                 & " FROM Aircrafts ACtemp " _ 
185                                 & " WHERE " & vCritACtemp _ 
186                                 & ")" 
187            End If 
188         Else   'not Aircrafts form 
189            If Not IsNull(vCritMMS) Then 
190                  gvCrit = (gvCrit + " AND ") _ 
191                                 & psField & " IN (" _ 
192                                 & " SELECT MMS." & psField _ 
193                                 & " FROM usys_MakeModelSeries MMS  " _ 
194                                 & " WHERE " & vCritMMS _ 
195                                 & ")" 
196            End If 
197         End If 
198     
199      End Function 
      Goto Top       Goto mod_local_ui       Goto Index

NotInList_Aircraft_fromPrj (67)

200     
201      Public Function NotInList_Aircraft_fromPrj( _ 
202         psTable As String _ 
203         , pFldText As String _ 
204         , pNewData As Variant _ 
205         , pnProjectID As Long _ 
206         , Optional sDeli As String = "'" _ 
207         ) As Boolean 
208       '...131024
209           ' crystal (strive4peace)
210     
211          'assumption:
212          'the combobox first column is hidden
213          'and is the Autonumber record ID  for the source table
214     
215          'set up Error Handler
216         On Error GoTo Proc_Err 
217     
218         NotInList_Aircraft_fromPrj = False 
219     
220         Dim sSQL As String _ 
221            , sMsg As String 
222     
223         pNewData = UCase(pNewData) 
224     
225          ' Display message box asking if user wants to add a new item
226         sMsg = "Do you want to add " & sDeli & pNewData & sDeli & "? " _ 
227     
228         If MsgBox(sMsg, vbYesNo, "Add New Data") = vbNo Then 
229            Exit Function 
230         End If 
231     
232         If pnProjectID = -99 Then 
233     
234          sSQL = "INSERT INTO Aircrafts (" & pFldText & ") " _ 
235              & " SELECT " _ 
236              & sDeli & pNewData & sDeli & ";" 
237     
238         Else 
239          sSQL = "INSERT INTO AirCrafts ( AirlineID, MakeID, ModelID, FleetID, " & pFldText & ") " _ 
240            & " SELECT Projectz.AirlineID" _ 
241              & ", Projectz.MakeID" _ 
242              & ", Projectz.ModelID" _ 
243              & ", Projectz.FleetID" _ 
244              & ", " & sDeli & pNewData & sDeli _ 
245              & " From Projectz" _ 
246              & " WHERE (Projectz.ProjectID=" & pnProjectID & ");" 
247         End If 
248     
249         NotInList_Aircraft_fromPrj = (rSql(sSQL) > 0) 
250     
251      Proc_Exit: 
252         On Error Resume Next 
253         Exit Function 
254     
255      Proc_Err: 
256         MsgBox Err.Description, , _ 
257              "ERROR " & Err.Number _ 
258              & "   NotInList_Aircraft_fromPrj" 
259     
260         Resume Proc_Exit 
261     
262          'if you want to single-step code to find error, CTRL-Break at MsgBox
263          'then set this to be the next statement
264         Resume 
265      End Function 
266     
      Goto Top       Goto mod_local_ui       Goto Index

mod_PlaySound (33)

PROCEDURES       Goto Top       Goto mod_PlaySound       Goto Modules       Goto Index
  1. API_PlaySound (11)
  2. Declaration Lines (11)
  3. PlayWelcome (11)

Declaration Lines (11)

1        Option Compare Database 
2        Option Explicit 
3         '
4         ' from Chip Pearson
5         ' http://www.cpearson.com/excel/PlaySound.aspx
6         '
7        Public Declare Function sndPlaySound32 _ 
8            Lib "winmm.dll" _ 
9            Alias "sndPlaySoundA" ( _ 
10               ByVal lpszSoundName As String, _ 
11               ByVal uFlags As Long) As Long 
      Goto Top       Goto mod_PlaySound       Goto Index

API_PlaySound (11)

12      
13        'SND_SYNC = &H0
14        'SND_ASYNC = &H1
15        'SND_NODEFAULT = &H2
16        'SND_MEMORY = &H4
17        'SND_LOOP = &H8
18        'SND_NOSTOP = &H10
19      
20       Public Sub API_PlaySound(psFilename As String) 
21          Call sndPlaySound32(psFilename, &H2 + &H1)   'SND_NODEFAULT + SND_ASYNC 
22       End Sub 
      Goto Top       Goto mod_PlaySound       Goto Index

PlayWelcome (11)

23      
24       Public Sub PlayWelcome() 
25          Dim sFile As String _ 
26             , sPathFile As String 
27      
28          sPathFile = CurrentProject.Path & "\WelcomeToContacts.wav" 
29          If Len(Dir(sPathFile)) > 0 Then 
30             Call sndPlaySound32(sPathFile, &H2 + &H1)   'SND_NODEFAULT + SND_ASYNC 
31          End If 
32      
33       End Sub 
      Goto Top       Goto mod_PlaySound       Goto Index

mod_SaveCSVasExcel (135)

PROCEDURES       Goto Top       Goto mod_SaveCSVasExcel       Goto Modules       Goto Index
  1. Declaration Lines (2)
  2. SaveCSVasExcel (42)
  3. SaveCSVasExcel_WBobject (50)
  4. testSaveCSVasExcel (41)

Declaration Lines (2)

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

testSaveCSVasExcel (41)

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       Sub testSaveCSVasExcel() 
30        '140507
31          Dim sgTimer As Single _ 
32             , sgDiff As Single 
33      
34          sgTimer = Timer() 
35      
36          Debug.Print sgTimer; 
37      
38          Call SaveCSVasExcel("F:\Tools_2012\Crystal_Reference_Database\Zips_US.csv") 
39      
40          sgDiff = Timer() - sgTimer 
41          Debug.Print sgDiff 
42      
43       End Sub 
      Goto Top       Goto mod_SaveCSVasExcel       Goto Index

SaveCSVasExcel (42)

44      
45       Public Function SaveCSVasExcel(pFilename As String) As Boolean 
46        '120814 Crystal (strive4peace)
47      
48          On Error GoTo Proc_Err 
49          SaveCSVasExcel = False 
50      
51          Dim xlApp As Object 
52           'Dim xlApp As Excel.Application
53          Set xlApp = CreateObject("Excel.Application") 
54      
55          With xlApp 
56             .Workbooks.Open pFilename 
57           'xlExcel8 = 56 ' --------------------- customize to whatever version you want
58             With .ActiveWorkbook 
59                .SaveAs FileName:= _ 
60                        Replace(pFilename, ".csv", ".xls") _ 
61                        , FileFormat:=56 
62                .Close 
63             End With 
64          End With 
65      
66          SaveCSVasExcel = True 
67      
68       Proc_Exit: 
69          On Error Resume Next 
70      
71          If TypeName(xlApp) <> "Nothing" Then 
72             xlApp.ActiveWorkbook.Close False 
73             Set xlApp = Nothing 
74          End If 
75      
76          Exit Function 
77      
78       Proc_Err: 
79          MsgBox Err.Description _ 
80                 , , "ERROR " & Err.Number & " SaveCSVasExcel" 
81      
82          Resume Proc_Exit 
83          Resume 
84      
85       End Function 
      Goto Top       Goto mod_SaveCSVasExcel       Goto Index

SaveCSVasExcel_WBobject (50)

86      
87       Public Function SaveCSVasExcel_WBobject(pFilename As String) As Boolean 
88        '120814 Crystal (strive4peace)
89      
90          On Error GoTo Proc_Err 
91          SaveCSVasExcel_WBobject = False 
92      
93          Dim xlWb As Object 
94      
95          Dim xlApp As Object 
96           'Dim xlApp As Excel.Application
97          Set xlApp = CreateObject("Excel.Application") 
98      
99          With xlApp 
100            Set xlWb = .Workbooks.Open(pFilename) 
101          'xlExcel8 = 56 ' --------------------- customize to whatever version you want
102            With xlWb 
103               .SaveAs FileName:= _ 
104                       Replace(pFilename, ".csv", ".xls") _ 
105                       , FileFormat:=56 
106               .Close False 
107            End With 
108         End With 
109         Set xlWb = Nothing 
110     
111         SaveCSVasExcel_WBobject = True 
112     
113      Proc_Exit: 
114         On Error Resume Next 
115         If Not xlWb Is Nothing Then 
116            xlWb.Close False 
117            Set xlWb = Nothing 
118         End If 
119         If TypeName(xlApp) <> "Nothing" Then 
120            xlApp.ActiveWorkbook.Close False 
121            Set xlApp = Nothing 
122         End If 
123     
124         Exit Function 
125     
126      Proc_Err: 
127         MsgBox Err.Description _ 
128                , , "ERROR " & Err.Number & " SaveCSVasExcel_WBobject" 
129     
130         Resume Proc_Exit 
131         Resume 
132     
133      End Function 
134     
135     
      Goto Top       Goto mod_SaveCSVasExcel       Goto Index

mod_SubDatasheet (105)

PROCEDURES       Goto Top       Goto mod_SubDatasheet       Goto Modules       Goto Index
  1. Declaration Lines (2)
  2. SetSubDatasheetNone (103)

Declaration Lines (2)

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

SetSubDatasheetNone (103)

3         '=======================================================
4         ' mod_SubDatasheet
5         '============================================================ LICENSE NOTICE -- must not be modified
6         ' This software is licensed to you under CC BY-NC-SA 3.0
7         '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
8         ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
9         '
10        ' You are free to:
11        '    Share — copy and redistribute the material in any medium or format
12        '    Adapt — remix, transform, and build upon the material
13        ' The licensor cannot revoke these freedoms as long as you follow these terms:
14        '    Attribution — You must give appropriate credit, provide a link to the license,
15        '                   and indicate if changes were made.
16        '                   You may do so in any reasonable manner,
17        '                   but not in any way that suggests the licensor endorses you or your use.
18        '    NonCommercial — You may not use the material for commercial purposes.
19        '    ShareAlike — If you remix, transform, or build upon the material,
20        '                 you must distribute your contributions under the same license as the original.
21        '
22        ' many procedures and module names contain author or controbitor names that must be left intact
23        ' if you make changes, add your name, date, and descriptive information to the comments
24        '
25        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629
26        ' ~ Crystal
27        '              * have an awesome day :)
28        '                                                   www.AccessMVP.com/strive4peace
29        ' END LICENSE NOTICE
30        '============================================================
31       Public Sub SetSubDatasheetNone() 
32      
33           'crystal 10-27-06, 130725
34           'strive4peace
35           ' download this code from:
36           '  http://www.rogersaccesslibrary.com/forum/set-subdatasheet-to-none-in-all-tables_topic614.html
37           ' http://www.utteraccess.com/wiki/index.php/SetSubDatasheetNone
38      
39           'based on code written by Allen Browne
40           '      http://allenbrowne.com/bug-09.html
41           '
42           '  click HERE
43           '     press F5 to Run!
44           '     (or choose 'Run, Run Sub/Userform' from the menu)
45           '
46           'set the Subdatasheet property to [None] in all (non-MSys) tables
47           '
48           '~~~~~~~~~~~~~~~~~~
49              'NEEDS reference to Microsoft DAO Library
50              'or
51              'Microsoft Office ##.0 Access Database Engine Object Library
52           '~~~~~~~~~~~~~~~~~~
53      
54          Dim tdf As DAO.TableDef _ 
55             , prop As DAO.Property 
56      
57          Dim nCountDone As Integer _ 
58             , nCountChecked As Integer _ 
59             , mBoo As Boolean _ 
60             , sStr As String 
61      
62           'cheap but it works 
63          On Error Resume Next 
64      
65          nCountDone = 0 
66          nCountChecked = 0 
67          For Each tdf In CurrentDb.TableDefs 
68              'skip Microsoft System tables
69             If Left(tdf.Name, 4) <> "Msys" Then 
70      
71                mBoo = False 
72                nCountChecked = nCountChecked + 1 
73                Err.Number = 0 
74                sStr = tdf.Properties("SubdatasheetName") 
75                If Err.Number > 0 Then 
76      
77                   Set prop = tdf.CreateProperty( _ 
78                      "SubdatasheetName", dbText, "[None]") 
79      
80                   tdf.Properties.Append prop 
81                   mBoo = True 
82                Else 
83                    'thanks, Allen!
84                   If tdf.Properties("SubdatasheetName") <> "[None]" Then 
85                      tdf.Properties("SubdatasheetName") = "[None]" 
86                      mBoo = True 
87                   End If 
88                End If 
89                If mBoo = True Then 
90                   nCountDone = nCountDone + 1 
91                End If 
92             End If 
93          Next tdf 
94      
95          Set prop = Nothing 
96          Set tdf = Nothing 
97      
98          MsgBox nCountChecked & " tables checked" & vbCrLf & vbCrLf _ 
99             & "Reset SubdatasheetName property to [None] in " _ 
100            & nCountDone & " tables" _ 
101            , , "Reset Subdatasheet to None" 
102     
103      End Sub 
104     
105     
      Goto Top       Goto mod_SubDatasheet       Goto Index

mod_TerryKreft_API_Clipboard_Copy_Paste (208)

PROCEDURES       Goto Top       Goto mod_TerryKreft_API_Clipboard_Copy_Paste       Goto Modules       Goto Index
  1. ClipBoard_GetText (30)
  2. ClipBoard_SetText (27)
  3. CopyOlePiccy (43)
  4. Declaration Lines (108)

Declaration Lines (108)

1        hOption Compare Database 
2        Option Explicit 
3       
4         'API: Copy variables/control contents to memory, by Terry Kreft
5         'http://www.mvps.org/access/api/api0049.htm
6         'bas_API_Clipboard_dd_Paste_TerryKreft
7       
8         'API: Copy variables/control contents to memory
9         ' Author (s): Terry Kreft
10      
11        ' To copy a variable's or a control's content to memory,
12        ' you must use API functions.
13        ' Although the built in RunCommand method does have a constant
14        ' which allows you to copy data to clipboard,
15        ' it's heavily dependent on controls on the form.
16        ' You must setFocus to the control and select the text first
17        ' before you can use RunCommand on the selection.
18      
19        ' Here are a few functions which let you copy and paste data to/from clipboard.
20      
21        '*********  Code Start  ************
22        ' This code was originally written by Terry Kreft.
23        ' It is not to be altered or distributed,
24        ' except as part of an application.
25        ' You are free to use it in any application,
26        ' provided the copyright notice is left unchanged.
27        '
28        ' Code Courtesy of
29        ' Terry Kreft
30        '
31       Public Const GHND = &H42 
32       Public Const CF_TEXT = 1 
33       Private Const CF_ANSIONLY = &H400& 
34       Private Const CF_APPLY = &H200& 
35       Private Const CF_BITMAP = 2 
36       Private Const CF_DIB = 8 
37       Private Const CF_DIF = 5 
38       Private Const CF_DSPBITMAP = &H82 
39       Private Const CF_DSPENHMETAFILE = &H8E 
40       Private Const CF_DSPMETAFILEPICT = &H83 
41       Private Const CF_DSPTEXT = &H81 
42       Private Const CF_EFFECTS = &H100& 
43       Private Const CF_ENABLEHOOK = &H8& 
44       Private Const CF_ENABLETEMPLATE = &H10& 
45       Private Const CF_ENABLETEMPLATEHANDLE = &H20& 
46       Private Const CF_ENHMETAFILE = 14 
47       Private Const CF_FIXEDPITCHONLY = &H4000& 
48       Private Const CF_FORCEFONTEXIST = &H10000 
49       Private Const CF_GDIOBJFIRST = &H300 
50       Private Const CF_GDIOBJLAST = &H3FF 
51       Private Const CF_HDROP = 15 
52       Private Const CF_INITTOLOGFONTSTRUCT = &H40& 
53       Private Const CF_LIMITSIZE = &H2000& 
54       Private Const CF_LOCALE = 16 
55       Private Const CF_MAX = 17 
56       Private Const CF_METAFILEPICT = 3 
57       Private Const CF_NOFACESEL = &H80000 
58       Private Const CF_NOSCRIPTSEL = &H800000 
59       Private Const CF_NOSIMULATIONS = &H1000& 
60       Private Const CF_NOSIZESEL = &H200000 
61       Private Const CF_NOSTYLESEL = &H100000 
62       Private Const CF_NOVECTORFONTS = &H800& 
63       Private Const CF_NOOEMFONTS = CF_NOVECTORFONTS 
64       Private Const CF_NOVERTFONTS = &H1000000 
65       Private Const CF_OEMTEXT = 7 
66       Private Const CF_OWNERDISPLAY = &H80 
67       Private Const CF_PALETTE = 9 
68       Private Const CF_PENDATA = 10 
69       Private Const CF_PRINTERFONTS = &H2 
70       Private Const CF_PRIVATEFIRST = &H200 
71       Private Const CF_PRIVATELAST = &H2FF 
72       Private Const CF_RIFF = 11 
73       Private Const CF_SCALABLEONLY = &H20000 
74       Private Const CF_SCREENFONTS = &H1 
75       Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS) 
76       Private Const CF_SCRIPTSONLY = CF_ANSIONLY 
77       Private Const CF_SELECTSCRIPT = &H400000 
78       Private Const CF_SHOWHELP = &H4& 
79       Private Const CF_SYLK = 4 
80       Private Const CF_TIFF = 6 
81       Private Const CF_TTONLY = &H40000 
82       Private Const CF_UNICODETEXT = 13 
83       Private Const CF_USESTYLE = &H80& 
84       Private Const CF_WAVE = 12 
85       Private Const CF_WYSIWYG = &H8000 
86      
87       Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal _ 
88         dwBytes As Long) As Long 
89       Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _ 
90         As Long 
91       Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) _ 
92         As Long 
93       Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _ 
94         ByVal lpString2 As Any) As Long 
95       Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" _ 
96         (ByVal lpString As String) As Long 
97      
98       Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _ 
99         As Long 
100     
101      Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) _ 
102        As Long 
103      Private Declare Function CloseClipboard Lib "user32" () As Long 
104      Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As _ 
105        Long) As Long 
106      Private Declare Function EmptyClipboard Lib "user32" () As Long 
107      Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat _ 
108        As Long, ByVal hMem As Long) As Long 
      Goto Top       Goto mod_TerryKreft_API_Clipboard_Copy_Paste       Goto Index

ClipBoard_SetText (27)

109     
110       'crystal added ByVal 100914
111      Function ClipBoard_SetText(ByVal strCopyString As String) As Boolean 
112        Dim hGlobalMemory As Long 
113        Dim lpGlobalMemory As Long 
114        Dim hClipMemory As Long 
115     
116         ' Allocate moveable global memory.
117         '-------------------------------------------
118        hGlobalMemory = GlobalAlloc(GHND, Len(strCopyString) + 1) 
119     
120         ' Lock the block to get a far pointer
121         ' to this memory.
122        lpGlobalMemory = GlobalLock(hGlobalMemory) 
123     
124         ' Copy the string to this global memory.
125        lpGlobalMemory = lstrcpy(lpGlobalMemory, strCopyString) 
126     
127         ' Unlock the memory and then copy to the clipboard
128        If GlobalUnlock(hGlobalMemory) = 0 Then 
129          If OpenClipboard(0&) <> 0 Then 
130            Call EmptyClipboard 
131            hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) 
132            ClipBoard_SetText = CBool(CloseClipboard) 
133          End If 
134        End If 
135      End Function 
      Goto Top       Goto mod_TerryKreft_API_Clipboard_Copy_Paste       Goto Index

ClipBoard_GetText (30)

136     
137      Function ClipBoard_GetText() As String 
138        Dim hClipMemory As Long 
139        Dim lpClipMemory As Long 
140        Dim strCBText As String 
141        Dim RetVal As Long 
142        Dim lngSize As Long 
143        If OpenClipboard(0&) <> 0 Then 
144           ' Obtain the handle to the global memory
145           ' block that is referencing the text.
146          hClipMemory = GetClipboardData(CF_TEXT) 
147          If hClipMemory <> 0 Then 
148             ' Lock Clipboard memory so we can reference
149             ' the actual data string.
150            lpClipMemory = GlobalLock(hClipMemory) 
151            If lpClipMemory <> 0 Then 
152              lngSize = GlobalSize(lpClipMemory) 
153              strCBText = Space$(lngSize) 
154              RetVal = lstrcpy(strCBText, lpClipMemory) 
155              RetVal = GlobalUnlock(hClipMemory) 
156               ' Peel off the null terminating character.
157              strCBText = Left(strCBText, InStr(1, strCBText, Chr$(0), 0) - 1) 
158            Else 
159              MsgBox "Could not lock memory to copy string from." 
160            End If 
161          End If 
162          Call CloseClipboard 
163        End If 
164        ClipBoard_GetText = strCBText 
165      End Function 
      Goto Top       Goto mod_TerryKreft_API_Clipboard_Copy_Paste       Goto Index

CopyOlePiccy (43)

166     
167      Function CopyOlePiccy(Piccy As Object) 
168        Dim hGlobalMemory As Long, lpGlobalMemory As Long 
169        Dim hClipMemory As Long, X As Long 
170     
171         ' Allocate moveable global memory.
172         '-------------------------------------------
173        hGlobalMemory = GlobalAlloc(GHND, Len(Piccy) + 1) 
174     
175         ' Lock the block to get a far pointer
176         ' to this memory.
177        lpGlobalMemory = GlobalLock(hGlobalMemory) 
178     
179     
180         'Need to copy the object to the memory here
181     
182        lpGlobalMemory = lstrcpy(lpGlobalMemory, Piccy) 
183     
184         ' Unlock the memory.
185        If GlobalUnlock(hGlobalMemory) <> 0 Then 
186          MsgBox "Could not unlock memory location. Copy aborted." 
187          GoTo OutOfHere2 
188        End If 
189     
190         ' Open the Clipboard to copy data to.
191        If OpenClipboard(0&) = 0 Then 
192          MsgBox "Could not open the Clipboard. Copy aborted." 
193          Exit Function 
194        End If 
195     
196         ' Clear the Clipboard.
197        X = EmptyClipboard() 
198     
199         ' Copy the data to the Clipboard.
200        hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) 
201     
202      OutOfHere2: 
203        If CloseClipboard() = 0 Then 
204          MsgBox "Could not close Clipboard." 
205        End If 
206      End Function 
207       '*********  Code End   ************
208     
      Goto Top       Goto mod_TerryKreft_API_Clipboard_Copy_Paste       Goto Index

mod_UI (789)

PROCEDURES       Goto Top       Goto mod_UI       Goto Modules       Goto Index
  1. AskSaveTheChanges (33)
  2. AttachNote (18)
  3. BehaviorEnteringField (6)
  4. DataSheet_ColumnWidth (32)
  5. Declaration Lines (2)
  6. FormBeforeUpdate (74)
  7. GetObjectType (16)
  8. GetResponse_NIL (71)
  9. GetSQL_ORDERBY (70)
  10. GetSQL_WHERE (103)
  11. IsValueUnique (22)
  12. myFormOpenEvent (71)
  13. NotInList_general (96)
  14. OpenShortcuts (5)
  15. PopCalendar (9)
  16. SetControl_RowSource (70)
  17. StripPhoneNonNumeric (17)
  18. ToggleProperCase (13)
  19. TypeID_NIL (61)

Declaration Lines (2)

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

NotInList_general (96)

3         '=======================================================
4         ' mod_UI
5         '============================================================ LICENSE NOTICE -- must not be modified
6         ' This software is licensed to you under CC BY-NC-SA 3.0
7         '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
8         ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
9         '
10        ' You are free to:
11        '    Share — copy and redistribute the material in any medium or format
12        '    Adapt — remix, transform, and build upon the material
13        ' The licensor cannot revoke these freedoms as long as you follow these terms:
14        '    Attribution — You must give appropriate credit, provide a link to the license,
15        '                   and indicate if changes were made.
16        '                   You may do so in any reasonable manner,
17        '                   but not in any way that suggests the licensor endorses you or your use.
18        '    NonCommercial — You may not use the material for commercial purposes.
19        '    ShareAlike — If you remix, transform, or build upon the material,
20        '                 you must distribute your contributions under the same license as the original.
21        '
22        ' many procedures and module names contain author or controbitor names that must be left intact
23        ' if you make changes, add your name, date, and descriptive information to the comments
24        '
25        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629
26        ' ~ Crystal
27        '              * have an awesome day :)
28        '                                                   www.AccessMVP.com/strive4peace
29        ' END LICENSE NOTICE
30        '============================================================
31       Public Function NotInList_general( _ 
32          psTable As String _ 
33          , psField As String _ 
34          , pNewData As Variant _ 
35          , Optional sDeli As String = "'" _ 
36          , Optional pbooCase As String = "" _ 
37          , Optional psField2 As String = "" _ 
38          , Optional pnValue2 As Long = -99 _ 
39          ) As Boolean 
40        '131027, 140103 pbooCase
41            ' crystal (strive4peace)
42      
43           'assumption:
44           'the combobox first column is hidden
45           'and is the Autonumber record ID  for the source table
46      
47           'set up Error Handler
48          On Error GoTo Proc_Err 
49      
50          NotInList_general = False 
51      
52          Dim sSQL As String _ 
53             , sMsg As String 
54      
55          Select Case pbooCase 
56          Case "" 
57          Case "U":  pNewData = UCase(pNewData) 
58          Case "M", "P": pNewData = StrConv(pNewData, vbProperCase) 
59          End Select 
60      
61           ' Display message box asking if user wants to add a new item
62          sMsg = "Do you want to add " & sDeli & pNewData & sDeli & "? " _ 
63      
64          If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "Add New Data") = vbNo Then 
65             Exit Function 
66          End If 
67      
68          If psField2 <> "" And pnValue2 <> -99 Then 
69           sSQL = "INSERT INTO [" & psTable & "] ([" & psField & "] ,[" & psField2 & "]) " _ 
70               & " SELECT " _ 
71               & sDeli & pNewData & sDeli _ 
72               & "," & pnValue2 _ 
73               & ";" 
74          Else 
75           sSQL = "INSERT INTO [" & psTable & "] (" & psField & ") " _ 
76               & " SELECT " _ 
77               & sDeli & pNewData & sDeli & ";" 
78          End If 
79      
80          NotInList_general = (rSql(sSQL) > 0) 
81        '   DoEvents
82      
83      
84       Proc_Exit: 
85          On Error Resume Next 
86          Exit Function 
87      
88       Proc_Err: 
89          MsgBox Err.Description, , _ 
90               "ERROR " & Err.Number _ 
91               & "   NotInList_general" 
92      
93          Resume Proc_Exit 
94      
95           'if you want to single-step code to find error, CTRL-Break at MsgBox
96           'then set this to be the next statement
97          Resume 
98       End Function 
      Goto Top       Goto mod_UI       Goto Index

DataSheet_ColumnWidth (32)

99      
100     
101      Public Function DataSheet_ColumnWidth( _ 
102         frm As Form _ 
103         ) As Byte 
104       '---------------------------------------------------------------------------------------
105       ' Procedure : DataSheet_ColumnWidth
106       ' Author    : GPG .................... modified by Crystal 131113, 131125
107       ' Date      : 9/25/2010
108       ' Purpose   : Reset column widths
109       '---------------------------------------------------------------------------------------
110         On Error GoTo Proc_Err 
111         Dim ctl As Control 
112     
113         For Each ctl In frm.Detail.Controls 
114             ' -2 sets column width to fit displayed text exactly
115            ctl.ColumnWidth = -2 
116         Next ctl 
117     
118      Proc_Exit: 
119         On Error Resume Next 
120         Set ctl = Nothing 
121         Exit Function 
122     
123      Proc_Err: 
124         If Err.Number = 438 Then Resume Next 
125         MsgBox Err.Description, , _ 
126              "ERROR " & Err.Number _ 
127              & "   DataSheet_ColumnWidth" 
128         Resume Proc_Exit 
129         Resume 
130      End Function 
      Goto Top       Goto mod_UI       Goto Index

PopCalendar (9)

131     
132      Public Function PopCalendar( _ 
133         Optional ByVal booDialog As Boolean = False _ 
134         , Optional pOpenArgs As String = "" _ 
135         ) 
136       '130902, 131103
137         DoCmd.OpenForm "f_PopupCalendar", , , , _ 
138         , IIf(booDialog, acDialog, acWindowNormal), pOpenArgs 
139      End Function 
      Goto Top       Goto mod_UI       Goto Index

IsValueUnique (22)

140     
141      Public Function IsValueUnique( _ 
142         psTable As String _ 
143         , psFieldID As String _ 
144         , pnIDcurrent As Long _ 
145         , psFieldValue As String _ 
146         , pvarValue As Variant _ 
147         , Optional psDeli As String = "" _ 
148         ) As Boolean 
149     
150          'make sure value is unique
151         Dim nIDfind As Long _ 
152            , varValueLookup As Variant 
153     
154         IsValueUnique = IsNull(DLookup(psFieldValue _ 
155                     , psTable _ 
156                     , "[" & psFieldValue & "]=" & psDeli & pvarValue & psDeli _ 
157                        & " AND [" & psFieldID & "] <>" & pnIDcurrent _ 
158                     )) 
159     
160     
161      End Function 
      Goto Top       Goto mod_UI       Goto Index

GetSQL_ORDERBY (70)

162     
163      Public Function GetSQL_ORDERBY( _ 
164            ByVal pSQL As String _ 
165            , ByVal psOrderBy As String _ 
166            , Optional ByVal pbooAdd As Boolean = False _ 
167            ) As String 
168       'strive4peace, 140421
169       'add/replace OrderBy clause of SQL string, if specified
170     
171       'strive4peace, 140121
172         On Error GoTo Proc_Err 
173         Dim iPos As Integer 
174     
175         If Not Len(psOrderBy) > 0 Then 
176             'no change
177            GetSQL_ORDERBY = pSQL     'same as what was sent 
178            Exit Function 
179         End If 
180     
181         pSQL = Trim(pSQL) 
182     
183          'look for ORDER BY
184         iPos = InStr(pSQL, "ORDER BY ") 
185     
186          'look for ORDER BY
187         If iPos > 0 Then 
188            If pbooAdd Then 
189               If Len(psOrderBy) > 0 Then 
190                   'add to beginning of ORDER BY clause
191                  pSQL = Replace(pSQL, "ORDER BY " _ 
192                                    , " ORDER BY " & psOrderBy & ", ") 
193               End If 
194            Else 
195               If Len(psOrderBy) > 0 Then 
196                   'replace ORDER BY clause
197                  pSQL = Left(pSQL, iPos + 8) & psOrderBy & ";" 
198               Else 
199                   'remove ORDER BY clause
200                  pSQL = Left(pSQL, iPos - 1) & ";" 
201               End If 
202     
203            End If 
204     
205         Else   'no ORDER BY clause in the SQL 
206            If Len(psOrderBy) > 0 Then 
207                'add to end
208               iPos = Len(pSQL) 
209               If Right(pSQL, 1) = ";" Then 
210                  iPos = iPos - 1 
211               End If 
212               pSQL = Left(pSQL, iPos) _ 
213                            & " ORDER BY " & psOrderBy & ";" 
214            Else 
215                'no change
216            End If 
217         End If 
218     
219         GetSQL_ORDERBY = pSQL 
220      Proc_Exit: 
221            On Error Resume Next 
222            Exit Function 
223     
224      Proc_Err: 
225          '   MsgBox Err.Description, , _
226              "ERROR " & Err.Number _
227              & "   GetSQL_ORDERBY"
228         GetSQL_ORDERBY = pSQL 
229         Resume Proc_Exit 
230         Resume 
231      End Function 
      Goto Top       Goto mod_UI       Goto Index

GetSQL_WHERE (103)

232     
233     
234      Public Function GetSQL_WHERE( _ 
235            ByVal pSQL As String _ 
236            , ByVal psWhere As String _ 
237            , Optional pbooAdd As Boolean = False _ 
238            ) As String 
239       'strive4peace
240       'add or replace criteria to/in the WHERE clause of an SQL string, if specified
241       'future: remove Where if not specified
242     
243       'strive4peace ... 131204, 140120, 140623
244       'add criteria to the WHERE clause of an SQL string. Create if Where is not there.
245       'will FAIL if fieldname ends with 'where', 'group by', ' having', 'order by'
246         On Error GoTo Proc_Err 
247         Dim iPos As Integer _ 
248             , iPos2 As Integer 
249     
250       '   If Not Len(psWhere) > 0 Then
251       '      'no change
252       '      GetSQL_WHERE = pSQL   'same as what was sent
253       '      Exit Function
254       '   End If
255     
256         pSQL = Trim(pSQL) 
257     
258          'look for WHERE
259         iPos = InStr(pSQL, "WHERE ") 
260     
261         If iPos > 0 Then 
262            If pbooAdd Then 
263                'add to beginning of WHERE clause
264               If Len(psWhere) > 0 Then 
265                  pSQL = Replace(pSQL, "WHERE " _ 
266                                    , " WHERE (" & psWhere & ")" & " AND ") 
267               End If 
268            Else 
269                'replace WHERE clause
270               iPos2 = InStr(iPos + 1, pSQL, "GROUP BY ") 
271               If Not iPos2 > 0 Then 
272                  iPos2 = InStr(iPos + 1, pSQL, "HAVING ") 
273                  If Not iPos2 > 0 Then 
274                     iPos2 = InStr(iPos + 1, pSQL, "ORDER BY ") 
275                  End If 
276               End If 
277               If Not iPos2 > 0 Then 
278                  iPos2 = Len(pSQL) 
279                  If Right(pSQL, 1) = ";" Then 
280                     iPos2 = iPos2 - 1 
281                  End If 
282               End If 
283               If Len(psWhere) > 0 Then   '140623 - 5 
284                  pSQL = Left(pSQL, iPos + 5) _ 
285                              & psWhere & " " & Mid(pSQL, iPos2) 
286               Else 
287                   'remove WHERE clause
288                  pSQL = Left(pSQL, iPos - 1) _ 
289                              & Mid(pSQL, iPos2) 
290               End If 
291            End If 
292         Else 
293            If Len(psWhere) > 0 Then 
294                'create WHERE clause
295                'look for GROUP BY
296               If (InStr(pSQL, "GROUP BY ")) > 0 Then 
297                   'put before 'GROUP BY'
298                  pSQL = Replace(pSQL, "GROUP BY " _ 
299                                       , " WHERE " & psWhere & " GROUP BY ") 
300                   'look for HAVING
301               ElseIf (InStr(pSQL, "HAVING")) > 0 Then 
302                   'put before 'Having'
303                  pSQL = Replace(pSQL, "HAVING " _ 
304                                       , " WHERE " & psWhere & " HAVING ") 
305               Else 
306                   'look for ORDER BY
307                  If (InStr(pSQL, "ORDER BY ")) > 0 Then 
308                     pSQL = Replace(pSQL, "ORDER BY " _ 
309                                          , " WHERE " & psWhere & " ORDER BY ") 
310                  Else 
311                      'add to end
312                     iPos = Len(pSQL) 
313                     If Right(pSQL, 1) = ";" Then 
314                        iPos = iPos - 1 
315                     End If 
316                     pSQL = Left(pSQL, iPos) _ 
317                            & " WHERE " & psWhere & ";" 
318                  End If 
319               End If 
320            End If 
321         End If 
322         GetSQL_WHERE = pSQL 
323      Proc_Exit: 
324            On Error Resume Next 
325            Exit Function 
326     
327      Proc_Err: 
328             '   MsgBox Err.Description, , _
329                 "ERROR " & Err.Number _
330                 & "   GetSQL_WHERE"
331            GetSQL_WHERE = pSQL 
332            Resume Proc_Exit 
333            Resume 
334         End Function 
      Goto Top       Goto mod_UI       Goto Index

SetControl_RowSource (70)

335     
336     
337      Public Function SetControl_RowSource( _ 
338         pCtl As Control _ 
339         , Optional ByVal psWhere As String = "" _ 
340         , Optional booClearValue As Boolean = False _ 
341         , Optional booClearIfNotInList As Boolean = False _ 
342         , Optional psOrderBy As String = "" _ 
343         , Optional psFind As String = "" _ 
344         , Optional psReplace As String = "" _ 
345         ) 
346       '131017 strive4peace, 131023, 1029, 1218, 140421, 141009 find/replace
347          'ASSUMPTIONs:
348          '  .Tag contains SQL for the control
349          '     if there is a WHERE clause, it will be appended.
350          '     if not, it will be added
351          '  SQL has an ORDER BY clause
352          '
353          ' CALLS
354          '  GetSQL_WHERE
355          '  GetSQL_ORDERBY
356          '  booClearIfNotInList
357     
358         On Error GoTo Proc_Err 
359     
360         Dim sSQL As String 
361     
362         sSQL = pCtl.Tag 
363         If psOrderBy <> "" Then 
364            sSQL = GetSQL_ORDERBY(sSQL, psOrderBy) 
365         End If 
366         sSQL = GetSQL_WHERE(sSQL, psWhere) 
367         If psFind <> "" And psReplace <> "" Then 
368            sSQL = Replace(sSQL, psFind, psReplace) 
369         End If 
370     
371         With pCtl 
372     
373            If .RowSource <> sSQL Then 
374      Debug.Print pCtl.Name, psWhere 
375      Debug.Print sSQL 
376     
377               .RowSource = sSQL 
378       '         On Error Resume Next
379               .Requery 
380       '         On Error Resume Next
381               If booClearValue Then 
382                  .Value = Null 
383               ElseIf booClearIfNotInList Then 
384                  If Not IsNull(.Value) Then 
385                     If CStr(Nz(.Value)) <> Nz(.Column(0)) Then 
386                        .Value = Null 
387                     End If 
388                  End If 
389               End If 
390            End If 
391         End With   'pCtl 
392     
393      Proc_Exit: 
394         On Error Resume Next 
395         Exit Function 
396     
397      Proc_Err: 
398         MsgBox Err.Description, , _ 
399              "ERROR " & Err.Number _ 
400              & "   SQL_AddWhere" 
401     
402         Resume Proc_Exit 
403         Resume 
404      End Function 
      Goto Top       Goto mod_UI       Goto Index

AttachNote (18)

405     
406      Public Function AttachNote( _ 
407          pnTID As Long _ 
408         , pnRecordID As Long _ 
409         , Optional pnCID As Long = -99 _ 
410         , Optional pnTopicID As Long = -99 _ 
411         ) 
412     
413         Call Set_Property("local_TID", pnTID) 
414         Call Set_Property("local_RecordID", pnRecordID) 
415         Call Set_Property("local_TopicID", pnTopicID) 
416         Call Set_Property("local_CID", pnCID) 
417     
418       '   DoEvents
419     
420         DoCmd.OpenForm "fc_Notes", , , , , acDialog 
421     
422      End Function 
      Goto Top       Goto mod_UI       Goto Index

BehaviorEnteringField (6)

423     
424      Public Sub BehaviorEnteringField() 
425         SetOption "Behavior entering field", 0 
426         MsgBox GetOption("Behavior entering field") 
427     
428      End Sub 
      Goto Top       Goto mod_UI       Goto Index

AskSaveTheChanges (33)

429     
430      Public Function AskSaveTheChanges( _ 
431         Optional pTable As String = "" _ 
432         , Optional pRecordDescription As String = "" _ 
433         ) As Long 
434       '101229
435      Exit Function 
436          'RETURNS
437          ' vbYes, vbNo, vbCancel
438     
439          'PARAMETERS
440          '  pTable --> how to describe what is changing
441          '      for example --> Contact
442          '      results in --> save changes to the Contact record?
443     
444         Dim sMsg As String 
445     
446         sMsg = "Do you want to save " _ 
447            & IIf(Len(pTable) > 0 _ 
448               , "changes to the " & pTable & " record" _ 
449               , "these changes?") _ 
450            & IIf(Len(pRecordDescription) > 0 _ 
451               , " for " & vbCrLf & vbCrLf & "     " & pRecordDescription _ 
452               , "?") _ 
453            & vbCrLf & vbCrLf _ 
454            & " YES, Save changes" & vbCrLf _ 
455            & " NO, Don't save yet. I am not done making changes" & vbCrLf _ 
456            & " CANCEL = Don't save changes, UNDO what I did" & vbCrLf 
457     
458         AskSaveTheChanges = MsgBox(sMsg _ 
459            , vbYesNoCancel, "Save Updates?") 
460     
461      End Function 
      Goto Top       Goto mod_UI       Goto Index

FormBeforeUpdate (74)

462     
463     
464       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ FormBeforeUpdate
465      Public Function FormBeforeUpdate(pF As Form _ 
466         , Optional bSetParentToo As Boolean = False _ 
467         ) As Boolean 
468     
469          '~~~~~~~~~~~~~~~~~~~~~~~~~~~~
470          '110918
471          'the reason this code is here is:
472          'if the user is Report then they should not be updating a record
473          'so the BeforeUpdate event should be canceled
474          'and the record should be undone
475     
476       '   If Get_Property("local_UsrCatID") = 3 Then
477       '      'don't set the tracking fields -- exit instead
478       '      Exit Sub
479       '   End If
480          '~~~~~~~~~~~~~~~~~~~~~~~~~~~~
481     
482       'cma
483       '101029 IsSubform
484     
485          'this is to be called on the Form BeforeUpdate event
486     
487          'to call this from code behind the form -->
488          '   FormBeforeUpdate Me
489          '
490          ' you can also specify the optional parameter to
491          ' update the parent form too (this defaults to False) -->
492          '   FormBeforeUpdate Me, True
493          '~~~~~~~~~~~~~~~~~~~~~~
494          '
495          'if the main form is NOT the parent,
496          'you could modify the procedure to accept
497          'another optional parameter with the form you also wish to update
498     
499          'Crystal 9-17-08, customized 100915
500     
501         On Error GoTo Proc_Err 
502     
503         FormBeforeUpdate = False 
504     
505       '   Dim nUsrID As Long
506       '   'use custom database properties to store the current user
507       '   nUsrID = DBEngine(0)(0).Properties("local_UserID")
508     
509       '   If bSetParentToo Then
510       '      If IsSubform(pF) Then
511       '         pF.Parent.dtmEdit = Now()
512       '         pF.Parent!IDedit = nUsrID
513       '      End If
514       '   End If
515     
516       '   If pF.NewRecord Then
517       '      'Date Added has a default value in the table definition
518       '      pF!IDadd = nUsrID
519       '   End If
520     
521       '   pF!IDedit = nUsrID
522         pF!dtmEdit = Now() 
523     
524         FormBeforeUpdate = True 
525     
526      Proc_Exit: 
527         Exit Function 
528     
529      Proc_Err: 
530         MsgBox Err.Description, , _ 
531              "ERROR " & Err.Number _ 
532              & "   FormBeforeUpdate" 
533         Resume Proc_Exit 
534         Resume 
535      End Function 
      Goto Top       Goto mod_UI       Goto Index

myFormOpenEvent (71)

536     
537     
538      Function myFormOpenEvent(pForm As Form _ 
539        , Optional pControlFocus As String = "" _ 
540        , Optional pTagData As String = "~DataEnable~" _ 
541        ) As Long 
542       '111130
543       '111201 change RecordsetType conditional
544       '130831
545     
546          'returns UsrCatID
547     
548         myFormOpenEvent = -999 
549     
550         Dim ctl As Control _ 
551            , bBoo As Boolean 
552     
553         On Error GoTo Proc_Err 
554     
555        Dim nUsrCatID As Long 
556     
557          'read database property information for user privileges
558          '1=Admin, 2=Data, 3=Report
559         nUsrCatID = Get_Property("local_UsrCatID") 
560         myFormOpenEvent = nUsrCatID 
561         If nUsrCatID = 3 Then 
562             'reporting only
563            If pForm.RecordsetType <> 2 Then 
564               pForm.RecordsetType = 2 
565            End If 
566            bBoo = False   'disable marked controls 
567         Else 
568            If pForm.RecordsetType <> 0 Then 
569               pForm.RecordsetType = 0 
570            End If 
571            bBoo = True   'enable everything that is marked 
572         End If 
573     
574          'move focus if we are disabling
575         If Not bBoo Then 
576             'if optional parameter was specified, move focus
577            If Len(pControlFocus) > 0 Then pForm(pControlFocus).SetFocus 
578         End If 
579     
580             '111130 tony
581         For Each ctl In pForm.Controls 
582            If InStr(ctl.Tag, pTagData) > 0 Then 
583              ctl.Properties("Enabled") = bBoo 
584            End If 
585         Next ctl 
586     
587      Proc_Exit: 
588     
589         Set ctl = Nothing 
590         Exit Function 
591     
592      Proc_Err: 
593         MsgBox Err.Description, , _ 
594         "ERROR " & Err.Number _ 
595         & " myFormOpenEvent" 
596     
597       'Debug.Print pForm.Name
598       'Debug.Print ctl.Name
599     
600         Resume Proc_Exit 
601     
602          'if you want to single-step code to find error, CTRL-Break at MsgBox
603          'then set this to be the next statement
604         Resume 
605     
606      End Function 
      Goto Top       Goto mod_UI       Goto Index

GetResponse_NIL (71)

607     
608     
609       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GetResponse_NIL
610      Public Function GetResponse_NIL(pNewData As String _ 
611         , psTblNm As String _ 
612         , psFldNm As String _ 
613         , Optional pnTID As Long = 0 _ 
614         , Optional psTitle As String = "Type" _ 
615         , Optional pBooConvertProper As Boolean = False _ 
616         ) As Integer 
617       '101010
618           'set up Error Handler
619          On Error GoTo Proc_Err 
620     
621          Dim sSQL As String _ 
622            , sNewData As String 
623     
624         If pBooConvertProper Then 
625            sNewData = StrConv(pNewData, 3)   '3=vbProperCase 
626         Else 
627            sNewData = pNewData 
628         End If 
629     
630          ' Display message box asking if user wants to add a new item
631          ' for default to be NO instead of Yes --> vbYesNo + vbDefaultButton2
632         Select Case MsgBox("Add '" & sNewData & "'? " _ 
633            , vbYesNo, "Add New " & psTitle) 
634     
635         Case vbYes 
636     
637            sSQL = "INSERT INTO [" & psTblNm & "] ([" & psFldNm & "]" _ 
638               & IIf(pnTID <> 0, ", TID", Null) _ 
639               & ") " _ 
640               & " SELECT '" & sNewData & "'" _ 
641               & IIf(pnTID <> 0, ", " & pnTID, Null) _ 
642               & ";" 
643     
644            With DBEngine(0)(0) 
645               .Execute sSQL 
646               .TableDefs.Refresh 
647                'comment or remove next lines after this works correctly, if desired
648               Debug.Print sSQL 
649               Debug.Print "---------------- " & .RecordsAffected 
650            End With 
651     
652            DoEvents 
653     
654             'assume SQL to add was ok
655             '-- may want to change to acDataErrContinue
656             ' and return True or False
657            GetResponse_NIL = 2    'acDataErrAdded 
658     
659          Case Else 
660              GetResponse_NIL = 0    'acDataErrContinue 
661          End Select 
662     
663      Proc_Exit: 
664         Exit Function 
665     
666      Proc_Err: 
667          'NOTE: replace ProcedureName with the name of your procedure
668         MsgBox Err.Description, , _ 
669              "ERROR " & Err.Number _ 
670              & "   GetResponse_NIL" 
671     
672         Resume Proc_Exit 
673     
674          'if you want to single-step code to find error, CTRL-Break at MsgBox
675          'then set this to be the next statement
676         Resume 
677      End Function 
      Goto Top       Goto mod_UI       Goto Index

TypeID_NIL (61)

678     
679     
680       '~~~~~~~~~~~~~~~~~~~~~~~~~~ TypeID_NIL
681       ' CUSTOMIZE
682      Function TypeID_NIL( _ 
683         ByRef NewData As String _ 
684         , ByRef Response As Integer _ 
685         , ByVal pF As Form _ 
686         , ByVal pTID As Long _ 
687         , Optional ByVal pTID_ As Long = 0) As Boolean 
688     
689       '8-6-08
690         TypeID_NIL = False 
691     
692       '   If Not IsAdmin() Then
693       '      MsgBox "Contact Administrator to add item to list", , "Pick Item from list"
694       '      pF.TypeID = Null
695       '      Response = acDataErrContinue
696       '      Exit Function
697       '   End If
698     
699          Dim s As String _ 
700            , mRecordID As Long _ 
701            , mText As String _ 
702            , mNum As Long 
703     
704          'convert to ProperCase
705         If Not CurrentDb.Properties("DefaultProperCase") Then 
706            mText = NewData 
707         Else 
708            mText = StrConv(NewData, vbProperCase) 
709         End If 
710     
711         s = "INSERT INTO t_Types (Typ, TID" 
712     
713         If pTID_ <> 0 Then s = s & ", TID_" 
714     
715         s = s & ") " _ 
716            & " SELECT '" & mText & "', " & pTID 
717         If pTID_ <> 0 Then s = s & ", " & pTID_ 
718     
719         s = s & ";" 
720     
721           '--------------------------------------------------------
722     
723          mNum = rSql(s) 
724          DoEvents 
725     
726          If mNum > 0 Then 
727       '      mRecordID = Nz(DMax("TypeID", "t_Types"))
728       '         pF.TypeID.Requery
729              Response = acDataErrAdded 
730       '        pF.TypeID = mRecordID
731          Else 
732              Response = acDataErrContinue 
733          End If 
734     
735         TypeID_NIL = True 
736      Proc_Exit: 
737         Exit Function 
738      End Function 
      Goto Top       Goto mod_UI       Goto Index

ToggleProperCase (13)

739     
740     
741      Function ToggleProperCase(Optional pBoo As Integer = -99) As Boolean 
742         Dim mBoo As Boolean 
743         If pBoo = -99 Then 
744            mBoo = Get_Property("local_ConvertToProper") 
745            mBoo = Not mBoo 
746         Else 
747            mBoo = pBoo 
748         End If 
749         Set_Property "local_ConvertToProper", mBoo, dbBoolean 
750         ToggleProperCase = mBoo 
751       End Function 
      Goto Top       Goto mod_UI       Goto Index

StripPhoneNonNumeric (17)

752     
753       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ StripPhoneNonNumeric
754      Function StripPhoneNonNumeric(pPhone As String) As String 
755       '8-6-08
756         Dim sPhone As String _ 
757            , i As Integer _ 
758            , sChar As String * 1 
759     
760          'loop through number and only keep numeric characters
761         For i = 1 To Len(pPhone) 
762            sChar = Mid(pPhone, i, 1) 
763            If IsNumeric(sChar) Then 
764               sPhone = sPhone & sChar 
765            End If 
766         Next i 
767         StripPhoneNonNumeric = sPhone 
768      End Function 
      Goto Top       Goto mod_UI       Goto Index

OpenShortcuts (5)

769     
770      Function OpenShortcuts() 
771       '101213
772         DoCmd.OpenForm "f_ShortcutKeys" 
773      End Function 
      Goto Top       Goto mod_UI       Goto Index

GetObjectType (16)

774     
775       'this is needed for: qExtra_MsysObjects
776      Function GetObjectType(pType) As String 
777         Select Case pType 
778         Case 1: GetObjectType = "Table" 
779         Case 3: GetObjectType = "Container" 
780         Case 5: GetObjectType = "Query" 
781         Case 8: GetObjectType = "Relationship"   '100514 
782         Case -32768: GetObjectType = "Form" 
783         Case -32764: GetObjectType = "Report" 
784         Case -32766: GetObjectType = "Macro" 
785         Case -32761: GetObjectType = "Module" 
786         Case Else: GetObjectType = pType 
787         End Select 
788      End Function 
789     
      Goto Top       Goto mod_UI       Goto Index

Reports

  1. Report_r_ADDRESSES (40)
  2. Report_r_addresses_sub (3)
  3. Report_r_BIRTHDAYS (35)
  4. Report_r_COMPANY_CONTACTS (36)
  5. Report_r_CONTACTS (41)
  6. Report_r_emailaddresses_sub (3)
  7. Report_r_Notes (24)
  8. Report_r_PHONES_2col (36)
  9. Report_r_PHONES_3col (36)
  10. Report_r_phones_sub (3)
  11. Report_r_web_sub (3)
  12. Report_rc_Avery5160 (27)
Goto END of Reports       Goto Top       Goto Index

Report_r_ADDRESSES (40)

PROCEDURES       Goto Top       Goto Report_r_ADDRESSES       Goto Reports       Goto Index
  1. Declaration Lines (12)
  2. GroupFooter1_Format (5)
  3. Report_NoData (7)
  4. Report_Open (10)
  5. ReportFooter_Format (6)

Declaration Lines (12)

1        Option Compare Database 
2        Option Explicit 
3         '
4         'This code was orignally written by Crystal
5         'It is not to be altered or distributed,
6         'except as part of an application.
7         'You are free to use it in any application,
8         'provided the copyright notice is left unchanged.
9         '
10        'strive4peace2007@yahoo.com
11        '
12        'released 6-4-07
      Goto Top       Goto Report_r_ADDRESSES       Goto Index

GroupFooter1_Format (5)

13      
14       Private Sub GroupFooter1_Format(Cancel As Integer, FormatCount As Integer) 
15        '141007
16          Me.GroupFooter1.Visible = (Me.countLetter > 1) 
17       End Sub 
      Goto Top       Goto Report_r_ADDRESSES       Goto Index

Report_NoData (7)

18      
19      
20       Private Sub Report_NoData(Cancel As Integer) 
21          Call ClosePleaseWait 
22          MsgBox "Report has no data for specified criteria", , "No Data" 
23          Cancel = True 
24       End Sub 
      Goto Top       Goto Report_r_ADDRESSES       Goto Index

Report_Open (10)

25      
26       Private Sub Report_Open(Cancel As Integer) 
27        '141007
28          On Error Resume Next 
29          Call PleaseWaitMsg("PleaseWait..." _ 
30             & vbCrLf & vbCrLf & Me.Caption & " Report is loading ...") 
31          With Me 
32             .FriendlyCrit.Caption = Replace(Nz(.OpenArgs, ""), "&", "&&") 
33          End With 
34       End Sub 
      Goto Top       Goto Report_r_ADDRESSES       Goto Index

ReportFooter_Format (6)

35      
36       Private Sub ReportFooter_Format(Cancel As Integer, FormatCount As Integer) 
37          On Error Resume Next 
38          Call ClosePleaseWait 
39       End Sub 
40      
      Goto Top       Goto Report_r_ADDRESSES       Goto Index

Report_r_addresses_sub (3)

PROCEDURES       Goto Top       Goto Report_r_addresses_sub       Goto Reports       Goto Index
  1. Declaration Lines (3)

Declaration Lines (3)

1        Option Compare Database 
2        Option Explicit 
3       
      Goto Top       Goto Report_r_addresses_sub       Goto Index

Report_r_BIRTHDAYS (35)

PROCEDURES       Goto Top       Goto Report_r_BIRTHDAYS       Goto Reports       Goto Index
  1. Declaration Lines (12)
  2. Report_NoData (6)
  3. Report_Open (10)
  4. ReportFooter_Format (7)

Declaration Lines (12)

1        Option Compare Database 
2        Option Explicit 
3         '
4         'This code was orignally written by Crystal
5         'It is not to be altered or distributed,
6         'except as part of an application.
7         'You are free to use it in any application,
8         'provided the copyright notice is left unchanged.
9         '
10        'strive4peace2007@yahoo.com
11        '
12        'released 6-4-07
      Goto Top       Goto Report_r_BIRTHDAYS       Goto Index

Report_NoData (6)

13      
14       Private Sub Report_NoData(Cancel As Integer) 
15          Call ClosePleaseWait 
16          MsgBox "Report has no data for specified criteria", , "No Data" 
17          Cancel = True 
18       End Sub 
      Goto Top       Goto Report_r_BIRTHDAYS       Goto Index

Report_Open (10)

19      
20       Private Sub Report_Open(Cancel As Integer) 
21        '141007
22          On Error Resume Next 
23          Call PleaseWaitMsg("PleaseWait..." _ 
24             & vbCrLf & vbCrLf & Me.Caption & " Report is loading ...") 
25          With Me 
26             .FriendlyCrit.Caption = Replace(Nz(.OpenArgs, ""), "&", "&&") 
27          End With 
28       End Sub 
      Goto Top       Goto Report_r_BIRTHDAYS       Goto Index

ReportFooter_Format (7)

29      
30       Private Sub ReportFooter_Format(Cancel As Integer, FormatCount As Integer) 
31          On Error Resume Next 
32          Call ClosePleaseWait 
33       End Sub 
34      
35      
      Goto Top       Goto Report_r_BIRTHDAYS       Goto Index

Report_r_COMPANY_CONTACTS (36)

PROCEDURES       Goto Top       Goto Report_r_COMPANY_CONTACTS       Goto Reports       Goto Index
  1. Declaration Lines (12)
  2. Report_NoData (6)
  3. Report_Open (10)
  4. ReportFooter_Format (8)

Declaration Lines (12)

1        Option Compare Database 
2        Option Explicit 
3         '
4         'This code was orignally written by Crystal
5         'It is not to be altered or distributed,
6         'except as part of an application.
7         'You are free to use it in any application,
8         'provided the copyright notice is left unchanged.
9         '
10        'strive4peace2007@yahoo.com
11        '
12        'released 6-4-07
      Goto Top       Goto Report_r_COMPANY_CONTACTS       Goto Index

Report_NoData (6)

13      
14       Private Sub Report_NoData(Cancel As Integer) 
15          Call ClosePleaseWait 
16          MsgBox "Report has no data for specified criteria", , "No Data" 
17          Cancel = True 
18       End Sub 
      Goto Top       Goto Report_r_COMPANY_CONTACTS       Goto Index

Report_Open (10)

19      
20       Private Sub Report_Open(Cancel As Integer) 
21        '141007
22          On Error Resume Next 
23          Call PleaseWaitMsg("PleaseWait..." _ 
24             & vbCrLf & vbCrLf & Me.Caption & " Report is loading ...") 
25          With Me 
26             .FriendlyCrit.Caption = Replace(Nz(.OpenArgs, ""), "&", "&&") 
27          End With 
28       End Sub 
      Goto Top       Goto Report_r_COMPANY_CONTACTS       Goto Index

ReportFooter_Format (8)

29      
30      
31       Private Sub ReportFooter_Format(Cancel As Integer, FormatCount As Integer) 
32          On Error Resume Next 
33          Call ClosePleaseWait 
34       End Sub 
35      
36      
      Goto Top       Goto Report_r_COMPANY_CONTACTS       Goto Index

Report_r_CONTACTS (41)

PROCEDURES       Goto Top       Goto Report_r_CONTACTS       Goto Reports       Goto Index
  1. Declaration Lines (12)
  2. GroupFooter3_Format (5)
  3. Report_NoData (6)
  4. Report_Open (10)
  5. ReportFooter_Format (8)

Declaration Lines (12)

1        Option Compare Database 
2        Option Explicit 
3         '
4         'This code was orignally written by Crystal
5         'It is not to be altered or distributed,
6         'except as part of an application.
7         'You are free to use it in any application,
8         'provided the copyright notice is left unchanged.
9         '
10        'strive4peace2007@yahoo.com
11        '
12        'released 6-4-07
      Goto Top       Goto Report_r_CONTACTS       Goto Index

GroupFooter3_Format (5)

13      
14       Private Sub GroupFooter3_Format(Cancel As Integer, FormatCount As Integer) 
15        '141007
16          Me.GroupFooter3.Visible = (Me.countContact_Letter > 1) 
17       End Sub 
      Goto Top       Goto Report_r_CONTACTS       Goto Index

Report_NoData (6)

18      
19       Private Sub Report_NoData(Cancel As Integer) 
20          Call ClosePleaseWait 
21          MsgBox "Report has no data for specified criteria", , "No Data" 
22          Cancel = True 
23       End Sub 
      Goto Top       Goto Report_r_CONTACTS       Goto Index

Report_Open (10)

24      
25       Private Sub Report_Open(Cancel As Integer) 
26        '141007
27          On Error Resume Next 
28          Call PleaseWaitMsg("PleaseWait..." _ 
29             & vbCrLf & vbCrLf & Me.Caption & " Report is loading ...") 
30          With Me 
31             .FriendlyCrit.Caption = Replace(Nz(.OpenArgs, ""), "&", "&&") 
32          End With 
33       End Sub 
      Goto Top       Goto Report_r_CONTACTS       Goto Index

ReportFooter_Format (8)

34      
35      
36      
37       Private Sub ReportFooter_Format(Cancel As Integer, FormatCount As Integer) 
38          On Error Resume Next 
39          Call ClosePleaseWait 
40       End Sub 
41      
      Goto Top       Goto Report_r_CONTACTS       Goto Index

Report_r_emailaddresses_sub (3)

PROCEDURES       Goto Top       Goto Report_r_emailaddresses_sub       Goto Reports       Goto Index
  1. Declaration Lines (3)

Declaration Lines (3)

1        Option Compare Database 
2        Option Explicit 
3       
      Goto Top       Goto Report_r_emailaddresses_sub       Goto Index

Report_r_Notes (24)

PROCEDURES       Goto Top       Goto Report_r_Notes       Goto Reports       Goto Index
  1. Declaration Lines (2)
  2. Report_NoData (6)
  3. Report_Open (10)
  4. ReportFooter_Format (6)

Declaration Lines (2)

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

Report_NoData (6)

3       
4        Private Sub Report_NoData(Cancel As Integer) 
5           Call ClosePleaseWait 
6           MsgBox "Report has no data for specified criteria", , "No Data" 
7           Cancel = True 
8        End Sub 
      Goto Top       Goto Report_r_Notes       Goto Index

Report_Open (10)

9       
10       Private Sub Report_Open(Cancel As Integer) 
11        '141007
12          On Error Resume Next 
13          Call PleaseWaitMsg("PleaseWait..." _ 
14             & vbCrLf & vbCrLf & Me.Caption & " Report is loading ...") 
15          With Me 
16             .FriendlyCrit.Caption = Replace(Nz(.OpenArgs, ""), "&", "&&") 
17          End With 
18       End Sub 
      Goto Top       Goto Report_r_Notes       Goto Index

ReportFooter_Format (6)

19      
20       Private Sub ReportFooter_Format(Cancel As Integer, FormatCount As Integer) 
21          On Error Resume Next 
22          Call ClosePleaseWait 
23       End Sub 
24      
      Goto Top       Goto Report_r_Notes       Goto Index

Report_r_PHONES_2col (36)

PROCEDURES       Goto Top       Goto Report_r_PHONES_2col       Goto Reports       Goto Index
  1. Declaration Lines (12)
  2. Report_NoData (6)
  3. Report_Open (10)
  4. ReportFooter_Format (8)

Declaration Lines (12)

1        Option Compare Database 
2        Option Explicit 
3         '
4         'This code was orignally written by Crystal
5         'It is not to be altered or distributed,
6         'except as part of an application.
7         'You are free to use it in any application,
8         'provided the copyright notice is left unchanged.
9         '
10        'strive4peace2007@yahoo.com
11        '
12        'released 6-4-07
      Goto Top       Goto Report_r_PHONES_2col       Goto Index

Report_NoData (6)

13      
14       Private Sub Report_NoData(Cancel As Integer) 
15          Call ClosePleaseWait 
16          MsgBox "Report has no data for specified criteria", , "No Data" 
17          Cancel = True 
18       End Sub 
      Goto Top       Goto Report_r_PHONES_2col       Goto Index

Report_Open (10)

19      
20       Private Sub Report_Open(Cancel As Integer) 
21        '141007
22          On Error Resume Next 
23          Call PleaseWaitMsg("PleaseWait..." _ 
24             & vbCrLf & vbCrLf & Me.Caption & " Report is loading ...") 
25          With Me 
26             .FriendlyCrit.Caption = Replace(Nz(.OpenArgs, ""), "&", "&&") 
27          End With 
28       End Sub 
      Goto Top       Goto Report_r_PHONES_2col       Goto Index

ReportFooter_Format (8)

29      
30      
31       Private Sub ReportFooter_Format(Cancel As Integer, FormatCount As Integer) 
32          On Error Resume Next 
33          Call ClosePleaseWait 
34       End Sub 
35      
36      
      Goto Top       Goto Report_r_PHONES_2col       Goto Index

Report_r_PHONES_3col (36)

PROCEDURES       Goto Top       Goto Report_r_PHONES_3col       Goto Reports       Goto Index
  1. Declaration Lines (12)
  2. Report_NoData (6)
  3. Report_Open (10)
  4. ReportFooter_Format (8)

Declaration Lines (12)

1        Option Compare Database 
2        Option Explicit 
3         '
4         'This code was orignally written by Crystal
5         'It is not to be altered or distributed,
6         'except as part of an application.
7         'You are free to use it in any application,
8         'provided the copyright notice is left unchanged.
9         '
10        'strive4peace2007@yahoo.com
11        '
12        'released 6-4-07
      Goto Top       Goto Report_r_PHONES_3col       Goto Index

Report_NoData (6)

13      
14       Private Sub Report_NoData(Cancel As Integer) 
15          Call ClosePleaseWait 
16          MsgBox "Report has no data for specified criteria", , "No Data" 
17          Cancel = True 
18       End Sub 
      Goto Top       Goto Report_r_PHONES_3col       Goto Index

Report_Open (10)

19      
20       Private Sub Report_Open(Cancel As Integer) 
21        '141007
22          On Error Resume Next 
23          Call PleaseWaitMsg("PleaseWait..." _ 
24             & vbCrLf & vbCrLf & Me.Caption & " Report is loading ...") 
25          With Me 
26             .FriendlyCrit.Caption = Replace(Nz(.OpenArgs, ""), "&", "&&") 
27          End With 
28       End Sub 
      Goto Top       Goto Report_r_PHONES_3col       Goto Index

ReportFooter_Format (8)

29      
30      
31       Private Sub ReportFooter_Format(Cancel As Integer, FormatCount As Integer) 
32          On Error Resume Next 
33          Call ClosePleaseWait 
34       End Sub 
35      
36      
      Goto Top       Goto Report_r_PHONES_3col       Goto Index

Report_r_phones_sub (3)

PROCEDURES       Goto Top       Goto Report_r_phones_sub       Goto Reports       Goto Index
  1. Declaration Lines (3)

Declaration Lines (3)

1        Option Compare Database 
2        Option Explicit 
3       
      Goto Top       Goto Report_r_phones_sub       Goto Index

Report_r_web_sub (3)

PROCEDURES       Goto Top       Goto Report_r_web_sub       Goto Reports       Goto Index
  1. Declaration Lines (3)

Declaration Lines (3)

1        Option Compare Database 
2        Option Explicit 
3       
      Goto Top       Goto Report_r_web_sub       Goto Index

Report_rc_Avery5160 (27)

PROCEDURES       Goto Top       Goto Report_rc_Avery5160       Goto Reports       Goto Index
  1. Declaration Lines (2)
  2. Report_NoData (6)
  3. Report_Open (10)
  4. ReportFooter_Format (9)

Declaration Lines (2)

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

Report_NoData (6)

3       
4        Private Sub Report_NoData(Cancel As Integer) 
5           Call ClosePleaseWait 
6           MsgBox "Report has no data for specified criteria", , "No Data" 
7           Cancel = True 
8        End Sub 
      Goto Top       Goto Report_rc_Avery5160       Goto Index

Report_Open (10)

9       
10       Private Sub Report_Open(Cancel As Integer) 
11        '141007
12          On Error Resume Next 
13          Call PleaseWaitMsg("PleaseWait..." _ 
14             & vbCrLf & vbCrLf & Me.Caption & " Report is loading ...") 
15        '   With Me
16        '      .FriendlyCrit.Caption = Replace(Nz(.OpenArgs, ""), "&", "&&")
17        '   End With
18       End Sub 
      Goto Top       Goto Report_rc_Avery5160       Goto Index

ReportFooter_Format (9)

19      
20       Private Sub ReportFooter_Format(Cancel As Integer, FormatCount As Integer) 
21          On Error Resume Next 
22          Call ClosePleaseWait 
23       End Sub 
24      
25      
26      
27      
      Goto Top       Goto Report_rc_Avery5160       Goto Index

INDEX

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

Modules and Procedures by Module

bas_crystal_code_general_1308 (2,724)

AddFieldDesc (69)
AddFieldToTable (140)
BoldMe (208)
CancelMe (11)
CapString (14)
ClearList (17)
CloseMe (46)
CorrectName (85)
CorrectProper (23)
Declaration Lines (69)
DoesControlExistOnForm (21)
DoesExist (56)
DoesExistDelete (60)
DropMe (31)
DropMeIfNull (13)
EMailReport (74)
ExitAccess (9)
FindRecordN (111)
GetAge (16)
GetBirthday (14)
GetCurrentPath (16)
IsLoadedForm (28)
IsLoadedReport (27)
IsSubform (17)
IsTable (20)
IsValidURL (38)
ListIndexes (19)
listQuerySQL (21)
LoopAndCombine (97)
LoopCombineVar (82)
MakeADirectory (44)
MakeAPath (48)
MakeMyQuery (67)
open_Form (25)
open_Form_Filter (22)
open_Query (14)
open_Report (21)
ProperCase (45)
RecordDelete (60)
RecordFirst (28)
RecordLast (25)
RecordNew (45)
RecordNext (28)
RecordPrev (27)
RenameTrackingFields (47)
RequeryMe (21)
ResetStuff (14)
RunAddFieldsToTable_Tracking (138)
RunLoopAndCombine (16)
RunLoopCombineVar (20)
SetGBlockDrop (11)
SetRecordSource (59)
SetReportFilter (114)
ShowHideControls (59)
Sort123 (112)
TableHasField (46)
Update_dtmEdit_to_dtmAdd (68)
UpperCase (27)
ZoomMe (21)

Goto Top       Goto Index

bas_Crystal_Properties_0806_130410_0429 (628)

Custom_Delete_Properties (27)
Custom_SetDefaultProperties (222)
Declaration Lines (2)
Delete_Property (58)
Get_Property (62)
GetDefaultExampleID (10)
HideDBWindow (10)
IsPropertyDefined (45)
RunDeleteDatabaseProperty (13)
RunSet_Property (18)
RunSetDatabaseProperties (13)
runShow_Properties (7)
Set_Property (87)
SetDefaultExampleID (13)
Show_Properties (26)
ShowProperty (10)
UnHideDBWindow (5)

Goto Top       Goto Index

bas_Crystal_ReLinker_140629_080726_1001 (1,250)

AddTextToTableDescription (88)
ChangeTableDescriptions_ConnectInfo (133)
Declaration Lines (2)
DeleteAllTableDescriptions (35)
FoundBackEnd (19)
GetPathFromFilename (52)
GetSourceTableDescriptions (105)
GetTableDescription (48)
InStrRev97 (21)
IsBEok (42)
ReLinker (497)
run_ReLinker (119)
SetPathAttachment (35)
Split97 (44)
testSetPathAttachment (10)

Goto Top       Goto Index

bas_Crystal_RunSQL_130522 (336)

Declaration Lines (49)
EndTime (21)
GetElapsedTime (27)
ReportElapsedTime (62)
reportProgress (11)
ResetStuff (10)
rSql (141)
StartTime (15)

Goto Top       Goto Index

bas_PleaseWait (47)

ClosePleaseWait (7)
Declaration Lines (2)
PleaseWaitMsg (6)
ShowPleaseWait (32)

Goto Top       Goto Index

bas_RenameControls_ActiveFormReport (172)

Declaration Lines (29)
RenameControls_ActiveFormReport (123)
runRenameControls_ActiveFormReport (20)

Goto Top       Goto Index

Form_f_ADMIN (1,024)

cmd_Browse_PathBE_Click (41)
cmd_Cancel_Click (5)
cmd_DeleteData_Click (5)
cmd_NavigationPane_Click (7)
cmd_OpenUsers_Click (12)
cmd_Relink_Click (17)
cmd_SaveClose_Click (113)
cmdExit_Click (5)
Declaration Lines (37)
Form_Open (147)
Get_ColorDirectory (104)
Get_DirectoryDialog (33)
GetGoodPartOfPath (34)
pri_DropMe (6)
pri_UsrMgt_SetProperties (105)
SetBackColor (19)
SetDirectory (106)
usrCatID_AfterUpdate (27)
UsrID_AfterUpdate (99)
UsrID_BeforeUpdate (8)
UsrID_NotInList (94)

Goto Top       Goto Index

Form_f_AnywhereMENU (401)

cmd_Attachments_Click (15)
cmd_AttachNote_Click (20)
cmd_ClearFilter_Click (6)
cmd_Design_Click (8)
cmd_Open_Click (8)
Declaration Lines (28)
fltrTablename_AfterUpdate (5)
Form_Load (9)
Form_Open (11)
Label_By_Click (6)
local_GetDataType (55)
local_MakeQuery (49)
RowSource_Fieldlist (75)
RowSource_TID (38)
SourceObject_fc_AnywhereSub (39)
TID_AfterUpdate (22)
TID_MouseUp (7)

Goto Top       Goto Index

Form_f_Calendar_sub (1,014)

Add_SetCalendar (32)
cal_GetCardinalNumber (28)
cal_GetCol4Calendar (5)
cal_GetDowN4Calendar (26)
cal_GetRoman (51)
cal_GetRow4Calendar (38)
cal_IsSubform (17)
cal_ShowHideControlsTag (34)
cmd11_Click (4)
cmd12_Click (4)
cmd13_Click (4)
cmd14_Click (4)
cmd15_Click (4)
cmd16_Click (4)
cmd17_Click (4)
cmd21_Click (4)
cmd22_Click (4)
cmd23_Click (4)
cmd24_Click (4)
cmd25_Click (4)
cmd26_Click (4)
cmd27_Click (4)
cmd31_Click (4)
cmd32_Click (4)
cmd33_Click (4)
cmd34_Click (4)
cmd35_Click (4)
cmd36_Click (4)
cmd37_Click (4)
cmd41_Click (4)
cmd42_Click (4)
cmd43_Click (4)
cmd44_Click (4)
cmd45_Click (4)
cmd46_Click (4)
cmd47_Click (4)
cmd51_Click (4)
cmd52_Click (4)
cmd53_Click (4)
cmd54_Click (4)
cmd55_Click (4)
cmd56_Click (4)
cmd57_Click (4)
cmd61_Click (4)
cmd62_Click (4)
cmd63_Click (4)
cmd64_Click (4)
cmd65_Click (4)
cmd66_Click (4)
cmd67_Click (4)
cmdDayAdd_Click (18)
cmdDaySub_Click (19)
cmdMonthAdd_Click (23)
cmdMonthSub_Click (16)
cmdYrAdd_Click (20)
cmdYrSub_Click (19)
DayClick (41)
Declaration Lines (43)
Form_Load (50)
Form_Open (9)
Label_strive4peace_Click (8)
Mark_TodayAndDate (68)
Set_Calendar (189)
Set_DefaultFormat (26)
ShowDatePickerMessage (13)
txtCalendarDate_AfterUpdate (14)
txtCalendarDate_BeforeUpdate (18)
Update_ExternalForms (21)

Goto Top       Goto Index

Form_f_CalendarSub_test (85)

Date1_AfterUpdate (6)
Date2_AfterUpdate (6)
Date3_AfterUpdate (8)
Declaration Lines (2)
Form_Load (52)
Label_emailCrystal_Click (6)
Label_website_Click (5)

Goto Top       Goto Index

Form_f_CUSTOMER (95)

cmd_Add_Click (8)
cmd_Del_Click (5)
Declaration Lines (28)
dt1Bus_DblClick (4)
dtPurch_DblClick (6)
fnd_Customer_AfterUpdate (6)
fnd_CustomerContact_AfterUpdate (6)
fnd_Project_AfterUpdate (6)
Form_BeforeUpdate (5)
Form_Current (21)

Goto Top       Goto Index

Form_f_DataDICTIONARY_DisplayControl (507)

chkExclusive_Click (5)
chkHid_Click (5)
chkLinked_Click (5)
chkODBC_Click (5)
chkSavePW_Click (5)
chkSys_AfterUpdate (4)
cmd_Checkbox_Click (4)
cmd_Design_Click (10)
cmd_Open_Click (8)
cmd_Textbox_Click (4)
cmdRename_Click (62)
Declaration Lines (36)
fltrTablename_AfterUpdate (5)
Form_Load (24)
Form_Open (8)
Label_By_Click (6)
lstFieldname_AfterUpdate (61)
MakeTheChanges (37)
RowSource_Fieldlist (116)
RowSource_Tablename (76)
RowSource_TablenameForm (6)
Tablename_AfterUpdate (5)
Tablename_MouseUp (10)

Goto Top       Goto Index

Form_f_EMPLOYEE (58)

Declaration Lines (28)
fnd_EmpID_AfterUpdate (5)
Form_BeforeUpdate (25)

Goto Top       Goto Index

Form_f_EmpPapers_sub (49)

StatusID_GotFocus (42)
StatusID_LostFocus (6)

Goto Top       Goto Index

Form_f_GetDateRange (90)

ASDay (6)
ASMonth (6)
ASYear (6)
cmd_Clear_Click (6)
Date1_DblClick (5)
Date2_DblClick (6)
Declaration Lines (2)
FillDate (7)
FillMonth (6)
FillMTD (6)
FillOneWeek (6)
FillOneYear (6)
FillQuarter (9)
FillWorkWeek (7)
FillYTD (6)

Goto Top       Goto Index

Form_f_INVOICE (102)

CalculateTax (57)
CIDCust_AfterUpdate (12)
cmd_New_Click (17)
Declaration Lines (2)
dtio_DblClick (5)
Form_Current (4)
txtTaxRate_AfterUpdate (5)

Goto Top       Goto Index

Form_f_Invoice_Charges_sub (32)

AmtChg_AfterUpdate (30)
Declaration Lines (2)

Goto Top       Goto Index

Form_f_Invoice_sub_NEEDSWORK (236)

CalculateAmtTran (19)
Declaration Lines (52)
DtIDTran_DblClick (6)
EmpID_AfterUpdate (38)
Form_BeforeUpdate (6)
QtyTran_AfterUpdate (6)
QtyTyID_AfterUpdate (5)
SetTabStops (36)
TranTyID_AfterUpdate (63)
UnitCost_AfterUpdate (5)

Goto Top       Goto Index

Form_f_InvoiceDetail_sub (101)

Declaration Lines (2)
Form_AfterUpdate (30)
fraItmBy_AfterUpdate (46)
ItmID_AfterUpdate (11)
QtyShip_AfterUpdate (6)
UnitPric_AfterUpdate (6)

Goto Top       Goto Index

Form_f_INVOICEs_NEEDSWORK (61)

Declaration Lines (24)
fnd_Invoice_AfterUpdate (6)
fnd_PO_AfterUpdate (7)
fnd_Project_AfterUpdate (6)
Form_BeforeUpdate (6)
Form_Open (12)

Goto Top       Goto Index

Form_f_ITM (141)

cmd_Clear_fltr_ItmID__Click (6)
cmd_Close_Click (5)
Declaration Lines (28)
FilterMe (62)
fltr_ItmID__AfterUpdate (5)
Fnd_ItmID_Code_AfterUpdate (5)
Fnd_ItmID_Name_AfterUpdate (5)
Fnd_ItmID_SupCode_AfterUpdate (5)
Form_BeforeUpdate (5)
Form_Load (15)

Goto Top       Goto Index

Form_f_ITMs (137)

cmd_Clear_fltr_ItmID__Click (6)
cmd_Close_Click (6)
Declaration Lines (28)
FilterMe (58)
fltr_ItmID__AfterUpdate (5)
Fnd_ItmID_Code_AfterUpdate (5)
Fnd_ItmID_Name_AfterUpdate (7)
Fnd_ItmID_SupCode_AfterUpdate (5)
Form_BeforeUpdate (5)
ItmCode_DblClick (5)
OpenTheItem (7)

Goto Top       Goto Index

Form_f_MAIN_MENU (93)

cmd_Anywhere_Click (5)
cmd_Contacts_Click (8)
cmd_Customer_Click (9)
cmd_Demo_Click (4)
cmd_Employees_Click (9)
cmd_Followup_Click (4)
cmd_Prospects_Click (9)
cmd_Vendors_Click (9)
Declaration Lines (28)
Form_Open (8)

Goto Top       Goto Index

Form_f_MENU_HTMLCalendar (2,077)

ASDay (14)
ASMonth (6)
ASYear (6)
btn1_Click (16)
btnClearDates_Click (7)
btnClearEmail_Click (5)
cal_MoAdd_Click (5)
cal_Month_Click (5)
cal_MoSub_Click (5)
cal_MTD_Click (5)
cal_Q1_Click (5)
cal_Q2_Click (5)
cal_Q3_Click (5)
cal_Q4_Click (5)
cal_Today_Click (5)
cal_Week_Click (5)
cal_WorkWeek_Click (5)
cal_YrAdd_Click (5)
cal_YrSub_Click (5)
CalTitle_DblClick (5)
CheckDates (40)
CheckEmailOptions (14)
chkOpen_AfterUpdate (4)
ClearList (7)
CloseMeMe (8)
cmdAdd_eMail_Click (7)
Color3_AfterUpdate (5)
Color3B_AfterUpdate (5)
ColorMe (18)
Create_HTMLCalendar (533)
createXLSfile (14)
Date1_DblClick (5)
Date2_DblClick (5)
Declaration Lines (23)
Edit_TQ (17)
EmailAddress_AfterUpdate (5)
EmailTheReport (12)
Examples1_DblClick (4)
Examples2_DblClick (4)
Examples3_DblClick (4)
Examples4_DblClick (4)
Field1_AfterUpdate (4)
Field2_AfterUpdate (4)
Field3_AfterUpdate (5)
Field4_AfterUpdate (6)
FillDate (7)
FillMonth (6)
FillMTD (6)
FillOneWeek (6)
FillOneYear (6)
FillQuarter (9)
FillWorkWeek (7)
FillYTD (6)
Form_Load (27)
fraOutput_AfterUpdate (26)
FraTQ_AfterUpdate (4)
Generate_Index (128)
Generate_Index_TOC (84)
html_EndTime (8)
html_StartTime (9)
label_Footer1_DblClick (4)
label_Footer2_DblClick (4)
label_Footer3_DblClick (4)
label_Footer4_DblClick (4)
Label_writtenBy_Click (6)
ListTQ_AfterUpdate (5)
ListTQ_DblClick (5)
NewFooterText (13)
PopCalendarAndDoStuff (31)
Report_Calendar (136)
ResetData (59)
RFTtheReport (33)
setCritDates (65)
SQL_Examples (255)
SQL_Fields (116)
SQL_TQ (48)
UnderConstruction (4)
WriteHTMLfooter (26)
WriteHTMLheader (39)

Goto Top       Goto Index

Form_f_Payments_sub (88)

Declaration Lines (31)
DtIDTran_DblClick (57)

Goto Top       Goto Index

Form_f_PleaseWait (48)

CalculateProgress (35)
Declaration Lines (2)
lbl_Footer1_Click (6)
lbl_Footer2_Click (5)

Goto Top       Goto Index

Form_f_PopupCalendar (1,571)

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

Goto Top       Goto Index

Form_f_PRJECT (267)

cmd_MakeInvoice_Click (149)
cmd_New_Click (8)
cmd_Print_Click (6)
Declaration Lines (29)
fnd_Customer_AfterUpdate (5)
fnd_Expens_AfterUpdate (5)
fnd_Invoice_AfterUpdate (6)
fnd_Payment_AfterUpdate (6)
fnd_Project_AfterUpdate (6)
Form_BeforeUpdate (5)
Form_Current (15)
PrjDate1_DblClick (4)
PrjDate2_DblClick (4)
RowSource_LstInvoices (19)

Goto Top       Goto Index

Form_f_PROJECTs (264)

AirlineID_NotInList (12)
cmd_Add_Click (13)
cmd_Delete_Click (12)
CustomerID_NotInList (10)
Declaration Lines (28)
FleetID_GotFocus (13)
FleetID_LostFocus (5)
FleetID_NotInList (18)
fnd_PO_AfterUpdate (12)
fnd_Project_AfterUpdate (5)
Form_AfterUpdate (6)
Form_BeforeUpdate (23)
Form_Current (20)
Form_Load (10)
MakeID_NotInList (9)
ModelID_GotFocus (13)
ModelID_LostFocus (7)
ModelID_NotInList (17)
OemID_NotInList (10)
StatID_NotInList (10)
SysID_NotInList (11)

Goto Top       Goto Index

Form_f_PROSPECT (67)

Declaration Lines (28)
fnd_CID_AfterUpdate (7)
fnd_CustomerContact_AfterUpdate (6)
Form_BeforeUpdate (5)
Form_Current (21)

Goto Top       Goto Index

Form_f_SplashScreen (40)

Declaration Lines (2)
Form_Open (8)
Form_Timer (30)

Goto Top       Goto Index

Form_f_UnderConstruction (3)

Declaration Lines (3)

Goto Top       Goto Index

Form_f_VENDOR (68)

Declaration Lines (28)
fnd_CID_AfterUpdate (7)
fnd_CustomerContact_AfterUpdate (6)
Form_BeforeUpdate (6)
Form_Current (21)

Goto Top       Goto Index

Form_fc_AddrDates_sub (79)

cmd_Add_Click (11)
cmd_Del_Click (6)
Declaration Lines (33)
dtAdr2_DblClick (9)
Form_BeforeUpdate (20)

Goto Top       Goto Index

Form_fc_Addresses_sub (367)

Addr1_AfterUpdate (18)
Addr2_AfterUpdate (7)
adrNote_AfterUpdate (7)
adrNote_KeyDown (18)
Area_AfterUpdate (8)
City_AfterUpdate (7)
cmd_Add_Click (6)
cmd_Del_Click (25)
cmd_Map2_Click (9)
cmd_MapAddress_Click (9)
cmdNext_Click (7)
cmdPrev_Click (5)
Declaration Lines (42)
Form_AfterUpdate (61)
Form_BeforeUpdate (31)
Form_Current (19)
TypeID_NotInList (14)
TypIdAdr_NotInList (34)
Zip_AfterUpdate (33)
Zip_NotInList (7)

Goto Top       Goto Index

Form_fc_AnywhereAttachments (903)

AddURL (78)
BrowseToFile (136)
cmd_Add_Click (52)
cmd_AddURL_Click (56)
cmd_Browse_Click (11)
cmd_Close_Click (31)
cmd_Delete_Click (55)
cmd_OpenAttachment_Click (62)
CorrectWebAddress (21)
Declaration Lines (39)
DoesWebAddressStartRight (50)
fnd_Record_AfterUpdate (31)
Form_AfterUpdate (24)
Form_BeforeUpdate (49)
Form_Current (35)
Form_Open (40)
RequeryMyParent (9)
SynchronizeMyAttachments (124)

Goto Top       Goto Index

Form_fc_AnywhereNotes (385)

cmd_Close_Click (5)
cmd_SetAppt_Click (5)
Declaration Lines (36)
dtmDun_DblClick (5)
dtmNote_DblClick (5)
dtmToDo_DblClick (5)
fnd_Record_AfterUpdate (33)
Form_AfterUpdate (11)
Form_BeforeInsert (8)
Form_BeforeUpdate (23)
Form_Current (4)
Form_Open (49)
NoteDate_DblClick (5)
Subject_AfterUpdate (6)
SynchronizeMyNotes (180)
TypIDnote_NotInList (5)

Goto Top       Goto Index

Form_fc_AnywhereNotes_sub (366)

cmd_Close_Click (5)
Declaration Lines (36)
dtmDun_DblClick (5)
dtmNote_DblClick (5)
dtmToDo_DblClick (5)
fnd_Record_AfterUpdate (33)
Form_AfterUpdate (10)
Form_BeforeInsert (8)
Form_BeforeUpdate (23)
Form_Current (4)
Form_Open (41)
NoteDate_DblClick (5)
Subject_AfterUpdate (6)
SynchronizeMyNotes (175)
TypIDnote_NotInList (5)

Goto Top       Goto Index

Form_fc_Contact_Categories_sub (193)

cmd_Del_Click (51)
cmd_Edit_Click (9)
cmd_Mark_Click (27)
Declaration Lines (28)
DeleteCategory (44)
MarkCategory (34)

Goto Top       Goto Index

Form_fc_eAdr_sub (124)

cmd_Add_Click (7)
cmd_Del_Click (6)
Declaration Lines (46)
eAdr_BeforeUpdate (4)
eAdr_DblClick (11)
emaNote_AfterUpdate (7)
Form_BeforeUpdate (20)
TypIDead_NotInList (23)

Goto Top       Goto Index

Form_fc_List_sub (76)

CID_NotInList (5)
Declaration Lines (36)
fnd_List_AfterUpdate (7)
Form_AfterDelConfirm (8)
Form_BeforeUpdate (7)
ListName_AfterUpdate (5)
listNote_AfterUpdate (8)

Goto Top       Goto Index

Form_fc_LISTS (87)

cmd_Add_Click (7)
cmd_Del_Click (9)
Declaration Lines (37)
FindList_AfterUpdate (4)
Form_AfterDelConfirm (5)
Form_AfterUpdate (25)

Goto Top       Goto Index

Form_fc_Lists_Members_sub (58)

Declaration Lines (38)
Form_BeforeUpdate (8)
TyCID_NotInList (12)

Goto Top       Goto Index

Form_fc_Lists_PickMembers_sub (106)

Declaration Lines (35)
Form_BeforeUpdate (5)
HighlightBox_Click (4)
PickMember (58)
Used_MouseUp (4)

Goto Top       Goto Index

Form_fc_MbrLists_sub (154)

cmd_Add_Click (6)
cmd_Del_Click (7)
Declaration Lines (47)
Form_BeforeUpdate (18)
Initialize_ListID (5)
ListID_BeforeUpdate (9)
ListID_NotInList (50)
MbrNote_AfterUpdate (5)
TypIDmbr_NotInList (7)

Goto Top       Goto Index

Form_fc_MENU_CONTACT (1,679)

CatIDc_KeyDown (21)
CatIDc_NotInList (50)
chkProperCase_AfterUpdate (12)
CID__AfterUpdate (5)
CID__DblClick (16)
CID__NotInList (8)
cmd_Add_Click (34)
cmd_Address_Click (4)
cmd_Address_GotFocus (5)
cmd_Admin_Click (5)
cmd_Binoculars_Click (21)
cmd_Clear_fltr_cCatID_Click (9)
cmd_Close_Click (7)
cmd_ContactCategories_Click (10)
cmd_Del_Click (107)
cmd_eMail_Click (8)
cmd_Items_Click (5)
cmd_Lists_Click (6)
cmd_Next_Click (4)
cmd_Phone_Click (11)
cmd_Previous_Click (7)
cmd_Rpt_Addresses_Click (5)
cmd_Rpt_Avery5160_Click (5)
cmd_Rpt_Birthdays_Click (5)
cmd_Rpt_ClearCriteria_Click (17)
cmd_Rpt_CompanyContacts_Click (5)
cmd_Rpt_Contacts_Click (5)
cmd_Rpt_MyCompanyInformation_Click (5)
cmd_Rpt_Notes_Click (6)
cmd_Rpt_Phone_2col_Click (5)
cmdSwitch_Click (13)
Declaration Lines (42)
fc_eAdr_sub_Enter (5)
fc_eAdr_sub_Exit (33)
FilterMyFind (140)
FindMyContact (95)
fltr_cCatID_AfterUpdate (5)
fnd_AdrID_AfterUpdate (90)
fnd_Name_DblClick (6)
Form_AfterDelConfirm (4)
Form_AfterUpdate (11)
Form_BeforeUpdate (68)
Form_Current (47)
Form_Load (67)
Form_Open (53)
Form_Unload (20)
GotToAddress (9)
ImageCalendar_Click (8)
IsHuman_AfterUpdate (5)
Label_emailCrystal_Click (7)
Label_thanks_Click (7)
Label_Tips_Click (6)
lst_CompanyContacts_AfterUpdate (38)
MainName_AfterUpdate (6)
MoveToRecord (72)
NameA_AfterUpdate (6)
NameB_AfterUpdate (11)
NickName_AfterUpdate (6)
OpenFindPeople (11)
OpenTheReport (210)
RequeryMyStuff (20)
runFindMyContact (77)
SetCurrentStuff (37)
ShowHuman (13)
SynchronizeOtherForms (18)

Goto Top       Goto Index

Form_fc_Notes_sub (65)

Declaration Lines (36)
dtmDun_DblClick (5)
dtmNote_DblClick (6)
Form_BeforeUpdate (7)
Subject_AfterUpdate (6)
TypIDnote_NotInList (5)

Goto Top       Goto Index

Form_fc_Phones_sub (195)

cmd_Add_Click (14)
cmd_Address_Click (5)
cmd_Del_Click (6)
cmd_PastePhone_Click (31)
Declaration Lines (41)
Form_BeforeUpdate (29)
IMPhone_AfterUpdate (13)
Phone_AfterUpdate (6)
Phone_GotFocus (6)
phoNote_AfterUpdate (6)
SetPhoneMask (11)
TypIdPho_NotInList (27)

Goto Top       Goto Index

Form_fc_PikPeople (418)

AZ_ZA_AfterUpdate (5)
BoldControl (25)
chkActive_AfterUpdate (5)
ClearLetters (5)
cmd_Reset_Click (13)
Declaration Lines (31)
FindRecord (45)
Form_Load (32)
Form_Open (18)
fraSort_AfterUpdate (5)
fraWhen_AfterUpdate (7)
ResetLetters (4)
set_RowSource_Names (216)
set_RowSource_Names_FindPeople (7)

Goto Top       Goto Index

Form_fc_pop_Appointment (139)

cmd_Cancel_Click (13)
cmd_OK_Click (23)
Declaration Lines (2)
dtmAppt_AfterUpdate (34)
Form_AfterUpdate (45)
Form_BeforeUpdate (22)

Goto Top       Goto Index

Form_fc_Popup_AddContact (302)

cmd_Cancel_Click (13)
cmd_OK_Click (17)
Declaration Lines (33)
Form_AfterUpdate (57)
Form_BeforeUpdate (167)
MarkHuman (15)

Goto Top       Goto Index

Form_fc_Tables (67)

cmd_Design_Click (33)
Declaration Lines (2)
FldAuto_combo_AfterUpdate (6)
FldRoll_combo_AfterUpdate (6)
Form_Current (16)
Tbl_AfterUpdate (4)

Goto Top       Goto Index

Form_fc_templateAnywhere (37)

Declaration Lines (2)
Form_BeforeUpdate (30)
Form_Open (5)

Goto Top       Goto Index

Form_fc_ViewAddress_sub (44)

cmd_Edit_Click (31)
Declaration Lines (2)
Form_Open (11)

Goto Top       Goto Index

Form_fc_Websites_sub (261)

cmd_Add_Click (7)
cmd_Del_Click (6)
Declaration Lines (49)
Form_BeforeUpdate (89)
GotoWebsite (34)
TypID_NotInList (20)
URL_DblClick (56)

Goto Top       Goto Index

Form_usys_f_PickUser__NOTUSED (94)

cdmClose_Click (30)
cmd_NavigationPane_Click (5)
cmdExit_Click (5)
Declaration Lines (2)
Form_Load (11)
Form_Open (16)
UsrID_AfterUpdate (16)
UsrID_BeforeUpdate (9)

Goto Top       Goto Index

Form_usys_fPw (52)

cmd_Cancel_Click (30)
cmd_OK_Click (8)
Declaration Lines (2)
Form_Open (12)

Goto Top       Goto Index

mod_crystal_DataDICTIONARY_DisplayControl (613)

dd_CanGet_ObjectProperty (45)
dd_CanGet_PropertyValue (61)
dd_ClearList (20)
dd_GetControlType (40)
dd_GetDataType (55)
dd_GetPropertyValue (27)
dd_SetDisplayControlCheckbox (66)
dd_SetDisplayControlTextbox (69)
Declaration Lines (33)
Get_CorrectName (134)
GetTableFlags (33)
IsExclusive (5)
IsHidden (5)
IsLinked (5)
IsODBC (5)
IsSavePW (5)
IsSystem (5)

Goto Top       Goto Index

mod_crystal_GetFile_Browse (157)

Declaration Lines (32)
GetFile_Browse (125)

Goto Top       Goto Index

mod_DocumentQueryCalculatedFields_Crystal (284)

Declaration Lines (2)
DocumentQueryCalculatedFields (282)

Goto Top       Goto Index

mod_helper_HTMLcalendar (653)

CorrectCase (20)
CorrectFilename (25)
GetDataType (608)

Goto Top       Goto Index

mod_local_Anywhere (880)

AttachNote (269)
Declaration Lines (2)
FindRecordNsub (28)
Form_Current (23)
GetAttachmentPath (51)
GetMax (32)
GetMin (36)
GetNameFromURL (48)
GetTheURL (16)
GetWholePathFile (45)
PopAttachments (24)
popNotes (43)
run_SaveAttachmentsToFiles (20)
SaveAttachmentsToFiles (200)
testGetNameFromURL (43)

Goto Top       Goto Index

mod_local_Contacts (463)

Declaration Lines (2)
DeleteRecords (68)
GetAddressFromForm (22)
GetAddressShort (18)
GetAge (13)
GetAgeYMD (26)
GetBirthdayNext (26)
GetBirthdayThisYr (16)
GetCategoryOrder (45)
GetFullName (95)
PutTextOnClipboard (132)

Goto Top       Goto Index

mod_local_ui (266)

Declaration Lines (33)
NotInList_Aircraft_fromPrj (67)
SetCriteria4AC (166)

Goto Top       Goto Index

mod_PlaySound (33)

API_PlaySound (11)
Declaration Lines (11)
PlayWelcome (11)

Goto Top       Goto Index

mod_SaveCSVasExcel (135)

Declaration Lines (2)
SaveCSVasExcel (42)
SaveCSVasExcel_WBobject (50)
testSaveCSVasExcel (41)

Goto Top       Goto Index

mod_SubDatasheet (105)

Declaration Lines (2)
SetSubDatasheetNone (103)

Goto Top       Goto Index

mod_TerryKreft_API_Clipboard_Copy_Paste (208)

ClipBoard_GetText (30)
ClipBoard_SetText (27)
CopyOlePiccy (43)
Declaration Lines (108)

Goto Top       Goto Index

mod_UI (789)

AskSaveTheChanges (33)
AttachNote (18)
BehaviorEnteringField (6)
DataSheet_ColumnWidth (32)
Declaration Lines (2)
FormBeforeUpdate (74)
GetObjectType (16)
GetResponse_NIL (71)
GetSQL_ORDERBY (70)
GetSQL_WHERE (103)
IsValueUnique (22)
myFormOpenEvent (71)
NotInList_general (96)
OpenShortcuts (5)
PopCalendar (9)
SetControl_RowSource (70)
StripPhoneNonNumeric (17)
ToggleProperCase (13)
TypeID_NIL (61)

Goto Top       Goto Index

Report_r_ADDRESSES (40)

Declaration Lines (12)
GroupFooter1_Format (5)
Report_NoData (7)
Report_Open (10)
ReportFooter_Format (6)

Goto Top       Goto Index

Report_r_addresses_sub (3)

Declaration Lines (3)

Goto Top       Goto Index

Report_r_BIRTHDAYS (35)

Declaration Lines (12)
Report_NoData (6)
Report_Open (10)
ReportFooter_Format (7)

Goto Top       Goto Index

Report_r_COMPANY_CONTACTS (36)

Declaration Lines (12)
Report_NoData (6)
Report_Open (10)
ReportFooter_Format (8)

Goto Top       Goto Index

Report_r_CONTACTS (41)

Declaration Lines (12)
GroupFooter3_Format (5)
Report_NoData (6)
Report_Open (10)
ReportFooter_Format (8)

Goto Top       Goto Index

Report_r_emailaddresses_sub (3)

Declaration Lines (3)

Goto Top       Goto Index

Report_r_Notes (24)

Declaration Lines (2)
Report_NoData (6)
Report_Open (10)
ReportFooter_Format (6)

Goto Top       Goto Index

Report_r_PHONES_2col (36)

Declaration Lines (12)
Report_NoData (6)
Report_Open (10)
ReportFooter_Format (8)

Goto Top       Goto Index

Report_r_PHONES_3col (36)

Declaration Lines (12)
Report_NoData (6)
Report_Open (10)
ReportFooter_Format (8)

Goto Top       Goto Index

Report_r_phones_sub (3)

Declaration Lines (3)

Goto Top       Goto Index

Report_r_web_sub (3)

Declaration Lines (3)

Goto Top       Goto Index

Report_rc_Avery5160 (27)

Declaration Lines (2)
Report_NoData (6)
Report_Open (10)
ReportFooter_Format (9)

Procedure name, Module name

   A    B    C    D    E    F    G    H    I    L    M    N    O    P    Q    R    S    T    U    W    Z

Goto Top       Goto Index       Procedure name, Module name      
A
Add_SetCalendar (32) , Form_f_Calendar_sub (1,014)
Add_SetCalendar (30) , Form_f_PopupCalendar (1,571)
AddFieldDesc (69) , bas_crystal_code_general_1308 (2,724)
AddFieldToTable (140) , bas_crystal_code_general_1308 (2,724)
Addr1_AfterUpdate (18) , Form_fc_Addresses_sub (367)
Addr2_AfterUpdate (7) , Form_fc_Addresses_sub (367)
AddTextToTableDescription (88) , bas_Crystal_ReLinker_140629_080726_1001 (1,250)
AddURL (78) , Form_fc_AnywhereAttachments (903)
adrNote_AfterUpdate (7) , Form_fc_Addresses_sub (367)
adrNote_KeyDown (18) , Form_fc_Addresses_sub (367)
AirlineID_NotInList (12) , Form_f_PROJECTs (264)
AmPm (9) , Form_f_PopupCalendar (1,571)
AmtChg_AfterUpdate (30) , Form_f_Invoice_Charges_sub (32)
API_PlaySound (11) , mod_PlaySound (33)
Area_AfterUpdate (8) , Form_fc_Addresses_sub (367)
ASDay (6) , Form_f_GetDateRange (90)
ASDay (14) , Form_f_MENU_HTMLCalendar (2,077)
AskSaveTheChanges (33) , mod_UI (789)
ASMonth (6) , Form_f_GetDateRange (90)
ASMonth (6) , Form_f_MENU_HTMLCalendar (2,077)
ASYear (6) , Form_f_GetDateRange (90)
ASYear (6) , Form_f_MENU_HTMLCalendar (2,077)
AttachNote (269) , mod_local_Anywhere (880)
AttachNote (18) , mod_UI (789)
AZ_ZA_AfterUpdate (5) , Form_fc_PikPeople (418)

Goto Top       Goto Index       Procedure name, Module name       A
B
BehaviorEnteringField (6) , mod_UI (789)
BoldControl (25) , Form_fc_PikPeople (418)
BoldMe (208) , bas_crystal_code_general_1308 (2,724)
BrowseToFile (136) , Form_fc_AnywhereAttachments (903)
btn1_Click (16) , Form_f_MENU_HTMLCalendar (2,077)
btnClearDates_Click (7) , Form_f_MENU_HTMLCalendar (2,077)
btnClearEmail_Click (5) , Form_f_MENU_HTMLCalendar (2,077)

Goto Top       Goto Index       Procedure name, Module name       B
C
cal_GetBirthstone (19) , Form_f_PopupCalendar (1,571)
cal_GetCardinalNumber (28) , Form_f_Calendar_sub (1,014)
cal_GetCardinalNumber (28) , Form_f_PopupCalendar (1,571)
cal_GetCol4Calendar (5) , Form_f_Calendar_sub (1,014)
cal_GetCol4Calendar (5) , Form_f_PopupCalendar (1,571)
cal_GetDowN4Calendar (26) , Form_f_Calendar_sub (1,014)
cal_GetDowN4Calendar (26) , Form_f_PopupCalendar (1,571)
cal_GetRoman (51) , Form_f_Calendar_sub (1,014)
cal_GetRoman (51) , Form_f_PopupCalendar (1,571)
cal_GetRow4Calendar (38) , Form_f_Calendar_sub (1,014)
cal_GetRow4Calendar (38) , Form_f_PopupCalendar (1,571)
cal_IsSubform (17) , Form_f_Calendar_sub (1,014)
cal_IsSubform (17) , Form_f_PopupCalendar (1,571)
cal_MoAdd_Click (5) , Form_f_MENU_HTMLCalendar (2,077)
cal_Month_Click (5) , Form_f_MENU_HTMLCalendar (2,077)
cal_MoSub_Click (5) , Form_f_MENU_HTMLCalendar (2,077)
cal_MTD_Click (5) , Form_f_MENU_HTMLCalendar (2,077)
cal_Q1_Click (5) , Form_f_MENU_HTMLCalendar (2,077)
cal_Q2_Click (5) , Form_f_MENU_HTMLCalendar (2,077)
cal_Q3_Click (5) , Form_f_MENU_HTMLCalendar (2,077)
cal_Q4_Click (5) , Form_f_MENU_HTMLCalendar (2,077)
cal_ShowHideControlsTag (34) , Form_f_Calendar_sub (1,014)
cal_ShowHideControlsTag (34) , Form_f_PopupCalendar (1,571)
cal_Today_Click (5) , Form_f_MENU_HTMLCalendar (2,077)
cal_Week_Click (5) , Form_f_MENU_HTMLCalendar (2,077)
cal_WorkWeek_Click (5) , Form_f_MENU_HTMLCalendar (2,077)
cal_YrAdd_Click (5) , Form_f_MENU_HTMLCalendar (2,077)
cal_YrSub_Click (5) , Form_f_MENU_HTMLCalendar (2,077)
CalculateAmtTran (19) , Form_f_Invoice_sub_NEEDSWORK (236)
CalculateProgress (35) , Form_f_PleaseWait (48)
CalculateTax (57) , Form_f_INVOICE (102)
CalTitle_DblClick (5) , Form_f_MENU_HTMLCalendar (2,077)
CancelMe (11) , bas_crystal_code_general_1308 (2,724)
CapString (14) , bas_crystal_code_general_1308 (2,724)
CatIDc_KeyDown (21) , Form_fc_MENU_CONTACT (1,679)
CatIDc_NotInList (50) , Form_fc_MENU_CONTACT (1,679)
cdmClose_Click (30) , Form_usys_f_PickUser__NOTUSED (94)
ChangeTableDescriptions_ConnectInfo (133) , bas_Crystal_ReLinker_140629_080726_1001 (1,250)
CheckDates (40) , Form_f_MENU_HTMLCalendar (2,077)
CheckEmailOptions (14) , Form_f_MENU_HTMLCalendar (2,077)
chkActive_AfterUpdate (5) , Form_fc_PikPeople (418)
chkExclusive_Click (5) , Form_f_DataDICTIONARY_DisplayControl (507)
chkHid_Click (5) , Form_f_DataDICTIONARY_DisplayControl (507)
chkLinked_Click (5) , Form_f_DataDICTIONARY_DisplayControl (507)
chkODBC_Click (5) , Form_f_DataDICTIONARY_DisplayControl (507)
chkOpen_AfterUpdate (4) , Form_f_MENU_HTMLCalendar (2,077)
chkProperCase_AfterUpdate (12) , Form_fc_MENU_CONTACT (1,679)
chkSavePW_Click (5) , Form_f_DataDICTIONARY_DisplayControl (507)
chkSys_AfterUpdate (4) , Form_f_DataDICTIONARY_DisplayControl (507)
CID__AfterUpdate (5) , Form_fc_MENU_CONTACT (1,679)
CID__DblClick (16) , Form_fc_MENU_CONTACT (1,679)
CID__NotInList (8) , Form_fc_MENU_CONTACT (1,679)
CID_NotInList (5) , Form_fc_List_sub (76)
CIDCust_AfterUpdate (12) , Form_f_INVOICE (102)
City_AfterUpdate (7) , Form_fc_Addresses_sub (367)
ClearLetters (5) , Form_fc_PikPeople (418)
ClearList (17) , bas_crystal_code_general_1308 (2,724)
ClearList (7) , Form_f_MENU_HTMLCalendar (2,077)
ClipBoard_GetText (30) , mod_TerryKreft_API_Clipboard_Copy_Paste (208)
ClipBoard_SetText (27) , mod_TerryKreft_API_Clipboard_Copy_Paste (208)
CloseMe (46) , bas_crystal_code_general_1308 (2,724)
CloseMeMe (8) , Form_f_MENU_HTMLCalendar (2,077)
ClosePleaseWait (7) , bas_PleaseWait (47)
cmd_Add_Click (8) , Form_f_CUSTOMER (95)
cmd_Add_Click (13) , Form_f_PROJECTs (264)
cmd_Add_Click (11) , Form_fc_AddrDates_sub (79)
cmd_Add_Click (6) , Form_fc_Addresses_sub (367)
cmd_Add_Click (52) , Form_fc_AnywhereAttachments (903)
cmd_Add_Click (7) , Form_fc_eAdr_sub (124)
cmd_Add_Click (7) , Form_fc_LISTS (87)
cmd_Add_Click (6) , Form_fc_MbrLists_sub (154)
cmd_Add_Click (34) , Form_fc_MENU_CONTACT (1,679)
cmd_Add_Click (14) , Form_fc_Phones_sub (195)
cmd_Add_Click (7) , Form_fc_Websites_sub (261)
cmd_AddDays_Click (27) , Form_f_PopupCalendar (1,571)
cmd_Address_Click (4) , Form_fc_MENU_CONTACT (1,679)
cmd_Address_Click (5) , Form_fc_Phones_sub (195)
cmd_Address_GotFocus (5) , Form_fc_MENU_CONTACT (1,679)
cmd_AddURL_Click (56) , Form_fc_AnywhereAttachments (903)
cmd_Admin_Click (5) , Form_fc_MENU_CONTACT (1,679)
cmd_Anywhere_Click (5) , Form_f_MAIN_MENU (93)
cmd_Attachments_Click (15) , Form_f_AnywhereMENU (401)
cmd_AttachNote_Click (20) , Form_f_AnywhereMENU (401)
cmd_Binoculars_Click (21) , Form_fc_MENU_CONTACT (1,679)
cmd_Browse_Click (11) , Form_fc_AnywhereAttachments (903)
cmd_Browse_PathBE_Click (41) , Form_f_ADMIN (1,024)
cmd_Cancel_Click (5) , Form_f_ADMIN (1,024)
cmd_Cancel_Click (6) , Form_f_PopupCalendar (1,571)
cmd_Cancel_Click (13) , Form_fc_pop_Appointment (139)
cmd_Cancel_Click (13) , Form_fc_Popup_AddContact (302)
cmd_Cancel_Click (30) , Form_usys_fPw (52)
cmd_Checkbox_Click (4) , Form_f_DataDICTIONARY_DisplayControl (507)
cmd_Clear_Click (6) , Form_f_GetDateRange (90)
cmd_Clear_fltr_cCatID_Click (9) , Form_fc_MENU_CONTACT (1,679)
cmd_Clear_fltr_ItmID__Click (6) , Form_f_ITM (141)
cmd_Clear_fltr_ItmID__Click (6) , Form_f_ITMs (137)
cmd_ClearFilter_Click (6) , Form_f_AnywhereMENU (401)
cmd_Close_Click (5) , Form_f_ITM (141)
cmd_Close_Click (6) , Form_f_ITMs (137)
cmd_Close_Click (37) , Form_f_PopupCalendar (1,571)
cmd_Close_Click (31) , Form_fc_AnywhereAttachments (903)
cmd_Close_Click (5) , Form_fc_AnywhereNotes (385)
cmd_Close_Click (5) , Form_fc_AnywhereNotes_sub (366)
cmd_Close_Click (7) , Form_fc_MENU_CONTACT (1,679)
cmd_ContactCategories_Click (10) , Form_fc_MENU_CONTACT (1,679)
cmd_Contacts_Click (8) , Form_f_MAIN_MENU (93)
cmd_CurrentTime_Click (11) , Form_f_PopupCalendar (1,571)
cmd_Customer_Click (9) , Form_f_MAIN_MENU (93)
cmd_Del_Click (5) , Form_f_CUSTOMER (95)
cmd_Del_Click (6) , Form_fc_AddrDates_sub (79)
cmd_Del_Click (25) , Form_fc_Addresses_sub (367)
cmd_Del_Click (51) , Form_fc_Contact_Categories_sub (193)
cmd_Del_Click (6) , Form_fc_eAdr_sub (124)
cmd_Del_Click (9) , Form_fc_LISTS (87)
cmd_Del_Click (7) , Form_fc_MbrLists_sub (154)
cmd_Del_Click (107) , Form_fc_MENU_CONTACT (1,679)
cmd_Del_Click (6) , Form_fc_Phones_sub (195)
cmd_Del_Click (6) , Form_fc_Websites_sub (261)
cmd_Delete_Click (12) , Form_f_PROJECTs (264)
cmd_Delete_Click (55) , Form_fc_AnywhereAttachments (903)
cmd_DeleteData_Click (5) , Form_f_ADMIN (1,024)
cmd_Demo_Click (4) , Form_f_MAIN_MENU (93)
cmd_Design_Click (8) , Form_f_AnywhereMENU (401)
cmd_Design_Click (10) , Form_f_DataDICTIONARY_DisplayControl (507)
cmd_Design_Click (33) , Form_fc_Tables (67)
cmd_Edit_Click (9) , Form_fc_Contact_Categories_sub (193)
cmd_Edit_Click (31) , Form_fc_ViewAddress_sub (44)
cmd_eMail_Click (8) , Form_fc_MENU_CONTACT (1,679)
cmd_Employees_Click (9) , Form_f_MAIN_MENU (93)
cmd_Followup_Click (4) , Form_f_MAIN_MENU (93)
cmd_Items_Click (5) , Form_fc_MENU_CONTACT (1,679)
cmd_Lists_Click (6) , Form_fc_MENU_CONTACT (1,679)
cmd_M6add_Click (20) , Form_f_PopupCalendar (1,571)
cmd_M6sub_Click (19) , Form_f_PopupCalendar (1,571)
cmd_MakeInvoice_Click (149) , Form_f_PRJECT (267)
cmd_Map2_Click (9) , Form_fc_Addresses_sub (367)
cmd_MapAddress_Click (9) , Form_fc_Addresses_sub (367)
cmd_Mark_Click (27) , Form_fc_Contact_Categories_sub (193)
cmd_NavigationPane_Click (7) , Form_f_ADMIN (1,024)
cmd_NavigationPane_Click (5) , Form_usys_f_PickUser__NOTUSED (94)
cmd_New_Click (17) , Form_f_INVOICE (102)
cmd_New_Click (8) , Form_f_PRJECT (267)
cmd_Next_Click (4) , Form_fc_MENU_CONTACT (1,679)
cmd_Now_Click (18) , Form_f_PopupCalendar (1,571)
cmd_OK_Click (23) , Form_fc_pop_Appointment (139)
cmd_OK_Click (17) , Form_fc_Popup_AddContact (302)
cmd_OK_Click (8) , Form_usys_fPw (52)
cmd_Open_Click (8) , Form_f_AnywhereMENU (401)
cmd_Open_Click (8) , Form_f_DataDICTIONARY_DisplayControl (507)
cmd_OpenAttachment_Click (62) , Form_fc_AnywhereAttachments (903)
cmd_OpenUsers_Click (12) , Form_f_ADMIN (1,024)
cmd_PastePhone_Click (31) , Form_fc_Phones_sub (195)
cmd_Phone_Click (11) , Form_fc_MENU_CONTACT (1,679)
cmd_Previous_Click (7) , Form_fc_MENU_CONTACT (1,679)
cmd_Print_Click (6) , Form_f_PRJECT (267)
cmd_Prospects_Click (9) , Form_f_MAIN_MENU (93)
cmd_Q1add_Click (14) , Form_f_PopupCalendar (1,571)
cmd_Q1sub_Click (14) , Form_f_PopupCalendar (1,571)
cmd_Relink_Click (17) , Form_f_ADMIN (1,024)
cmd_Reset_Click (31) , Form_f_PopupCalendar (1,571)
cmd_Reset_Click (13) , Form_fc_PikPeople (418)
cmd_Rpt_Addresses_Click (5) , Form_fc_MENU_CONTACT (1,679)
cmd_Rpt_Avery5160_Click (5) , Form_fc_MENU_CONTACT (1,679)
cmd_Rpt_Birthdays_Click (5) , Form_fc_MENU_CONTACT (1,679)
cmd_Rpt_ClearCriteria_Click (17) , Form_fc_MENU_CONTACT (1,679)
cmd_Rpt_CompanyContacts_Click (5) , Form_fc_MENU_CONTACT (1,679)
cmd_Rpt_Contacts_Click (5) , Form_fc_MENU_CONTACT (1,679)
cmd_Rpt_MyCompanyInformation_Click (5) , Form_fc_MENU_CONTACT (1,679)
cmd_Rpt_Notes_Click (6) , Form_fc_MENU_CONTACT (1,679)
cmd_Rpt_Phone_2col_Click (5) , Form_fc_MENU_CONTACT (1,679)
cmd_SaveClose_Click (113) , Form_f_ADMIN (1,024)
cmd_SetAppt_Click (5) , Form_fc_AnywhereNotes (385)
cmd_Textbox_Click (4) , Form_f_DataDICTIONARY_DisplayControl (507)
cmd_Today_Click (17) , Form_f_PopupCalendar (1,571)
cmd_Vendors_Click (9) , Form_f_MAIN_MENU (93)
cmd_W1add_Click (19) , Form_f_PopupCalendar (1,571)
cmd_W1sub_Click (19) , Form_f_PopupCalendar (1,571)
cmd_Y10add_Click (14) , Form_f_PopupCalendar (1,571)
cmd_Y10sub_Click (14) , Form_f_PopupCalendar (1,571)
cmd11_Click (4) , Form_f_Calendar_sub (1,014)
cmd11_Click (4) , Form_f_PopupCalendar (1,571)
cmd12_Click (4) , Form_f_Calendar_sub (1,014)
cmd12_Click (4) , Form_f_PopupCalendar (1,571)
cmd13_Click (4) , Form_f_Calendar_sub (1,014)
cmd13_Click (4) , Form_f_PopupCalendar (1,571)
cmd14_Click (4) , Form_f_Calendar_sub (1,014)
cmd14_Click (4) , Form_f_PopupCalendar (1,571)
cmd15_Click (4) , Form_f_Calendar_sub (1,014)
cmd15_Click (4) , Form_f_PopupCalendar (1,571)
cmd16_Click (4) , Form_f_Calendar_sub (1,014)
cmd16_Click (4) , Form_f_PopupCalendar (1,571)
cmd17_Click (4) , Form_f_Calendar_sub (1,014)
cmd17_Click (4) , Form_f_PopupCalendar (1,571)
cmd21_Click (4) , Form_f_Calendar_sub (1,014)
cmd21_Click (4) , Form_f_PopupCalendar (1,571)
cmd22_Click (4) , Form_f_Calendar_sub (1,014)
cmd22_Click (4) , Form_f_PopupCalendar (1,571)
cmd23_Click (4) , Form_f_Calendar_sub (1,014)
cmd23_Click (4) , Form_f_PopupCalendar (1,571)
cmd24_Click (4) , Form_f_Calendar_sub (1,014)
cmd24_Click (4) , Form_f_PopupCalendar (1,571)
cmd25_Click (4) , Form_f_Calendar_sub (1,014)
cmd25_Click (4) , Form_f_PopupCalendar (1,571)
cmd26_Click (4) , Form_f_Calendar_sub (1,014)
cmd26_Click (4) , Form_f_PopupCalendar (1,571)
cmd27_Click (4) , Form_f_Calendar_sub (1,014)
cmd27_Click (4) , Form_f_PopupCalendar (1,571)
cmd31_Click (4) , Form_f_Calendar_sub (1,014)
cmd31_Click (4) , Form_f_PopupCalendar (1,571)
cmd32_Click (4) , Form_f_Calendar_sub (1,014)
cmd32_Click (4) , Form_f_PopupCalendar (1,571)
cmd33_Click (4) , Form_f_Calendar_sub (1,014)
cmd33_Click (4) , Form_f_PopupCalendar (1,571)
cmd34_Click (4) , Form_f_Calendar_sub (1,014)
cmd34_Click (4) , Form_f_PopupCalendar (1,571)
cmd35_Click (4) , Form_f_Calendar_sub (1,014)
cmd35_Click (4) , Form_f_PopupCalendar (1,571)
cmd36_Click (4) , Form_f_Calendar_sub (1,014)
cmd36_Click (4) , Form_f_PopupCalendar (1,571)
cmd37_Click (4) , Form_f_Calendar_sub (1,014)
cmd37_Click (4) , Form_f_PopupCalendar (1,571)
cmd41_Click (4) , Form_f_Calendar_sub (1,014)
cmd41_Click (4) , Form_f_PopupCalendar (1,571)
cmd42_Click (4) , Form_f_Calendar_sub (1,014)
cmd42_Click (4) , Form_f_PopupCalendar (1,571)
cmd43_Click (4) , Form_f_Calendar_sub (1,014)
cmd43_Click (4) , Form_f_PopupCalendar (1,571)
cmd44_Click (4) , Form_f_Calendar_sub (1,014)
cmd44_Click (4) , Form_f_PopupCalendar (1,571)
cmd45_Click (4) , Form_f_Calendar_sub (1,014)
cmd45_Click (4) , Form_f_PopupCalendar (1,571)
cmd46_Click (4) , Form_f_Calendar_sub (1,014)
cmd46_Click (4) , Form_f_PopupCalendar (1,571)
cmd47_Click (4) , Form_f_Calendar_sub (1,014)
cmd47_Click (4) , Form_f_PopupCalendar (1,571)
cmd51_Click (4) , Form_f_Calendar_sub (1,014)
cmd51_Click (4) , Form_f_PopupCalendar (1,571)
cmd52_Click (4) , Form_f_Calendar_sub (1,014)
cmd52_Click (4) , Form_f_PopupCalendar (1,571)
cmd53_Click (4) , Form_f_Calendar_sub (1,014)
cmd53_Click (4) , Form_f_PopupCalendar (1,571)
cmd54_Click (4) , Form_f_Calendar_sub (1,014)
cmd54_Click (4) , Form_f_PopupCalendar (1,571)
cmd55_Click (4) , Form_f_Calendar_sub (1,014)
cmd55_Click (4) , Form_f_PopupCalendar (1,571)
cmd56_Click (4) , Form_f_Calendar_sub (1,014)
cmd56_Click (4) , Form_f_PopupCalendar (1,571)
cmd57_Click (4) , Form_f_Calendar_sub (1,014)
cmd57_Click (4) , Form_f_PopupCalendar (1,571)
cmd61_Click (4) , Form_f_Calendar_sub (1,014)
cmd61_Click (4) , Form_f_PopupCalendar (1,571)
cmd62_Click (4) , Form_f_Calendar_sub (1,014)
cmd62_Click (4) , Form_f_PopupCalendar (1,571)
cmd63_Click (4) , Form_f_Calendar_sub (1,014)
cmd63_Click (4) , Form_f_PopupCalendar (1,571)
cmd64_Click (4) , Form_f_Calendar_sub (1,014)
cmd64_Click (4) , Form_f_PopupCalendar (1,571)
cmd65_Click (4) , Form_f_Calendar_sub (1,014)
cmd65_Click (4) , Form_f_PopupCalendar (1,571)
cmd66_Click (4) , Form_f_Calendar_sub (1,014)
cmd66_Click (4) , Form_f_PopupCalendar (1,571)
cmd67_Click (4) , Form_f_Calendar_sub (1,014)
cmd67_Click (4) , Form_f_PopupCalendar (1,571)
cmdAdd_eMail_Click (7) , Form_f_MENU_HTMLCalendar (2,077)
cmdDayAdd_Click (18) , Form_f_Calendar_sub (1,014)
cmdDayAdd_Click (18) , Form_f_PopupCalendar (1,571)
cmdDaySub_Click (19) , Form_f_Calendar_sub (1,014)
cmdDaySub_Click (19) , Form_f_PopupCalendar (1,571)
cmdExit_Click (5) , Form_f_ADMIN (1,024)
cmdExit_Click (5) , Form_usys_f_PickUser__NOTUSED (94)
cmdMonth_Click (7) , Form_f_PopupCalendar (1,571)
cmdMonthAdd_Click (23) , Form_f_Calendar_sub (1,014)
cmdMonthAdd_Click (19) , Form_f_PopupCalendar (1,571)
cmdMonthSub_Click (16) , Form_f_Calendar_sub (1,014)
cmdMonthSub_Click (16) , Form_f_PopupCalendar (1,571)
cmdNext_Click (7) , Form_fc_Addresses_sub (367)
cmdPrev_Click (5) , Form_fc_Addresses_sub (367)
cmdRename_Click (62) , Form_f_DataDICTIONARY_DisplayControl (507)
cmdSwitch_Click (13) , Form_fc_MENU_CONTACT (1,679)
cmdYr_Click (10) , Form_f_PopupCalendar (1,571)
cmdYrAdd_Click (20) , Form_f_Calendar_sub (1,014)
cmdYrAdd_Click (20) , Form_f_PopupCalendar (1,571)
cmdYrSub_Click (19) , Form_f_Calendar_sub (1,014)
cmdYrSub_Click (18) , Form_f_PopupCalendar (1,571)
Color3_AfterUpdate (5) , Form_f_MENU_HTMLCalendar (2,077)
Color3B_AfterUpdate (5) , Form_f_MENU_HTMLCalendar (2,077)
ColorMe (18) , Form_f_MENU_HTMLCalendar (2,077)
CopyOlePiccy (43) , mod_TerryKreft_API_Clipboard_Copy_Paste (208)
CorrectCase (20) , mod_helper_HTMLcalendar (653)
CorrectFilename (25) , mod_helper_HTMLcalendar (653)
CorrectName (85) , bas_crystal_code_general_1308 (2,724)
CorrectProper (23) , bas_crystal_code_general_1308 (2,724)
CorrectWebAddress (21) , Form_fc_AnywhereAttachments (903)
Create_HTMLCalendar (533) , Form_f_MENU_HTMLCalendar (2,077)
createXLSfile (14) , Form_f_MENU_HTMLCalendar (2,077)
Custom_Delete_Properties (27) , bas_Crystal_Properties_0806_130410_0429 (628)
Custom_SetDefaultProperties (222) , bas_Crystal_Properties_0806_130410_0429 (628)
CustomerID_NotInList (10) , Form_f_PROJECTs (264)

Goto Top       Goto Index       Procedure name, Module name       C
D
DataSheet_ColumnWidth (32) , mod_UI (789)
Date1_AfterUpdate (6) , Form_f_CalendarSub_test (85)
Date1_DblClick (5) , Form_f_GetDateRange (90)
Date1_DblClick (5) , Form_f_MENU_HTMLCalendar (2,077)
Date2_AfterUpdate (6) , Form_f_CalendarSub_test (85)
Date2_DblClick (6) , Form_f_GetDateRange (90)
Date2_DblClick (5) , Form_f_MENU_HTMLCalendar (2,077)
Date3_AfterUpdate (8) , Form_f_CalendarSub_test (85)
DayClick (41) , Form_f_Calendar_sub (1,014)
DayClick (43) , Form_f_PopupCalendar (1,571)
dd_CanGet_ObjectProperty (45) , mod_crystal_DataDICTIONARY_DisplayControl (613)
dd_CanGet_PropertyValue (61) , mod_crystal_DataDICTIONARY_DisplayControl (613)
dd_ClearList (20) , mod_crystal_DataDICTIONARY_DisplayControl (613)
dd_GetControlType (40) , mod_crystal_DataDICTIONARY_DisplayControl (613)
dd_GetDataType (55) , mod_crystal_DataDICTIONARY_DisplayControl (613)
dd_GetPropertyValue (27) , mod_crystal_DataDICTIONARY_DisplayControl (613)
dd_SetDisplayControlCheckbox (66) , mod_crystal_DataDICTIONARY_DisplayControl (613)
dd_SetDisplayControlTextbox (69) , mod_crystal_DataDICTIONARY_DisplayControl (613)
Declaration Lines (69) , bas_crystal_code_general_1308 (2,724)
Declaration Lines (2) , bas_Crystal_Properties_0806_130410_0429 (628)
Declaration Lines (2) , bas_Crystal_ReLinker_140629_080726_1001 (1,250)
Declaration Lines (49) , bas_Crystal_RunSQL_130522 (336)
Declaration Lines (2) , bas_PleaseWait (47)
Declaration Lines (29) , bas_RenameControls_ActiveFormReport (172)
Declaration Lines (37) , Form_f_ADMIN (1,024)
Declaration Lines (28) , Form_f_AnywhereMENU (401)
Declaration Lines (43) , Form_f_Calendar_sub (1,014)
Declaration Lines (2) , Form_f_CalendarSub_test (85)
Declaration Lines (28) , Form_f_CUSTOMER (95)
Declaration Lines (36) , Form_f_DataDICTIONARY_DisplayControl (507)
Declaration Lines (28) , Form_f_EMPLOYEE (58)
Declaration Lines (2) , Form_f_GetDateRange (90)
Declaration Lines (2) , Form_f_INVOICE (102)
Declaration Lines (2) , Form_f_Invoice_Charges_sub (32)
Declaration Lines (52) , Form_f_Invoice_sub_NEEDSWORK (236)
Declaration Lines (2) , Form_f_InvoiceDetail_sub (101)
Declaration Lines (24) , Form_f_INVOICEs_NEEDSWORK (61)
Declaration Lines (28) , Form_f_ITM (141)
Declaration Lines (28) , Form_f_ITMs (137)
Declaration Lines (28) , Form_f_MAIN_MENU (93)
Declaration Lines (23) , Form_f_MENU_HTMLCalendar (2,077)
Declaration Lines (31) , Form_f_Payments_sub (88)
Declaration Lines (2) , Form_f_PleaseWait (48)
Declaration Lines (53) , Form_f_PopupCalendar (1,571)
Declaration Lines (29) , Form_f_PRJECT (267)
Declaration Lines (28) , Form_f_PROJECTs (264)
Declaration Lines (28) , Form_f_PROSPECT (67)
Declaration Lines (2) , Form_f_SplashScreen (40)
Declaration Lines (3) , Form_f_UnderConstruction (3)
Declaration Lines (28) , Form_f_VENDOR (68)
Declaration Lines (33) , Form_fc_AddrDates_sub (79)
Declaration Lines (42) , Form_fc_Addresses_sub (367)
Declaration Lines (39) , Form_fc_AnywhereAttachments (903)
Declaration Lines (36) , Form_fc_AnywhereNotes (385)
Declaration Lines (36) , Form_fc_AnywhereNotes_sub (366)
Declaration Lines (28) , Form_fc_Contact_Categories_sub (193)
Declaration Lines (46) , Form_fc_eAdr_sub (124)
Declaration Lines (36) , Form_fc_List_sub (76)
Declaration Lines (37) , Form_fc_LISTS (87)
Declaration Lines (38) , Form_fc_Lists_Members_sub (58)
Declaration Lines (35) , Form_fc_Lists_PickMembers_sub (106)
Declaration Lines (47) , Form_fc_MbrLists_sub (154)
Declaration Lines (42) , Form_fc_MENU_CONTACT (1,679)
Declaration Lines (36) , Form_fc_Notes_sub (65)
Declaration Lines (41) , Form_fc_Phones_sub (195)
Declaration Lines (31) , Form_fc_PikPeople (418)
Declaration Lines (2) , Form_fc_pop_Appointment (139)
Declaration Lines (33) , Form_fc_Popup_AddContact (302)
Declaration Lines (2) , Form_fc_Tables (67)
Declaration Lines (2) , Form_fc_templateAnywhere (37)
Declaration Lines (2) , Form_fc_ViewAddress_sub (44)
Declaration Lines (49) , Form_fc_Websites_sub (261)
Declaration Lines (2) , Form_usys_f_PickUser__NOTUSED (94)
Declaration Lines (2) , Form_usys_fPw (52)
Declaration Lines (33) , mod_crystal_DataDICTIONARY_DisplayControl (613)
Declaration Lines (32) , mod_crystal_GetFile_Browse (157)
Declaration Lines (2) , mod_DocumentQueryCalculatedFields_Crystal (284)
Declaration Lines (2) , mod_local_Anywhere (880)
Declaration Lines (2) , mod_local_Contacts (463)
Declaration Lines (33) , mod_local_ui (266)
Declaration Lines (11) , mod_PlaySound (33)
Declaration Lines (2) , mod_SaveCSVasExcel (135)
Declaration Lines (2) , mod_SubDatasheet (105)
Declaration Lines (108) , mod_TerryKreft_API_Clipboard_Copy_Paste (208)
Declaration Lines (2) , mod_UI (789)
Declaration Lines (12) , Report_r_ADDRESSES (40)
Declaration Lines (3) , Report_r_addresses_sub (3)
Declaration Lines (12) , Report_r_BIRTHDAYS (35)
Declaration Lines (12) , Report_r_COMPANY_CONTACTS (36)
Declaration Lines (12) , Report_r_CONTACTS (41)
Declaration Lines (3) , Report_r_emailaddresses_sub (3)
Declaration Lines (2) , Report_r_Notes (24)
Declaration Lines (12) , Report_r_PHONES_2col (36)
Declaration Lines (12) , Report_r_PHONES_3col (36)
Declaration Lines (3) , Report_r_phones_sub (3)
Declaration Lines (3) , Report_r_web_sub (3)
Declaration Lines (2) , Report_rc_Avery5160 (27)
Delete_Property (58) , bas_Crystal_Properties_0806_130410_0429 (628)
DeleteAllTableDescriptions (35) , bas_Crystal_ReLinker_140629_080726_1001 (1,250)
DeleteCategory (44) , Form_fc_Contact_Categories_sub (193)
DeleteRecords (68) , mod_local_Contacts (463)
DocumentQueryCalculatedFields (282) , mod_DocumentQueryCalculatedFields_Crystal (284)
DoesControlExistOnForm (21) , bas_crystal_code_general_1308 (2,724)
DoesExist (56) , bas_crystal_code_general_1308 (2,724)
DoesExistDelete (60) , bas_crystal_code_general_1308 (2,724)
DoesWebAddressStartRight (50) , Form_fc_AnywhereAttachments (903)
DropMe (31) , bas_crystal_code_general_1308 (2,724)
DropMeIfNull (13) , bas_crystal_code_general_1308 (2,724)
dt1Bus_DblClick (4) , Form_f_CUSTOMER (95)
dtAdr2_DblClick (9) , Form_fc_AddrDates_sub (79)
DtIDTran_DblClick (6) , Form_f_Invoice_sub_NEEDSWORK (236)
DtIDTran_DblClick (57) , Form_f_Payments_sub (88)
dtio_DblClick (5) , Form_f_INVOICE (102)
dtmAppt_AfterUpdate (34) , Form_fc_pop_Appointment (139)
dtmDun_DblClick (5) , Form_fc_AnywhereNotes (385)
dtmDun_DblClick (5) , Form_fc_AnywhereNotes_sub (366)
dtmDun_DblClick (5) , Form_fc_Notes_sub (65)
dtmNote_DblClick (5) , Form_fc_AnywhereNotes (385)
dtmNote_DblClick (5) , Form_fc_AnywhereNotes_sub (366)
dtmNote_DblClick (6) , Form_fc_Notes_sub (65)
dtmToDo_DblClick (5) , Form_fc_AnywhereNotes (385)
dtmToDo_DblClick (5) , Form_fc_AnywhereNotes_sub (366)
dtPurch_DblClick (6) , Form_f_CUSTOMER (95)

Goto Top       Goto Index       Procedure name, Module name       D
E
eAdr_BeforeUpdate (4) , Form_fc_eAdr_sub (124)
eAdr_DblClick (11) , Form_fc_eAdr_sub (124)
Edit_TQ (17) , Form_f_MENU_HTMLCalendar (2,077)
EmailAddress_AfterUpdate (5) , Form_f_MENU_HTMLCalendar (2,077)
EMailReport (74) , bas_crystal_code_general_1308 (2,724)
EmailTheReport (12) , Form_f_MENU_HTMLCalendar (2,077)
emaNote_AfterUpdate (7) , Form_fc_eAdr_sub (124)
EmpID_AfterUpdate (38) , Form_f_Invoice_sub_NEEDSWORK (236)
EndTime (21) , bas_Crystal_RunSQL_130522 (336)
Examples1_DblClick (4) , Form_f_MENU_HTMLCalendar (2,077)
Examples2_DblClick (4) , Form_f_MENU_HTMLCalendar (2,077)
Examples3_DblClick (4) , Form_f_MENU_HTMLCalendar (2,077)
Examples4_DblClick (4) , Form_f_MENU_HTMLCalendar (2,077)
ExitAccess (9) , bas_crystal_code_general_1308 (2,724)

Goto Top       Goto Index       Procedure name, Module name       E
F
fc_eAdr_sub_Enter (5) , Form_fc_MENU_CONTACT (1,679)
fc_eAdr_sub_Exit (33) , Form_fc_MENU_CONTACT (1,679)
Field1_AfterUpdate (4) , Form_f_MENU_HTMLCalendar (2,077)
Field2_AfterUpdate (4) , Form_f_MENU_HTMLCalendar (2,077)
Field3_AfterUpdate (5) , Form_f_MENU_HTMLCalendar (2,077)
Field4_AfterUpdate (6) , Form_f_MENU_HTMLCalendar (2,077)
FillDate (7) , Form_f_GetDateRange (90)
FillDate (7) , Form_f_MENU_HTMLCalendar (2,077)
FillMonth (6) , Form_f_GetDateRange (90)
FillMonth (6) , Form_f_MENU_HTMLCalendar (2,077)
FillMTD (6) , Form_f_GetDateRange (90)
FillMTD (6) , Form_f_MENU_HTMLCalendar (2,077)
FillOneWeek (6) , Form_f_GetDateRange (90)
FillOneWeek (6) , Form_f_MENU_HTMLCalendar (2,077)
FillOneYear (6) , Form_f_GetDateRange (90)
FillOneYear (6) , Form_f_MENU_HTMLCalendar (2,077)
FillQuarter (9) , Form_f_GetDateRange (90)
FillQuarter (9) , Form_f_MENU_HTMLCalendar (2,077)
FillWorkWeek (7) , Form_f_GetDateRange (90)
FillWorkWeek (7) , Form_f_MENU_HTMLCalendar (2,077)
FillYTD (6) , Form_f_GetDateRange (90)
FillYTD (6) , Form_f_MENU_HTMLCalendar (2,077)
FilterMe (62) , Form_f_ITM (141)
FilterMe (58) , Form_f_ITMs (137)
FilterMyFind (140) , Form_fc_MENU_CONTACT (1,679)
FindList_AfterUpdate (4) , Form_fc_LISTS (87)
FindMyContact (95) , Form_fc_MENU_CONTACT (1,679)
FindRecord (45) , Form_fc_PikPeople (418)
FindRecordN (111) , bas_crystal_code_general_1308 (2,724)
FindRecordNsub (28) , mod_local_Anywhere (880)
FldAuto_combo_AfterUpdate (6) , Form_fc_Tables (67)
FldRoll_combo_AfterUpdate (6) , Form_fc_Tables (67)
FleetID_GotFocus (13) , Form_f_PROJECTs (264)
FleetID_LostFocus (5) , Form_f_PROJECTs (264)
FleetID_NotInList (18) , Form_f_PROJECTs (264)
fltr_cCatID_AfterUpdate (5) , Form_fc_MENU_CONTACT (1,679)
fltr_ItmID__AfterUpdate (5) , Form_f_ITM (141)
fltr_ItmID__AfterUpdate (5) , Form_f_ITMs (137)
fltrTablename_AfterUpdate (5) , Form_f_AnywhereMENU (401)
fltrTablename_AfterUpdate (5) , Form_f_DataDICTIONARY_DisplayControl (507)
fnd_AdrID_AfterUpdate (90) , Form_fc_MENU_CONTACT (1,679)
fnd_CID_AfterUpdate (7) , Form_f_PROSPECT (67)
fnd_CID_AfterUpdate (7) , Form_f_VENDOR (68)
fnd_Customer_AfterUpdate (6) , Form_f_CUSTOMER (95)
fnd_Customer_AfterUpdate (5) , Form_f_PRJECT (267)
fnd_CustomerContact_AfterUpdate (6) , Form_f_CUSTOMER (95)
fnd_CustomerContact_AfterUpdate (6) , Form_f_PROSPECT (67)
fnd_CustomerContact_AfterUpdate (6) , Form_f_VENDOR (68)
fnd_EmpID_AfterUpdate (5) , Form_f_EMPLOYEE (58)
fnd_Expens_AfterUpdate (5) , Form_f_PRJECT (267)
fnd_Invoice_AfterUpdate (6) , Form_f_INVOICEs_NEEDSWORK (61)
fnd_Invoice_AfterUpdate (6) , Form_f_PRJECT (267)
Fnd_ItmID_Code_AfterUpdate (5) , Form_f_ITM (141)
Fnd_ItmID_Code_AfterUpdate (5) , Form_f_ITMs (137)
Fnd_ItmID_Name_AfterUpdate (5) , Form_f_ITM (141)
Fnd_ItmID_Name_AfterUpdate (7) , Form_f_ITMs (137)
Fnd_ItmID_SupCode_AfterUpdate (5) , Form_f_ITM (141)
Fnd_ItmID_SupCode_AfterUpdate (5) , Form_f_ITMs (137)
fnd_List_AfterUpdate (7) , Form_fc_List_sub (76)
fnd_Name_DblClick (6) , Form_fc_MENU_CONTACT (1,679)
fnd_Payment_AfterUpdate (6) , Form_f_PRJECT (267)
fnd_PO_AfterUpdate (7) , Form_f_INVOICEs_NEEDSWORK (61)
fnd_PO_AfterUpdate (12) , Form_f_PROJECTs (264)
fnd_Project_AfterUpdate (6) , Form_f_CUSTOMER (95)
fnd_Project_AfterUpdate (6) , Form_f_INVOICEs_NEEDSWORK (61)
fnd_Project_AfterUpdate (6) , Form_f_PRJECT (267)
fnd_Project_AfterUpdate (5) , Form_f_PROJECTs (264)
fnd_Record_AfterUpdate (31) , Form_fc_AnywhereAttachments (903)
fnd_Record_AfterUpdate (33) , Form_fc_AnywhereNotes (385)
fnd_Record_AfterUpdate (33) , Form_fc_AnywhereNotes_sub (366)
Form_AfterDelConfirm (8) , Form_fc_List_sub (76)
Form_AfterDelConfirm (5) , Form_fc_LISTS (87)
Form_AfterDelConfirm (4) , Form_fc_MENU_CONTACT (1,679)
Form_AfterUpdate (30) , Form_f_InvoiceDetail_sub (101)
Form_AfterUpdate (6) , Form_f_PROJECTs (264)
Form_AfterUpdate (61) , Form_fc_Addresses_sub (367)
Form_AfterUpdate (24) , Form_fc_AnywhereAttachments (903)
Form_AfterUpdate (11) , Form_fc_AnywhereNotes (385)
Form_AfterUpdate (10) , Form_fc_AnywhereNotes_sub (366)
Form_AfterUpdate (25) , Form_fc_LISTS (87)
Form_AfterUpdate (11) , Form_fc_MENU_CONTACT (1,679)
Form_AfterUpdate (45) , Form_fc_pop_Appointment (139)
Form_AfterUpdate (57) , Form_fc_Popup_AddContact (302)
Form_BeforeInsert (8) , Form_fc_AnywhereNotes (385)
Form_BeforeInsert (8) , Form_fc_AnywhereNotes_sub (366)
Form_BeforeUpdate (5) , Form_f_CUSTOMER (95)
Form_BeforeUpdate (25) , Form_f_EMPLOYEE (58)
Form_BeforeUpdate (6) , Form_f_Invoice_sub_NEEDSWORK (236)
Form_BeforeUpdate (6) , Form_f_INVOICEs_NEEDSWORK (61)
Form_BeforeUpdate (5) , Form_f_ITM (141)
Form_BeforeUpdate (5) , Form_f_ITMs (137)
Form_BeforeUpdate (5) , Form_f_PRJECT (267)
Form_BeforeUpdate (23) , Form_f_PROJECTs (264)
Form_BeforeUpdate (5) , Form_f_PROSPECT (67)
Form_BeforeUpdate (6) , Form_f_VENDOR (68)
Form_BeforeUpdate (20) , Form_fc_AddrDates_sub (79)
Form_BeforeUpdate (31) , Form_fc_Addresses_sub (367)
Form_BeforeUpdate (49) , Form_fc_AnywhereAttachments (903)
Form_BeforeUpdate (23) , Form_fc_AnywhereNotes (385)
Form_BeforeUpdate (23) , Form_fc_AnywhereNotes_sub (366)
Form_BeforeUpdate (20) , Form_fc_eAdr_sub (124)
Form_BeforeUpdate (7) , Form_fc_List_sub (76)
Form_BeforeUpdate (8) , Form_fc_Lists_Members_sub (58)
Form_BeforeUpdate (5) , Form_fc_Lists_PickMembers_sub (106)
Form_BeforeUpdate (18) , Form_fc_MbrLists_sub (154)
Form_BeforeUpdate (68) , Form_fc_MENU_CONTACT (1,679)
Form_BeforeUpdate (7) , Form_fc_Notes_sub (65)
Form_BeforeUpdate (29) , Form_fc_Phones_sub (195)
Form_BeforeUpdate (22) , Form_fc_pop_Appointment (139)
Form_BeforeUpdate (167) , Form_fc_Popup_AddContact (302)
Form_BeforeUpdate (30) , Form_fc_templateAnywhere (37)
Form_BeforeUpdate (89) , Form_fc_Websites_sub (261)
Form_Current (21) , Form_f_CUSTOMER (95)
Form_Current (4) , Form_f_INVOICE (102)
Form_Current (15) , Form_f_PRJECT (267)
Form_Current (20) , Form_f_PROJECTs (264)
Form_Current (21) , Form_f_PROSPECT (67)
Form_Current (21) , Form_f_VENDOR (68)
Form_Current (19) , Form_fc_Addresses_sub (367)
Form_Current (35) , Form_fc_AnywhereAttachments (903)
Form_Current (4) , Form_fc_AnywhereNotes (385)
Form_Current (4) , Form_fc_AnywhereNotes_sub (366)
Form_Current (47) , Form_fc_MENU_CONTACT (1,679)
Form_Current (16) , Form_fc_Tables (67)
Form_Current (23) , mod_local_Anywhere (880)
Form_Load (9) , Form_f_AnywhereMENU (401)
Form_Load (50) , Form_f_Calendar_sub (1,014)
Form_Load (52) , Form_f_CalendarSub_test (85)
Form_Load (24) , Form_f_DataDICTIONARY_DisplayControl (507)
Form_Load (15) , Form_f_ITM (141)
Form_Load (27) , Form_f_MENU_HTMLCalendar (2,077)
Form_Load (63) , Form_f_PopupCalendar (1,571)
Form_Load (10) , Form_f_PROJECTs (264)
Form_Load (67) , Form_fc_MENU_CONTACT (1,679)
Form_Load (32) , Form_fc_PikPeople (418)
Form_Load (11) , Form_usys_f_PickUser__NOTUSED (94)
Form_Open (147) , Form_f_ADMIN (1,024)
Form_Open (11) , Form_f_AnywhereMENU (401)
Form_Open (9) , Form_f_Calendar_sub (1,014)
Form_Open (8) , Form_f_DataDICTIONARY_DisplayControl (507)
Form_Open (12) , Form_f_INVOICEs_NEEDSWORK (61)
Form_Open (8) , Form_f_MAIN_MENU (93)
Form_Open (84) , Form_f_PopupCalendar (1,571)
Form_Open (8) , Form_f_SplashScreen (40)
Form_Open (40) , Form_fc_AnywhereAttachments (903)
Form_Open (49) , Form_fc_AnywhereNotes (385)
Form_Open (41) , Form_fc_AnywhereNotes_sub (366)
Form_Open (53) , Form_fc_MENU_CONTACT (1,679)
Form_Open (18) , Form_fc_PikPeople (418)
Form_Open (5) , Form_fc_templateAnywhere (37)
Form_Open (11) , Form_fc_ViewAddress_sub (44)
Form_Open (16) , Form_usys_f_PickUser__NOTUSED (94)
Form_Open (12) , Form_usys_fPw (52)
Form_Timer (30) , Form_f_SplashScreen (40)
Form_Unload (20) , Form_fc_MENU_CONTACT (1,679)
FormBeforeUpdate (74) , mod_UI (789)
FoundBackEnd (19) , bas_Crystal_ReLinker_140629_080726_1001 (1,250)
fraItmBy_AfterUpdate (46) , Form_f_InvoiceDetail_sub (101)
fraOutput_AfterUpdate (26) , Form_f_MENU_HTMLCalendar (2,077)
fraSort_AfterUpdate (5) , Form_fc_PikPeople (418)
FraTQ_AfterUpdate (4) , Form_f_MENU_HTMLCalendar (2,077)
fraWhen_AfterUpdate (7) , Form_fc_PikPeople (418)

Goto Top       Goto Index       Procedure name, Module name       F
G
Generate_Index (128) , Form_f_MENU_HTMLCalendar (2,077)
Generate_Index_TOC (84) , Form_f_MENU_HTMLCalendar (2,077)
Get_ColorDirectory (104) , Form_f_ADMIN (1,024)
Get_CorrectName (134) , mod_crystal_DataDICTIONARY_DisplayControl (613)
Get_DirectoryDialog (33) , Form_f_ADMIN (1,024)
Get_Property (62) , bas_Crystal_Properties_0806_130410_0429 (628)
GetAddressFromForm (22) , mod_local_Contacts (463)
GetAddressShort (18) , mod_local_Contacts (463)
GetAge (16) , bas_crystal_code_general_1308 (2,724)
GetAge (13) , mod_local_Contacts (463)
GetAgeYMD (26) , mod_local_Contacts (463)
GetAttachmentPath (51) , mod_local_Anywhere (880)
GetBirthday (14) , bas_crystal_code_general_1308 (2,724)
GetBirthdayNext (26) , mod_local_Contacts (463)
GetBirthdayThisYr (16) , mod_local_Contacts (463)
GetCategoryOrder (45) , mod_local_Contacts (463)
GetCurrentPath (16) , bas_crystal_code_general_1308 (2,724)
GetDataType (608) , mod_helper_HTMLcalendar (653)
GetDefaultExampleID (10) , bas_Crystal_Properties_0806_130410_0429 (628)
GetElapsedTime (27) , bas_Crystal_RunSQL_130522 (336)
GetFile_Browse (125) , mod_crystal_GetFile_Browse (157)
GetFullName (95) , mod_local_Contacts (463)
GetGoodPartOfPath (34) , Form_f_ADMIN (1,024)
GetMax (32) , mod_local_Anywhere (880)
GetMin (36) , mod_local_Anywhere (880)
GetNameFromURL (48) , mod_local_Anywhere (880)
GetObjectType (16) , mod_UI (789)
GetPathFromFilename (52) , bas_Crystal_ReLinker_140629_080726_1001 (1,250)
GetResponse_NIL (71) , mod_UI (789)
GetSourceTableDescriptions (105) , bas_Crystal_ReLinker_140629_080726_1001 (1,250)
GetSQL_ORDERBY (70) , mod_UI (789)
GetSQL_WHERE (103) , mod_UI (789)
GetTableDescription (48) , bas_Crystal_ReLinker_140629_080726_1001 (1,250)
GetTableFlags (33) , mod_crystal_DataDICTIONARY_DisplayControl (613)
GetTheURL (16) , mod_local_Anywhere (880)
GetWholePathFile (45) , mod_local_Anywhere (880)
GotoWebsite (34) , Form_fc_Websites_sub (261)
GotToAddress (9) , Form_fc_MENU_CONTACT (1,679)
GroupFooter1_Format (5) , Report_r_ADDRESSES (40)
GroupFooter3_Format (5) , Report_r_CONTACTS (41)

Goto Top       Goto Index       Procedure name, Module name       G
H
hDn_Click (11) , Form_f_PopupCalendar (1,571)
HideDBWindow (10) , bas_Crystal_Properties_0806_130410_0429 (628)
HighlightBox_Click (4) , Form_fc_Lists_PickMembers_sub (106)
HrUpDn (39) , Form_f_PopupCalendar (1,571)
html_EndTime (8) , Form_f_MENU_HTMLCalendar (2,077)
html_StartTime (9) , Form_f_MENU_HTMLCalendar (2,077)
hUp_Click (10) , Form_f_PopupCalendar (1,571)

Goto Top       Goto Index       Procedure name, Module name       H
I
ImageCalendar_Click (8) , Form_fc_MENU_CONTACT (1,679)
IMPhone_AfterUpdate (13) , Form_fc_Phones_sub (195)
Initialize_ListID (5) , Form_fc_MbrLists_sub (154)
InStrRev97 (21) , bas_Crystal_ReLinker_140629_080726_1001 (1,250)
IsBEok (42) , bas_Crystal_ReLinker_140629_080726_1001 (1,250)
IsExclusive (5) , mod_crystal_DataDICTIONARY_DisplayControl (613)
IsHidden (5) , mod_crystal_DataDICTIONARY_DisplayControl (613)
IsHuman_AfterUpdate (5) , Form_fc_MENU_CONTACT (1,679)
IsLinked (5) , mod_crystal_DataDICTIONARY_DisplayControl (613)
IsLoadedForm (28) , bas_crystal_code_general_1308 (2,724)
IsLoadedReport (27) , bas_crystal_code_general_1308 (2,724)
IsODBC (5) , mod_crystal_DataDICTIONARY_DisplayControl (613)
IsPropertyDefined (45) , bas_Crystal_Properties_0806_130410_0429 (628)
IsSavePW (5) , mod_crystal_DataDICTIONARY_DisplayControl (613)
IsSubform (17) , bas_crystal_code_general_1308 (2,724)
IsSystem (5) , mod_crystal_DataDICTIONARY_DisplayControl (613)
IsTable (20) , bas_crystal_code_general_1308 (2,724)
IsValidURL (38) , bas_crystal_code_general_1308 (2,724)
IsValueUnique (22) , mod_UI (789)
ItmCode_DblClick (5) , Form_f_ITMs (137)
ItmID_AfterUpdate (11) , Form_f_InvoiceDetail_sub (101)

Goto Top       Goto Index       Procedure name, Module name       I
L
Label_By_Click (6) , Form_f_AnywhereMENU (401)
Label_By_Click (6) , Form_f_DataDICTIONARY_DisplayControl (507)
Label_emailCrystal_Click (6) , Form_f_CalendarSub_test (85)
Label_emailCrystal_Click (7) , Form_fc_MENU_CONTACT (1,679)
label_Footer1_DblClick (4) , Form_f_MENU_HTMLCalendar (2,077)
label_Footer2_DblClick (4) , Form_f_MENU_HTMLCalendar (2,077)
label_Footer3_DblClick (4) , Form_f_MENU_HTMLCalendar (2,077)
label_Footer4_DblClick (4) , Form_f_MENU_HTMLCalendar (2,077)
Label_strive4peace_Click (8) , Form_f_Calendar_sub (1,014)
Label_strive4peace_Click (7) , Form_f_PopupCalendar (1,571)
Label_thanks_Click (7) , Form_fc_MENU_CONTACT (1,679)
Label_Tips_Click (6) , Form_fc_MENU_CONTACT (1,679)
Label_website_Click (5) , Form_f_CalendarSub_test (85)
Label_writtenBy_Click (6) , Form_f_MENU_HTMLCalendar (2,077)
lbl_Footer1_Click (6) , Form_f_PleaseWait (48)
lbl_Footer2_Click (5) , Form_f_PleaseWait (48)
ListID_BeforeUpdate (9) , Form_fc_MbrLists_sub (154)
ListID_NotInList (50) , Form_fc_MbrLists_sub (154)
ListIndexes (19) , bas_crystal_code_general_1308 (2,724)
ListName_AfterUpdate (5) , Form_fc_List_sub (76)
listNote_AfterUpdate (8) , Form_fc_List_sub (76)
listQuerySQL (21) , bas_crystal_code_general_1308 (2,724)
ListTQ_AfterUpdate (5) , Form_f_MENU_HTMLCalendar (2,077)
ListTQ_DblClick (5) , Form_f_MENU_HTMLCalendar (2,077)
local_GetDataType (55) , Form_f_AnywhereMENU (401)
local_MakeQuery (49) , Form_f_AnywhereMENU (401)
LoopAndCombine (97) , bas_crystal_code_general_1308 (2,724)
LoopCombineVar (82) , bas_crystal_code_general_1308 (2,724)
lst_CompanyContacts_AfterUpdate (38) , Form_fc_MENU_CONTACT (1,679)
lstFieldname_AfterUpdate (61) , Form_f_DataDICTIONARY_DisplayControl (507)

Goto Top       Goto Index       Procedure name, Module name       L
M
MainName_AfterUpdate (6) , Form_fc_MENU_CONTACT (1,679)
MakeADirectory (44) , bas_crystal_code_general_1308 (2,724)
MakeAPath (48) , bas_crystal_code_general_1308 (2,724)
MakeID_NotInList (9) , Form_f_PROJECTs (264)
MakeMyQuery (67) , bas_crystal_code_general_1308 (2,724)
MakeTheChanges (37) , Form_f_DataDICTIONARY_DisplayControl (507)
Mark_TodayAndDate (68) , Form_f_Calendar_sub (1,014)
Mark_TodayAndDate (71) , Form_f_PopupCalendar (1,571)
MarkCategory (34) , Form_fc_Contact_Categories_sub (193)
MarkHuman (15) , Form_fc_Popup_AddContact (302)
MbrNote_AfterUpdate (5) , Form_fc_MbrLists_sub (154)
MinUpDn (21) , Form_f_PopupCalendar (1,571)
ModelID_GotFocus (13) , Form_f_PROJECTs (264)
ModelID_LostFocus (7) , Form_f_PROJECTs (264)
ModelID_NotInList (17) , Form_f_PROJECTs (264)
MoveToRecord (72) , Form_fc_MENU_CONTACT (1,679)
myFormOpenEvent (71) , mod_UI (789)

Goto Top       Goto Index       Procedure name, Module name       M
N
NameA_AfterUpdate (6) , Form_fc_MENU_CONTACT (1,679)
NameB_AfterUpdate (11) , Form_fc_MENU_CONTACT (1,679)
NewFooterText (13) , Form_f_MENU_HTMLCalendar (2,077)
NickName_AfterUpdate (6) , Form_fc_MENU_CONTACT (1,679)
NoteDate_DblClick (5) , Form_fc_AnywhereNotes (385)
NoteDate_DblClick (5) , Form_fc_AnywhereNotes_sub (366)
NotInList_Aircraft_fromPrj (67) , mod_local_ui (266)
NotInList_general (96) , mod_UI (789)

Goto Top       Goto Index       Procedure name, Module name       N
O
OemID_NotInList (10) , Form_f_PROJECTs (264)
open_Form (25) , bas_crystal_code_general_1308 (2,724)
open_Form_Filter (22) , bas_crystal_code_general_1308 (2,724)
open_Query (14) , bas_crystal_code_general_1308 (2,724)
open_Report (21) , bas_crystal_code_general_1308 (2,724)
OpenFindPeople (11) , Form_fc_MENU_CONTACT (1,679)
OpenShortcuts (5) , mod_UI (789)
OpenTheItem (7) , Form_f_ITMs (137)
OpenTheReport (210) , Form_fc_MENU_CONTACT (1,679)

Goto Top       Goto Index       Procedure name, Module name       O
P
Phone_AfterUpdate (6) , Form_fc_Phones_sub (195)
Phone_GotFocus (6) , Form_fc_Phones_sub (195)
phoNote_AfterUpdate (6) , Form_fc_Phones_sub (195)
PickMember (58) , Form_fc_Lists_PickMembers_sub (106)
PlayWelcome (11) , mod_PlaySound (33)
PleaseWaitMsg (6) , bas_PleaseWait (47)
PopAttachments (24) , mod_local_Anywhere (880)
PopCalendar (9) , mod_UI (789)
PopCalendarAndDoStuff (31) , Form_f_MENU_HTMLCalendar (2,077)
popNotes (43) , mod_local_Anywhere (880)
pri_DropMe (6) , Form_f_ADMIN (1,024)
pri_UsrMgt_SetProperties (105) , Form_f_ADMIN (1,024)
PrjDate1_DblClick (4) , Form_f_PRJECT (267)
PrjDate2_DblClick (4) , Form_f_PRJECT (267)
ProperCase (45) , bas_crystal_code_general_1308 (2,724)
PutTextOnClipboard (132) , mod_local_Contacts (463)

Goto Top       Goto Index       Procedure name, Module name       P
Q
QtyShip_AfterUpdate (6) , Form_f_InvoiceDetail_sub (101)
QtyTran_AfterUpdate (6) , Form_f_Invoice_sub_NEEDSWORK (236)
QtyTyID_AfterUpdate (5) , Form_f_Invoice_sub_NEEDSWORK (236)

Goto Top       Goto Index       Procedure name, Module name       Q
R
RecordDelete (60) , bas_crystal_code_general_1308 (2,724)
RecordFirst (28) , bas_crystal_code_general_1308 (2,724)
RecordLast (25) , bas_crystal_code_general_1308 (2,724)
RecordNew (45) , bas_crystal_code_general_1308 (2,724)
RecordNext (28) , bas_crystal_code_general_1308 (2,724)
RecordPrev (27) , bas_crystal_code_general_1308 (2,724)
ReLinker (497) , bas_Crystal_ReLinker_140629_080726_1001 (1,250)
RenameControls_ActiveFormReport (123) , bas_RenameControls_ActiveFormReport (172)
RenameTrackingFields (47) , bas_crystal_code_general_1308 (2,724)
Report_Calendar (136) , Form_f_MENU_HTMLCalendar (2,077)
Report_NoData (7) , Report_r_ADDRESSES (40)
Report_NoData (6) , Report_r_BIRTHDAYS (35)
Report_NoData (6) , Report_r_COMPANY_CONTACTS (36)
Report_NoData (6) , Report_r_CONTACTS (41)
Report_NoData (6) , Report_r_Notes (24)
Report_NoData (6) , Report_r_PHONES_2col (36)
Report_NoData (6) , Report_r_PHONES_3col (36)
Report_NoData (6) , Report_rc_Avery5160 (27)
Report_Open (10) , Report_r_ADDRESSES (40)
Report_Open (10) , Report_r_BIRTHDAYS (35)
Report_Open (10) , Report_r_COMPANY_CONTACTS (36)
Report_Open (10) , Report_r_CONTACTS (41)
Report_Open (10) , Report_r_Notes (24)
Report_Open (10) , Report_r_PHONES_2col (36)
Report_Open (10) , Report_r_PHONES_3col (36)
Report_Open (10) , Report_rc_Avery5160 (27)
ReportElapsedTime (62) , bas_Crystal_RunSQL_130522 (336)
ReportFooter_Format (6) , Report_r_ADDRESSES (40)
ReportFooter_Format (7) , Report_r_BIRTHDAYS (35)
ReportFooter_Format (8) , Report_r_COMPANY_CONTACTS (36)
ReportFooter_Format (8) , Report_r_CONTACTS (41)
ReportFooter_Format (6) , Report_r_Notes (24)
ReportFooter_Format (8) , Report_r_PHONES_2col (36)
ReportFooter_Format (8) , Report_r_PHONES_3col (36)
ReportFooter_Format (9) , Report_rc_Avery5160 (27)
reportProgress (11) , bas_Crystal_RunSQL_130522 (336)
RequeryMe (21) , bas_crystal_code_general_1308 (2,724)
RequeryMyParent (9) , Form_fc_AnywhereAttachments (903)
RequeryMyStuff (20) , Form_fc_MENU_CONTACT (1,679)
ResetData (59) , Form_f_MENU_HTMLCalendar (2,077)
ResetLetters (4) , Form_fc_PikPeople (418)
ResetStuff (14) , bas_crystal_code_general_1308 (2,724)
ResetStuff (10) , bas_Crystal_RunSQL_130522 (336)
RFTtheReport (33) , Form_f_MENU_HTMLCalendar (2,077)
RowSource_Fieldlist (75) , Form_f_AnywhereMENU (401)
RowSource_Fieldlist (116) , Form_f_DataDICTIONARY_DisplayControl (507)
RowSource_LstInvoices (19) , Form_f_PRJECT (267)
RowSource_Tablename (76) , Form_f_DataDICTIONARY_DisplayControl (507)
RowSource_TablenameForm (6) , Form_f_DataDICTIONARY_DisplayControl (507)
RowSource_TID (38) , Form_f_AnywhereMENU (401)
rSql (141) , bas_Crystal_RunSQL_130522 (336)
run_ReLinker (119) , bas_Crystal_ReLinker_140629_080726_1001 (1,250)
run_SaveAttachmentsToFiles (20) , mod_local_Anywhere (880)
RunAddFieldsToTable_Tracking (138) , bas_crystal_code_general_1308 (2,724)
RunDeleteDatabaseProperty (13) , bas_Crystal_Properties_0806_130410_0429 (628)
runFindMyContact (77) , Form_fc_MENU_CONTACT (1,679)
RunLoopAndCombine (16) , bas_crystal_code_general_1308 (2,724)
RunLoopCombineVar (20) , bas_crystal_code_general_1308 (2,724)
runRenameControls_ActiveFormReport (20) , bas_RenameControls_ActiveFormReport (172)
RunSet_Property (18) , bas_Crystal_Properties_0806_130410_0429 (628)
RunSetDatabaseProperties (13) , bas_Crystal_Properties_0806_130410_0429 (628)
runShow_Properties (7) , bas_Crystal_Properties_0806_130410_0429 (628)

Goto Top       Goto Index       Procedure name, Module name       R
S
SaveAttachmentsToFiles (200) , mod_local_Anywhere (880)
SaveCSVasExcel (42) , mod_SaveCSVasExcel (135)
SaveCSVasExcel_WBobject (50) , mod_SaveCSVasExcel (135)
Set_Calendar (189) , Form_f_Calendar_sub (1,014)
Set_Calendar (169) , Form_f_PopupCalendar (1,571)
Set_DefaultFormat (26) , Form_f_Calendar_sub (1,014)
Set_DefaultFormat (26) , Form_f_PopupCalendar (1,571)
Set_Property (87) , bas_Crystal_Properties_0806_130410_0429 (628)
set_RowSource_Names (216) , Form_fc_PikPeople (418)
set_RowSource_Names_FindPeople (7) , Form_fc_PikPeople (418)
SetBackColor (19) , Form_f_ADMIN (1,024)
SetControl_RowSource (70) , mod_UI (789)
setCritDates (65) , Form_f_MENU_HTMLCalendar (2,077)
SetCriteria4AC (166) , mod_local_ui (266)
SetCurrentStuff (37) , Form_fc_MENU_CONTACT (1,679)
SetDefaultExampleID (13) , bas_Crystal_Properties_0806_130410_0429 (628)
SetDirectory (106) , Form_f_ADMIN (1,024)
SetGBlockDrop (11) , bas_crystal_code_general_1308 (2,724)
SetPathAttachment (35) , bas_Crystal_ReLinker_140629_080726_1001 (1,250)
SetPhoneMask (11) , Form_fc_Phones_sub (195)
SetRecordSource (59) , bas_crystal_code_general_1308 (2,724)
SetReportFilter (114) , bas_crystal_code_general_1308 (2,724)
SetSubDatasheetNone (103) , mod_SubDatasheet (105)
SetTabStops (36) , Form_f_Invoice_sub_NEEDSWORK (236)
Show_Properties (26) , bas_Crystal_Properties_0806_130410_0429 (628)
ShowDatePickerMessage (13) , Form_f_Calendar_sub (1,014)
ShowDatePickerMessage (13) , Form_f_PopupCalendar (1,571)
ShowHideControls (59) , bas_crystal_code_general_1308 (2,724)
ShowHuman (13) , Form_fc_MENU_CONTACT (1,679)
ShowPleaseWait (32) , bas_PleaseWait (47)
ShowProperty (10) , bas_Crystal_Properties_0806_130410_0429 (628)
Sort123 (112) , bas_crystal_code_general_1308 (2,724)
SourceObject_fc_AnywhereSub (39) , Form_f_AnywhereMENU (401)
Split97 (44) , bas_Crystal_ReLinker_140629_080726_1001 (1,250)
SQL_Examples (255) , Form_f_MENU_HTMLCalendar (2,077)
SQL_Fields (116) , Form_f_MENU_HTMLCalendar (2,077)
SQL_TQ (48) , Form_f_MENU_HTMLCalendar (2,077)
StartTime (15) , bas_Crystal_RunSQL_130522 (336)
StatID_NotInList (10) , Form_f_PROJECTs (264)
StatusID_GotFocus (42) , Form_f_EmpPapers_sub (49)
StatusID_LostFocus (6) , Form_f_EmpPapers_sub (49)
StripPhoneNonNumeric (17) , mod_UI (789)
Subject_AfterUpdate (6) , Form_fc_AnywhereNotes (385)
Subject_AfterUpdate (6) , Form_fc_AnywhereNotes_sub (366)
Subject_AfterUpdate (6) , Form_fc_Notes_sub (65)
SynchronizeMyAttachments (124) , Form_fc_AnywhereAttachments (903)
SynchronizeMyNotes (180) , Form_fc_AnywhereNotes (385)
SynchronizeMyNotes (175) , Form_fc_AnywhereNotes_sub (366)
SynchronizeOtherForms (18) , Form_fc_MENU_CONTACT (1,679)
SysID_NotInList (11) , Form_f_PROJECTs (264)

Goto Top       Goto Index       Procedure name, Module name       S
T
TableHasField (46) , bas_crystal_code_general_1308 (2,724)
Tablename_AfterUpdate (5) , Form_f_DataDICTIONARY_DisplayControl (507)
Tablename_MouseUp (10) , Form_f_DataDICTIONARY_DisplayControl (507)
Tbl_AfterUpdate (4) , Form_fc_Tables (67)
testGetNameFromURL (43) , mod_local_Anywhere (880)
testSaveCSVasExcel (41) , mod_SaveCSVasExcel (135)
testSetPathAttachment (10) , bas_Crystal_ReLinker_140629_080726_1001 (1,250)
TID_AfterUpdate (22) , Form_f_AnywhereMENU (401)
TID_MouseUp (7) , Form_f_AnywhereMENU (401)
ToggleProperCase (13) , mod_UI (789)
TranTyID_AfterUpdate (63) , Form_f_Invoice_sub_NEEDSWORK (236)
txtCalendarDate_AfterUpdate (14) , Form_f_Calendar_sub (1,014)
txtCalendarDate_AfterUpdate (14) , Form_f_PopupCalendar (1,571)
txtCalendarDate_BeforeUpdate (18) , Form_f_Calendar_sub (1,014)
txtCalendarDate_BeforeUpdate (18) , Form_f_PopupCalendar (1,571)
txtDate_AfterUpdate (41) , Form_f_PopupCalendar (1,571)
txtDays_DblClick (10) , Form_f_PopupCalendar (1,571)
txtTaxRate_AfterUpdate (5) , Form_f_INVOICE (102)
TyCID_NotInList (12) , Form_fc_Lists_Members_sub (58)
TypeID_NIL (61) , mod_UI (789)
TypeID_NotInList (14) , Form_fc_Addresses_sub (367)
TypID_NotInList (20) , Form_fc_Websites_sub (261)
TypIdAdr_NotInList (34) , Form_fc_Addresses_sub (367)
TypIDead_NotInList (23) , Form_fc_eAdr_sub (124)
TypIDmbr_NotInList (7) , Form_fc_MbrLists_sub (154)
TypIDnote_NotInList (5) , Form_fc_AnywhereNotes (385)
TypIDnote_NotInList (5) , Form_fc_AnywhereNotes_sub (366)
TypIDnote_NotInList (5) , Form_fc_Notes_sub (65)
TypIdPho_NotInList (27) , Form_fc_Phones_sub (195)

Goto Top       Goto Index       Procedure name, Module name       T
U
UnderConstruction (4) , Form_f_MENU_HTMLCalendar (2,077)
UnHideDBWindow (5) , bas_Crystal_Properties_0806_130410_0429 (628)
UnitCost_AfterUpdate (5) , Form_f_Invoice_sub_NEEDSWORK (236)
UnitPric_AfterUpdate (6) , Form_f_InvoiceDetail_sub (101)
Update_dtmEdit_to_dtmAdd (68) , bas_crystal_code_general_1308 (2,724)
Update_ExternalForms (21) , Form_f_Calendar_sub (1,014)
Update_ExternalForms (34) , Form_f_PopupCalendar (1,571)
UpperCase (27) , bas_crystal_code_general_1308 (2,724)
URL_DblClick (56) , Form_fc_Websites_sub (261)
Used_MouseUp (4) , Form_fc_Lists_PickMembers_sub (106)
UseTheTime (12) , Form_f_PopupCalendar (1,571)
usrCatID_AfterUpdate (27) , Form_f_ADMIN (1,024)
UsrID_AfterUpdate (99) , Form_f_ADMIN (1,024)
UsrID_AfterUpdate (16) , Form_usys_f_PickUser__NOTUSED (94)
UsrID_BeforeUpdate (8) , Form_f_ADMIN (1,024)
UsrID_BeforeUpdate (9) , Form_usys_f_PickUser__NOTUSED (94)
UsrID_NotInList (94) , Form_f_ADMIN (1,024)

Goto Top       Goto Index       Procedure name, Module name       U
W
WriteHTMLfooter (26) , Form_f_MENU_HTMLCalendar (2,077)
WriteHTMLheader (39) , Form_f_MENU_HTMLCalendar (2,077)

Goto Top       Goto Index       Procedure name, Module name       W
Z
Zip_AfterUpdate (33) , Form_fc_Addresses_sub (367)
Zip_NotInList (7) , Form_fc_Addresses_sub (367)
ZoomMe (21) , bas_crystal_code_general_1308 (2,724)

Object Details


Table


- c_Tables
- c_UsrCats
- c_Usrs
- EmpPapers
- f_9E8203D96A754B0890DAF9414007C362_Data
- MyCompany
- Papers
- t_AddrLines

Table-Link6


- a_DataTypes
- Branches
- c_Accounts
- c_Address
- c_AdrDates
- c_AdrType
- c_Appointment
- c_ApptType
- c_Attachments
- c_AttLinks
- c_AttTypes
- c_Category
- c_Contact
- c_Country
- c_CtcCat
- c_eAddress
- c_EadType
- c_KeepOpen
- c_List
- c_ListMbr
- c_ListType
- c_MbrType
- c_Notes
- c_NoteType
- c_Phone
- c_PhoneType
- c_State
- c_Web
- c_WebPfx
- c_WebType
- Charge_IoPo
- ChrgTypes
- Contractors
- CustCO
- Customers
- CustPO
- Defaultz
- Departments
- Distributors
- Employees
- Expenses
- ExpTypes
- InvOrd
- InvOrdDetail
- IoDStatus
- IoStatus
- Itms
- ItmSuppliers
- itmTanks
- ItmTypes
- Manufacturers
- OEMs
- PackInfo
- Pmts
- PmtTrms
- PmtTypes
- PoDetail
- POs
- Positionz
- PoStatus
- Prices
- PrjCategory
- Prjects
- PrjStatus
- ProdLines
- Prospects
- ProspTypes
- PurMeths
- Ranks
- RateTypes
- RcvDetail
- Rcving
- RentalPlans
- Shippers
- StatusDet
- StatusIO
- StatusPo
- STOCK
- Suppliers
- TankTypes
- TaskDet
- Tasks
- TaskStat
- TaskTypes
- TranTypes
- UnitCats
- Unitz
- Vendors
- Zips_US

Query


- a_qApp_c_Tables
- a_qApp_TIDs
- a_qFields
- c_qAnywhere
- Find duplicates for c_Address
- q_Birthdays
- qAddress
- qApp_0
- qapp_shuffleContacts_Contractors
- qapp_shuffleContacts_Customers
- qapp_shuffleContacts_Employees
- qapp_shuffleContacts_Suppliers
- qapp_shuffleContacts_Vendors
- qCalculatedQueryFields
- qCart_CAdrTy
- qCompanyContacts_Primary
- qContact
- qContact_Address
- qContact_Analyzer
- qContact_Primary
- qContact_withStats
- qContactsCompany_Primary
- qEmailAddresses
- qFields
- qObjex_byCrystal
- qPhones
- qUp_TypID
- qWeb
- usys_CompanyContacts_Primary_Address_Phone_Email
- usys_Contact
- usys_Contact_Customer
- usys_Contact_Primary_Address_Phone_Email
- usys_Contact_Primary_Phone_Email
- usys_Contact_PrimaryAddress
- usys_COPY_qContact
- usys_PrimaryAddress
- usys_PrimaryEmailAddress
- usys_PrimaryPhone
- usys_PrimaryWeb
- usys_qc_All_ListsPeople
- usys_qc_All_ListsPeople1
- usys_qCurrentCtcCat
- usys_qFollowup

Form


- f_ADMIN
- f_AnywhereMENU
- f_Calendar_sub
- f_CalendarSub_test
- f_CUSTOMER
- f_DataDICTIONARY_DisplayControl
- f_EMPLOYEE
- f_EmpPapers_sub
- f_GetDateRange
- f_INVOICE
- f_Invoice_Charges_sub
- f_Invoice_sub_NEEDSWORK
- f_InvoiceDetail_sub
- f_INVOICEs_NEEDSWORK
- f_ITM
- f_ITMs
- f_MAIN_MENU
- f_MENU_HTMLCalendar
- f_Payments_sub
- f_PleaseWait
- f_PopupCalendar
- f_PRJECT
- f_PROJECTs
- f_PROSPECT
- f_SplashScreen
- f_UnderConstruction
- f_VENDOR
- fc_AddrDates_sub
- fc_Addresses_sub
- fc_AnywhereAttachments
- fc_AnywhereNotes
- fc_AnywhereNotes_sub
- fc_AnywhereSub
- fc_binoculars
- fc_Contact_Categories_sub
- fc_eAdr_sub
- fc_List_sub
- fc_LISTS
- fc_Lists_Members_sub
- fc_Lists_PickMembers_sub
- fc_Logo
- fc_MbrLists_sub
- fc_MENU_CONTACT
- fc_Notes_sub
- fc_Phones_sub
- fc_PikPeople
- fc_pop_Appointment
- fc_Popup_AddContact
- fc_Tables
- fc_templateAnywhere
- fc_ViewAddress_sub
- fc_Websites_sub
- usys_f_Dummy
- usys_f_PickUser__NOTUSED
- usys_fPw

Report


- r_ADDRESSES
- r_addresses_sub
- r_BIRTHDAYS
- r_COMPANY_Contacts
- r_CONTACTS
- r_emailaddresses_sub
- r_Invoice
- r_MyCompanyInformation
- r_Notes
- r_PHONES_2col
- r_PHONES_3col
- r_phones_sub
- r_web_sub
- rc_Avery5160

Module


- bas_crystal_code_general_1308
- bas_Crystal_Properties_0806_130410_0429
- bas_Crystal_ReLinker_140629_080726_1001
- bas_Crystal_RunSQL_130522
- bas_PleaseWait
- bas_RenameControls_ActiveFormReport
- mod_crystal_DataDICTIONARY_DisplayControl
- mod_crystal_GetFile_Browse
- mod_DocumentQueryCalculatedFields_Crystal
- mod_helper_HTMLcalendar
- mod_local_Anywhere
- mod_local_Contacts
- mod_local_ui
- mod_PlaySound
- mod_SaveCSVasExcel
- mod_SubDatasheet
- mod_TerryKreft_API_Clipboard_Copy_Paste
- mod_UI

Access


- SummaryInfo
- UserDefined

      Goto Top       Goto Index

Help Links for Keywords