Analyzer_161023_BigData_s4p_accdb

Access Documentation Generated by Code Documenter
Oct-23-16 03:22 AM
J:\Tools_2016\__Analyzer_2016\Analyzer_161023_BigData_s4p.accdb
File last modified: 10/23/2016 8:03:17 AM
File size: 15,340 Kbytes

Application Title: Analyzer for Microsoft Access, October 2016 Big Data
Startup Form: a_f_ANALYZER_MENU

371 Objects modified between 12/20/2007 1:05:20 PM and 10/23/2016 3:03:15 AM
126 Tables, 104 Queries, 24 Forms, 62 Reports, 1 Macro, 54 Modules

113 Modules
1,051 Procedures
53,578 Lines

13,202 Statements
6,887 Comments
4,544 Blank Lines
79% Executable

Index

References

Forms

  1. Form_a_f_ANALYZER_MENU (2,397)
  2. Form_a_f_DbTests_sub (180)
  3. Form_a_f_Login (33)
  4. Form_a_f_strip (41)
  5. Form_f_COLOR_PICKER (108)
  6. Form_F_Colors_AtAGlance (467)
  7. Form_f_Colors_Edit_A (343)
  8. Form_F_Colors_Edit_B (517)
  9. Form_f_Colors_MyFavorites (337)
  10. Form_f_DataDICTIONARY_DisplayControl (508)
  11. Form_f_SplashScreen (30)
  12. Form_frm_Test (104)
  13. Form_frmFilePropertyViewer (93)
  14. Form_oa_f_FldA (33)
  15. Form_oa_f_Optimize (12)
  16. Form_oa_f_OptTests_sub (44)
  17. Form_oa_f_TblA (23)
  18. Form_TSC_ProgressMeter (62)
Goto END of Forms       Goto Top       Goto Index

Form_a_f_ANALYZER_MENU (2397)

PROCEDURES       Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Forms       Goto Index
  1. BatchID_NotInList (70)
  2. BrowseForDatabase (199)
  3. BrowseForWorkGroup (82)
  4. btnDeepAnalysis_Click (6)
  5. btnFldList_Click (6)
  6. btnRelationships_Click (6)
  7. btnTableIndexes_Click (6)
  8. btnTableSummary_Click (10)
  9. CanReportsRun (21)
  10. chk_DoSort_AfterUpdate (6)
  11. cmd_Browse_Click (9)
  12. cmd_ClearOptimizer_Click (5)
  13. cmd_Delete_Click (73)
  14. cmd_EditFldA_Click (8)
  15. cmd_EditProperties_Click (7)
  16. cmd_EditTblA_Click (7)
  17. cmd_OpenReport_Click (99)
  18. cmd_Optimizer_Click (17)
  19. cmd_Quit_Click (19)
  20. cmd_ResetRptCrit_Click (50)
  21. cmd_RunAnalyzer_Click (15)
  22. cmd_SetOptimizer_Click (5)
  23. cmdSysInfo_Click (6)
  24. db_AutoCorrectPerform_AfterUpdate (6)
  25. dbPathFile_Click (7)
  26. dbPathFile_Label_Click (7)
  27. dbTitle_AfterUpdate (6)
  28. Declaration Lines (76)
  29. FindDatabase_AfterUpdate (13)
  30. Form_AfterUpdate (7)
  31. Form_BeforeUpdate (18)
  32. Form_Current (50)
  33. Form_Dirty (15)
  34. Form_Load (30)
  35. Form_Open (50)
  36. fra_lst_Objects_Filter_AfterUpdate (7)
  37. fra_Sort_lst_Objects_AfterUpdate (12)
  38. HideGuids_AfterUpdate (7)
  39. HideMSys_AfterUpdate (6)
  40. HideTemps_AfterUpdate (6)
  41. IsSchemaDS_AfterUpdate (6)
  42. Label_About_Crystal_Click (12)
  43. Label_About_DblClick (5)
  44. Label_AZ_ZA_Click (7)
  45. Label_By_Click (8)
  46. Label_SendComment_Click (39)
  47. lst_aCatID_AfterUpdate (49)
  48. lst_aRptID_AfterUpdate (21)
  49. lst_aRptID_DblClick (5)
  50. lst_ObjSummary_MouseUp (41)
  51. Me_RequeryStuff (145)
  52. Me_TurnOnStuff (114)
  53. MyTID_AfterUpdate (26)
  54. Report_GetCriteria (290)
  55. RptDesc_AfterUpdate (18)
  56. Run_AnalyzerTests (219)
  57. SetOptimizerTests2Run (15)
  58. SetSql_LinkedDBs (70)
  59. SetSql_Objects (117)
  60. SetSql_ObjSummary (79)
  61. ToggleEqual (15)
  62. ToggleStar (14)
  63. WrkGrpFile_BeforeUpdate (19)
  64. WrkGrpFile_Click (8)

Declaration Lines (76)

1        Option Compare Database 
2        Option Explicit 
3         '
4         '
5         '============================================================ LICENSE NOTICE -- must not be modified
6         ' The Analyzer 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        '
26        '
27        ' Join Analyzer Developer Project at http://analyzer.codeplex.com/
28        '
29        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140605
30        ' END LICENSE NOTICE
31        '============================================================
32        'MODIFICATIONS:
33        '
34        '140628 Graham Mandeno (GM) : changes to circumvent problems of date formatting in non-US locales
35        '
36        '============================================================
37        ' Crystal 130411, 130501
38        ' 150416
39        ' on RequeryStuff:
40        'With Me.a_f_DbTests_sub.Form
41        ' .RecordSource = .Tag
42        'End With
43        '
44        ' Run_AnalyzerTests is the last procedure in this module
45        ' cbf:
46        ' a_f_ANALYZER_MENU
47        '
48        ' Crystal May 2013
49        '
50        ' calls
51        '   FindRecordN
52        '   BoldMe
53        '   DoesExist
54        '   MakeRecords_Objects
55        '      Get_Property
56        '      Set_Property
57        '   Analyzer_100_DataDictionary
58        '
59        ' calls, by Bill Mosca
60        '      Set_DBLink
61        '
62        ' calls, to invoke Wayne's vbWatchdog
63        '      EnableErrorHandler
64        '
65        ' calles these functions in Event Properties -->
66        '  =DropMe()
67        '
68        ' custom database PROPERTIES
69        '  local_CurrentDir
70        '  local_StripDate
71        '  local_ReportDate
72        '
73           ' CREATES TABLE LINK
74           '  usys_LinkedObjects
75        '
76        ' 'Requires reference to Microsoft Office #.0 Object Library.
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

Form_Open (50)

77      
78      
79        '=======================================
80        '            Form
81        '=======================================
82      
83        '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Form_Open
84       Private Sub Form_Open(Cancel As Integer) 
85        'Crystal 041014, 18, 130302, 130304, 25, 160422
86           'PROPERTIES
87           '  local_CurrentDir
88           '  local_StripDate
89           '  local_ReportDate
90      
91           'CALLS
92           ' IsPropertyDefined
93           ' Set_Property
94      
95          Dim sPath As String 
96           '160424 s4p added 2 properties, check initial directory
97          Dim sTemp As String 
98      
99          Call InitializeVBWatchdog  ' Usually started in the splash screen, but just in case the splash screen didn't open before us 
100     
101          'reset RowSources of Objects and Linked Databases
102         Me.lst_LinkedDBs.RowSource = Me.lst_LinkedDBs.Tag 
103         Me.lst_Objects.RowSource = Me.lst_Objects.Tag 
104         Me.lst_ObjSummary.RowSource = Me.lst_ObjSummary.Tag 
105     
106          'set current directory
107         sPath = Nz(Get_Property("local_CurrentDir"), "") 
108         If Not Len(sPath) > 2 Then 
109            Call Set_Property("local_CurrentDir", CurrentProject.Path & "\", dbText) 
110         Else 
111             'make sure the directory is good
112            sTemp = Dir(sPath) 
113            If Not Len(sTemp) > 0 Then 
114               Call Set_Property("local_CurrentDir", CurrentProject.Path & "\", dbText) 
115            End If 
116         End If 
117     
118          'properties for strip date and report date
119         If IsNull(Get_Property("local_StripDate")) Then 
120            Call Set_Property("local_StripDate", #12/31/2100#, dbDate)   'set high so it will be done 
121         End If 
122         If IsNull(Get_Property("local_StripDate")) Then 
123            Call Set_Property("local_ReportDate", #1/2/1900#, dbDate) 
124         End If 
125     
126      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

Form_Load (30)

127     
128       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Form_Load
129      Private Sub Form_Load() 
130       '100325 Crystal, 130304, 130409, 150524
131          'CALLS
132          '  Me_TurnOnStuff
133     
134         If Not Me.NewRecord Then 
135            DoCmd.RunCommand acCmdRecordsGoToNew 
136         End If 
137     
138          'turn on controls for a NEW record, don't requery
139         Call Me_TurnOnStuff(True, False, False) 
140     
141          'filter reports for basic five 150415
142         Dim nCatID As Long _ 
143            , sWhere As String 
144     
145         nCatID = 1 
146         Me.lst_aCatID = 1 'report category is Basic Reports '150524 
147         sWhere = "(aRpt.IsActiv=True) AND (aCats.aCatID = " & nCatID & ")" 
148     
149         Call SetControl_RowSource(Me.lst_aRptID, sWhere) 
150     
151         Me.MyNumRec = 0 
152     
153      proc_exit: 
154         Exit Sub 
155     
156      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

Form_BeforeUpdate (18)

157     
158       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Form_BeforeUpdate
159      Private Sub Form_BeforeUpdate(Cancel As Integer) 
160       'Crystal 0409, 130304, 150524
161         On Error Resume Next 
162         Me.dtmEdit = Now() 
163         If IsNull(Me.dbPathFile) Then 
164            Me.Undo 
165            Cancel = True 
166            Exit Sub 
167         End If 
168     
169          'if db title is not filled out, autofill from name
170         If IsNull(Me.dbTitle) Then 
171            Me.dbTitle = Left(Mid(dbPathFile _ 
172               , InStrRev(dbPathFile & Space(3), "\") + 1), 100) 
173         End If 
174      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

Form_Current (50)

175     
176       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Form_Current
177      Private Sub Form_Current() 
178       'strive4peace 100326, 29, 0409, 19, 130324, 26, 130404,11, 130417
179          'CALLS
180          '  Me_TurnOnStuff
181     
182          'On Error GoTo Proc_Err
183     
184         Dim nDbID As Long 
185     
186          'save the DbID so that it can be used for filtering DbTests and usys_DbTests
187         If Me.NewRecord Then 
188            nDbID = -99 
189         Else 
190            nDbID = Me.DbID 
191         End If 
192     
193          'Call SetDbID for querying etc
194         Call SetDbID(nDbID) 
195     
196         Dim bBooNew As Boolean _ 
197            , bBooRun As Boolean _ 
198            , bBooRpt As Boolean 
199     
200         bBooNew = (Me.NewRecord) 
201         If bBooNew Then 
202            bBooRun = False 
203            bBooRpt = False 
204         Else 
205            bBooRun = True 
206            bBooRpt = True 
207         End If 
208     
209          'show or hide controls depending if Analyzer has run, reports need to show, etc. requery stuff
210         Call Me_TurnOnStuff(bBooNew, bBooRun, bBooRpt, nDbID) 
211     
212      proc_exit: 
213         On Error Resume Next 
214         Exit Sub 
215     
216      proc_err: 
217         MsgBox Err.Description, , _ 
218              "ERROR " & Err.Number _ 
219              & "   Form_Current : " & Me.Name 
220     
221         Resume proc_exit 
222         Resume 
223     
224      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

Form_AfterUpdate (7)

225     
226       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Form_AfterUpdate
227     
228      Private Sub Form_AfterUpdate() 
229       'Crystal 130404
230         Me.FindDatabase.Requery 
231      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

Form_Dirty (15)

232     
233       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Form_Dirty
234      Private Sub Form_Dirty(Cancel As Integer) 
235       'Crystal 100330, 0409, 130417
236          'if user enters data in any control before a file is chosen, it is undone
237         If IsNull(Me.dbPathFile) And Me.ActiveControl.Name <> "dbPathFile" Then 
238            Me.Undo 
239            Cancel = True 
240            MsgBox "* CHOOSE DATABASE TO ANALYZE*" _ 
241               & vbCrLf & "  - or - " & vbCrLf _ 
242               & "pick previous analysis from Find combo" _ 
243               , , "Choose Database to Analyze" 
244            Me.cmd_Browse.SetFocus 
245         End If 
246      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

Me_TurnOnStuff (114)

247     
248       '=============================================
249       '            Me_TurnOnStuff, Me_RequeryStuff
250       '=============================================
251     
252       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
253      Private Function Me_TurnOnStuff( _ 
254          ByVal pBooNewVisible As Boolean _ 
255         , ByVal pBooRunVisible As Boolean _ 
256         , ByVal pBooRptVisible As Boolean _ 
257         , Optional pDbID As Long = -999 _ 
258         ) As Boolean 
259     
260       '130404 Crystal
261       '
262          'CALLS
263          '  Me_RequeryStuff
264     
265       '  CALLED BY                     New, Run, Report
266       '     Form_Load                  True, False, False -- doesn't do bRequeryToo
267       '     Form_Current               bBooNew, bBooRun, bBooRpt
268       '     BrowseForDatabase
269       '     Analyzer_0_ObjectSummary                 False, True, False
270       '     Run_AnalyzerTests     False, False, True
271       '
272       ' make visible or not the controls for a New Analysis if TAG has "~New~"
273       '  dbPathFile_Label  * CHOOSE A DATABASE TO ANALYZE *
274       '
275       ' make visible or not the controls to Run Analyzer if TAG has "~Run~"
276       '  cmd_RunAnalyzer
277       '  Label_Include
278       '  Label_ValueAnalysis
279       '  Box_ValueAnalysis (since there is only one choice, border is temporarily transparent)
280       '  DoValT
281       '  DoProp
282       ' pgSecurity (TabAnalyzer)
283       '
284       ' these are currently not implemented (so TAG is -Run~
285       '  DoValQ
286       '  chk_TestRowSources
287       '  chk_Backup
288       '  fra_BackupDirectory
289     
290       ' make visible or not report controls if TAG has "~Rpt~"
291       ' pgReports (TabAnalyzer)
292       ' pgAnalyzer:
293       '        btnTableSummary
294       '        btnDeepAnalysis
295       '        btnFldList
296       '        btnRelationships
297       '        btnTableIndexes
298       '        RptDesc (bound)
299       '        rptOnlyRec (bound)
300       '        dbVer (bound)
301       ' pgDBsettings (bound):
302       '        IsSchemaDS
303       '        AllowBrk
304       '        AllowBIT
305       '        AllowBypass
306       '        AllowFull
307       '        AllowSpec
308       '        AllowSCmen
309       '        AllowTBchg
310       '        ShowDbWin
311       '        ShowStatBar
312       '        HasAutoEx
313       '        StartFrm
314     
315         Dim ctl As Control 
316     
317         Dim booVisible As Integer 
318     
319     
320          'set focus to a safe control -- maybe capture what has focus?
321         Me.cmd_Browse.SetFocus 
322     
323         If pBooNewVisible = True Then 
324             'override what else might have been passed
325            pBooRunVisible = False 
326            pBooRptVisible = False 
327         End If 
328     
329         With Me 
330            For Each ctl In .Controls 
331               booVisible = -99 
332               Select Case True 
333               Case InStr(ctl.Tag, "~New~") > 0 
334                  booVisible = pBooNewVisible 
335               Case InStr(ctl.Tag, "~Rpt~") > 0 And InStr(ctl.Tag, "~Run~") > 0 
336                  booVisible = pBooRptVisible Or pBooRunVisible 
337               Case InStr(ctl.Tag, "~Rpt~") > 0 
338                  booVisible = pBooRptVisible 
339               Case InStr(ctl.Tag, "~Run~") > 0 
340                  booVisible = pBooRunVisible 
341               End Select 
342               If booVisible <> -99 Then   'leave it alone if it is not tagged 
343                  If ctl.Visible <> booVisible Then ctl.Visible = booVisible 
344               End If 
345            Next ctl 
346         End With 
347     
348     
349         If pDbID <> -999 Then 
350            If Me.Dirty Then Me.Dirty = False 
351             'call Me_RequeryStuff
352         End If 
353     
354     
355         Call Me_RequeryStuff(pDbID)   '150418 
356     
357      proc_err: 
358         Set ctl = Nothing 
359     
360      End Function 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

Me_RequeryStuff (145)

361     
362      Private Function Me_RequeryStuff(pDbID As Long) As Boolean 
363       '...150416 s4p
364     
365          'CALLS
366          '  SetSql_Objects
367          '  SetSql_ObjSummary
368          '  SetSql_LinkedDBs
369          '  SetControl_RowSource
370          '  DbTests_MakeQuery
371     
372          'CALLED BY
373          'Me_TurnOnStuff
374     
375         Me_RequeryStuff = False 
376     
377         Dim ctl As Control 
378     
379         Dim iPos As Integer _ 
380            , nNum As Integer _ 
381            , sWhere As String _ 
382            , sSQL As String 
383     
384          'reset SQL for lists
385         Call SetSql_Objects(pDbID) 
386         Call SetSql_ObjSummary(pDbID) 
387         Call SetSql_LinkedDBs(pDbID) 
388     
389         CurrentDb.TableDefs.Refresh 
390         DoEvents 
391         DoEvents 
392         DoEvents 
393     
394          '150416 s4p -----------------
395         sWhere = "T.Dbid = " & pDbID 
396     
397          'call SetControl_RowSource but don't set -- return the SQL and set here
398         sSQL = SetControl_RowSource(Me.MyTID, sWhere, , , , , , True) 
399         With Me.MyTID 
400            .RowSource = sSQL 
401            .Requery 
402         End With 
403     
404     
405     
406         sWhere = "F.Dbid = " & pDbID 
407          'call SetControl_RowSource but don't set -- return the SQL and set here
408         sSQL = SetControl_RowSource(Me.MyFID, sWhere, , , , , , True) 
409         With Me.MyFID 
410            .RowSource = sSQL 
411            .Requery 
412         End With 
413     
414     
415         sWhere = "FF.Dbid = " & pDbID 
416          'call SetControl_RowSource but don't set -- return the SQL and set here
417         sSQL = SetControl_RowSource(Me.MyFrmID, sWhere, , , , , , True) 
418         With Me.MyFrmID 
419            .RowSource = sSQL 
420            .Requery 
421         End With 
422     
423         sWhere = "C.Dbid = " & pDbID 
424          'call SetControl_RowSource but don't set -- return the SQL and set here
425         sSQL = SetControl_RowSource(Me.MyCtLID, sWhere, , , , , , True) 
426         With Me.MyCtLID 
427            .RowSource = sSQL 
428            .Requery 
429         End With 
430          '---------------------------
431     
432       '150415 if label not found, skip
433     
434          'Bold (or not bold) child labels for checkboxes that are checked (or not)
435          'Requery Listboxes (if unbound then set to Null too)
436         With Me.Detail 
437            For Each ctl In .Controls 
438               Select Case ctl.ControlType 
439               Case acCheckBox 
440                'Case InStr(ctl.Tag, "~BoldMe~") > 0
441                  On Error Resume Next 
442                  Call BoldMe(Me, ctl.Name) 
443                  On Error GoTo 0 
444     
445               Case acListBox 
446                  With ctl 
447                     .Requery 
448                     If Not Len(.ControlSource) > 0 Then 
449                         'reset choices user made
450                        If .Value <> Null Then .Value = Null 
451                     End If 
452                  End With   'ctl 
453     
454               Case acOptionGroup 
455                  If .Visible Then 
456                      'see if number of options is in the TAG
457                     iPos = InStr(.Tag, "~#")   '~#2~ means 2 options 
458                     If iPos > 0 Then 
459                        nNum = 0 
460                        On Error Resume Next 
461                        nNum = CInt(Mid(.Tag, iPos + 3, Len(.Tag) - InStr(iPos + 4, .Tag, "~"))) 
462                        On Error GoTo 0 
463                        If nNum > 0 Then 
464                           Call BoldMe(Me, ctl.Name, nNum) 
465                        End If 
466                     End If 
467                  End If 
468     
469               End Select 
470      NextControl: 
471            Next ctl 
472         End With 
473     
474          'call DbTests_MakeQuery
475         If Not DbTests_MakeQuery(CurrentDb, pDbID) Then 
476            MsgBox "Trouble resetting records on the Analyzer Test subform", , "Error" 
477            GoTo proc_exit 
478         Else 
479             'analyzer tests subform - Requery wasn't working - stored the SQL in the Tag
480            On Error Resume Next 
481            DoEvents 
482            With Me.a_f_DbTests_sub.Form 
483               .RecordSource = .Tag 
484            End With 
485         End If 
486         DoEvents 
487     
488         Me_RequeryStuff = True 
489     
490      proc_exit: 
491         On Error Resume Next 
492         Set ctl = Nothing 
493         Exit Function 
494     
495     
496      proc_err: 
497         If Err.Number = 0 Then Resume NextControl 
498         MsgBox Err.Description, , _ 
499              "ERROR " & Err.Number _ 
500              & "   Me_RequeryStuff : " & Me.Name 
501     
502         Resume proc_exit 
503         Resume 
504     
505      End Function 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

cmd_Delete_Click (73)

506     
507       '=======================================
508       '            Delete
509       '=======================================
510     
511       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ cmd_Delete_Click
512      Private Sub cmd_Delete_Click() 
513       'strive4peace 100415, 130404, 160417
514       'change table a_Batches
515          'CALLS
516          '  Form_Load
517          '  Form_AfterUpdate
518     
519       'change table a_DBs
520       'change table a_Settings
521     
522         If Me.Dirty Then Me.Undo 
523         If Me.NewRecord Then 
524            Exit Sub 
525         End If 
526     
527         Dim nDbID As Long _ 
528            , nBatchID As Long _ 
529            , sSQL As String _ 
530            , i As Integer _ 
531            , sTbl As String 
532     
533         nDbID = Me.DbID 
534         If IsNull(Me.BatchID) Then 
535            nBatchID = -99 
536         Else 
537            nBatchID = Me.BatchID 
538         End If 
539     
540         If MsgBox("Delete Current Analysis?" _ 
541            , vbYesNo + vbDefaultButton2, "Delete Analysis?") = vbNo Then Exit Sub 
542     
543         If DoesExist("a_Settings", "T") Then 
544            sSQL = "DELETE * FROM a_Settings WHERE DbID =" & nDbID & ";" 
545            rSql sSQL 
546         End If 
547     
548          'CASCADE DELETE is on
549         sSQL = "DELETE * FROM a_Settings WHERE DbID =" & nDbID & ";" 
550         rSql sSQL 
551         sSQL = "DELETE * FROM a_Ctrlz1 WHERE DbID =" & nDbID & ";" 
552         rSql sSQL 
553         sSQL = "DELETE * FROM a_Forms1 WHERE DbID =" & nDbID & ";" 
554         rSql sSQL 
555         sSQL = "DELETE * FROM a_Reports1 WHERE DbID =" & nDbID & ";" 
556         rSql sSQL 
557         sSQL = "DELETE * FROM a_DBs WHERE DbIDpar =" & nDbID & ";" 
558         rSql sSQL 
559         sSQL = "DELETE * FROM a_DBs WHERE DbID =" & nDbID & ";" 
560         rSql sSQL 
561         If nBatchID <> -99 Then 
562             'there may be other linked records so this may fail
563            sSQL = "DELETE * FROM a_Batches WHERE BatchID =" & nBatchID & ";" 
564            rSql sSQL 
565         End If 
566     
567         CurrentDb.TableDefs.Refresh 
568         Application.RefreshDatabaseWindow 
569         DoEvents 
570         Me.Refresh 
571     
572         Call Form_AfterUpdate 
573         Call Form_Load 
574     
575     
576         MsgBox "Close the database, back it up if you still have results to keep, then compact/repair when opening next time." _ 
577            , , "Done deleting" 
578      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

dbTitle_AfterUpdate (6)

579     
580       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ AfterUpdate
581      Private Sub dbTitle_AfterUpdate() 
582       '130304
583         Me.Dirty = False 
584      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

Label_About_Crystal_Click (12)

585     
586     
587     
588     
589     
590     
591     
592      Private Sub Label_About_Crystal_Click() 
593       '130328
594         Application.FollowHyperlink _ 
595            "mailto: strive4peace2010@yahoo.com?subject=Analyzer Project Ideas" 
596      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

Label_About_DblClick (5)

597     
598      Private Sub Label_About_DblClick(Cancel As Integer) 
599         Application.FollowHyperlink _ 
600            "mailto: strive4peace2010@yahoo.com?subject=Analyzer Project Ideas to share" 
601      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

Label_By_Click (8)

602     
603       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Hyperlinks
604       'handled by Hyperlink Address Property instead of code
605     
606      Private Sub Label_By_Click() 
607         Application.FollowHyperlink _ 
608            "mailto: strive4peace2010@yahoo.com?subject=Analyzer Project Comments" 
609      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

Label_SendComment_Click (39)

610     
611       'Private Sub Label_Crystals_Site_Click()
612       '   Application.FollowHyperlink "http://www.accessmvp.com/strive4peace"
613       'End Sub
614     
615       'Private Sub Label_JoinCodePlex_Click()
616       '   Application.FollowHyperlink "http://analyzer.codeplex.com/"
617       'End Sub
618     
619       'Private Sub Label_Link_ADTejpal_Click()
620       '   Application.FollowHyperlink "http://www.rogersaccesslibrary.com/forum/tejpal-ad_forum45.html"
621          'http://www.rogersaccesslibrary.com/forum/tejpal-ad_forum45&SID=c8a7b14z-4581-c77ez916-3977991a-abfz9126.html
622       'End Sub
623     
624       'Private Sub Label_Link_AllenBrowne_DAO_Click()
625       '   Application.FollowHyperlink "http://allenbrowne.com/func-DAO.html"
626       'End Sub
627     
628       'Private Sub Label_Link_AllenBrowne_Reserved_Click()
629       '   Application.FollowHyperlink "http://allenbrowne.com/AppIssueBadWord.html"
630       'End Sub
631     
632       'Private Sub Label_Link_BillMosca_Click()
633       '   Application.FollowHyperlink "http://thatlldoit.com"
634       'End Sub
635     
636       'Private Sub Label_Link_APIs_Click()
637       'API: Index of APIs on the Access Web
638       '   Application.FollowHyperlink "http://access.mvps.org/access/api/index.html"
639       'End Sub
640     
641       'Private Sub Label_Link_WaynePhillips_Click()
642       '   Application.FollowHyperlink "http://www.everythingaccess.com/vbwatchdog.htm"
643       'End Sub
644     
645      Private Sub Label_SendComment_Click() 
646         Application.FollowHyperlink _ 
647            "mailto: strive4peace2010@yahoo.com?subject=Analyzer Code Comments" 
648      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

lst_aCatID_AfterUpdate (49)

649     
650      Private Sub lst_aCatID_AfterUpdate() 
651       '130421, 150412-15 Crystal, 150809
652     
653          'CALLS
654          '  SetControl_RowSource
655     
656         Dim sWhere As String _ 
657            , naCatID As Long _ 
658            , sCatCode As String 
659     
660     
661             'setcontrol_rowsource
662     
663         With Me.lst_aCatID 
664            If Nz(.Value, 0) = 0 Then   'All 
665               sWhere = "(aRpt.IsActiv=True)" 
666            Else 
667               naCatID = .Value 
668               sCatCode = .Column(2) 
669     
670               sWhere = "(aRpt.IsActiv=True) AND (" _ 
671                  & "(aCats.aCatID = " & naCatID & ")" 
672     
673               If Len(sCatCode) > 0 Then   'modified 160324 s4p 
674                  sWhere = sWhere & " OR (" _ 
675                         & " (instr(aRpt.rTbls, """ & sCatCode & """) >0)" _ 
676                     & ")" 
677               End If 
678     
679               sWhere = sWhere & ")" 
680     
681            End If 
682     
683         End With 
684      Debug.Print sWhere 
685     
686         Call SetControl_RowSource(Me.lst_aRptID, sWhere) 
687     
688       '150412
689          'show or hide criteria for reports
690          'controls starting with "my6" are for fields, which include:
691          ' Deep Analysis (aRptID=2)
692          ' and
693          ' field list (aRptID=3)
694     
695             '(aCats.aCatID)<32000)
696             'SELECT aRpt.aRptID, aRpt.RptTitle, aCats.aCat, aRpt.RptName, aCats.aCatID, aRpt.rTbls FROM a_aCats AS aCats INNER JOIN a_aReports AS aRpt ON aCats.aCatID = aRpt.aCatID WHERE (((aCats.aCatID)<32000) AND ((aRpt.IsActiv)=True)) ORDER BY aRpt.OrdrRpt;
697      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

lst_aRptID_AfterUpdate (21)

698     
699      Private Sub lst_aRptID_AfterUpdate() 
700       '131014
701          'column 5 is the report category, ie:
702          '  ~T~F~I~IF~R~RF~
703     
704          '150412
705         Dim sRptCat As String 
706         If IsNull(Me.ActiveControl) Then Exit Sub 
707     
708         With Me.ActiveControl 
709            sRptCat = .Column(5) 
710         End With 
711     
712         Call SetGroupDb   'set group by to be database level -- 150811 future: -- modify for batch 
713         Call SetDbID(Me.DbID)   '150811 future: change to set GrpID which could be DbID or BatchID 
714     
715         Call cmd_OpenReport_Click 
716     
717     
718      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

MyTID_AfterUpdate (26)

719     
720     
721     
722      Private Sub MyTID_AfterUpdate() 
723       '150416
724         If Me.Dirty Then Me.Dirty = False 
725         If Me.NewRecord Then Exit Sub 
726     
727     
728         Dim sWhere As String _ 
729            , nDbID As Long _ 
730            , nTID As Long 
731     
732     
733         With Me.MyTID 
734            If Not IsNull(.Value) Then 
735               nDbID = Me.DbID 
736               sWhere = "F.Dbid = " & nDbID 
737               nTID = .Value 
738               sWhere = sWhere & "  And f.TID = " & nTID 
739            End If 
740         End With 
741     
742         Call SetControl_RowSource(Me.MyFID, sWhere) 
743     
744      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

chk_DoSort_AfterUpdate (6)

745     
746      Private Sub chk_DoSort_AfterUpdate() 
747       '160422 s4p
748          'force sort fields to recalculate
749         Call Set_Property("local_StripDate", #12/31/2100#, dbDate) 
750      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

ToggleStar (14)

751     
752     
753     
754      Private Function ToggleStar() 
755       'assigned on property sheet for AfterUpdate of togStarC1, togStar...
756       '150416
757         With Me.ActiveControl 
758            If .Value <> True Then 
759               .Caption = " " 
760            Else 
761               .Caption = "*" 
762            End If 
763         End With 
764      End Function 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

ToggleEqual (15)

765     
766      Private Function ToggleEqual() 
767       'assigned on property sheet for AfterUpdate of togEqual_TID, togStar
768       '150416
769         With Me.ActiveControl 
770            If .Value <> True Then 
771               .Caption = "<>" 
772            Else 
773               .Caption = "=" 
774            End If 
775         End With 
776      End Function 
777       '=======================================
778       '            WorkGroup
779       '=======================================
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

WrkGrpFile_BeforeUpdate (19)

780     
781       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ WrkGrpFile_BeforeUpdate
782      Private Sub WrkGrpFile_BeforeUpdate(Cancel As Integer) 
783       'originally written by Bill Mosca
784       'modified by Crystal 100330, 0410
785     
786       '   On Error Resume Next
787          If Len(Me.WrkGrpFile & vbNullString) <> 0 Then 
788              DoCmd.OpenForm "a_f_Login", , , , , acDialog 
789              If g_sUserID & "" = "" Or g_sPWD & "" = "" Then 
790                  Me.WrkGrpFile = Null 
791               Else 
792                  Me.uNm = g_sUserID 
793                  Me.pw = g_sPWD 
794              End If 
795              Me.dbPathFile.SetFocus 
796              Me.Dirty = False 
797          End If 
798      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

WrkGrpFile_Click (8)

799     
800       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ WrkGrpFile_Click
801      Private Sub WrkGrpFile_Click() 
802       '0410
803       '   On Error Resume Next
804         If Me.ActiveControl.Locked Then Exit Sub 
805         Call BrowseForWorkGroup 
806      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

BrowseForWorkGroup (82)

807     
808       '=======================================
809       '            Browse
810       '=======================================
811       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ BrowseForWorkGroup
812      Private Sub BrowseForWorkGroup(Optional pWorkgroupPathFile As String = "") 
813       '100330 modified from Bill's code, 0410
814       '130404 replace API with GetFile_Browse
815       '   calls
816       '     GetFile_Browse
817       '      Get_Property
818       '      Set_Property
819       '
820       ' database properties:
821       '      local_CurrentDir
822       '
823     
824          'On Error GoTo Proc_Err
825     
826         Dim sPathFile As String _ 
827            , sStr As String _ 
828            , nPos As Integer _ 
829            , sLastDir As String 
830     
831       '   Dim nDbID As Long
832     
833         If Len(pWorkgroupPathFile) > 0 Then 
834            sPathFile = pWorkgroupPathFile 
835         Else 
836            If Not IsNull(Me.dbPathFile) Then 
837               nPos = InStrRev(dbPathFile, "\") 
838               If nPos > 0 Then 
839                  sLastDir = Left(dbPathFile, nPos) 
840               End If 
841            Else 
842               sStr = Nz(Get_Property("local_CurrentDir"), "") 
843               sLastDir = sStr 
844            End If 
845     
846            If Not Len(sLastDir & "") > 0 Then 
847               sLastDir = CurrentProject.Path & "\" 
848            End If 
849     
850            sPathFile = GetFile_Browse(, sLastDir, "Choose Workgroup File", "W") 
851     
852            If Len(sPathFile) = 0 Then Exit Sub 
853     
854         End If 
855     
856         sStr = "" 
857         On Error Resume Next 
858         Err.Clear 
859         sStr = Dir(sPathFile) 
860         If Err.Number > 0 Then 
861            MsgBox "Error locating file: " & sPathFile _ 
862               & vbCrLf & vbCrLf _ 
863               , , "Cannot use this workgroup file" 
864            Resume proc_exit 
865         End If 
866         On Error GoTo 0   'Proc_Err 
867     
868         Me.WrkGrpFile = sPathFile 
869     
870         sStr = Left(sPathFile, InStrRev(sPathFile, "\")) 
871         If Len(Trim(sStr)) > 0 Then 
872            Set_Property "local_CurrentDir", sStr, dbText 
873         End If 
874     
875         Me.Dirty = False 
876     
877      proc_exit: 
878         Exit Sub 
879     
880      proc_err: 
881         MsgBox Err.Description, , _ 
882              "ERROR " & Err.Number _ 
883              & "   BrowseForWorkGroup : " & Me.Name 
884     
885         Resume proc_exit 
886         Resume 
887     
888      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

dbPathFile_Click (7)

889     
890       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ dbPathFile_Click
891      Private Sub dbPathFile_Click() 
892         If IsNull(Me.ActiveControl) Then 
893            cmd_Browse_Click 
894         End If 
895      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

dbPathFile_Label_Click (7)

896     
897       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ dbPathFile_Click
898      Private Sub dbPathFile_Label_Click() 
899       '100327
900         Me.cmd_Browse.SetFocus 
901         Call BrowseForDatabase 
902      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

FindDatabase_AfterUpdate (13)

903     
904     
905       '=======================================
906       '            Find
907       '=======================================
908       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Find
909     
910      Private Sub FindDatabase_AfterUpdate() 
911       '0409
912         On Error Resume Next 
913         Call FindRecordN(Me, "DbID") 
914       '   Call Form_Current
915      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

RptDesc_AfterUpdate (18)

916     
917     
918       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Reports
919       'Private Sub btnRelationships_Click()
920       '   On Error Resume Next
921       '   If Not CanReportsRun Then Exit Sub
922       '   DoCmd.OpenReport "zRelationships", acViewPreview, , GetCriteria()
923       'End Sub
924     
925       '=======================================
926       '            Format
927       '=======================================
928     
929       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ RptDesc_AfterUpdate
930      Private Sub RptDesc_AfterUpdate() 
931       '100327, 0409
932         Call BoldMe(Me, "RptDesc") 
933      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

db_AutoCorrectPerform_AfterUpdate (6)

934     
935       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ db_AutoCorrectPerform_AfterUpdate
936      Private Sub db_AutoCorrectPerform_AfterUpdate() 
937       '100327, 0409
938         Call BoldMe(Me, "db_AutoCorrectPerform") 
939      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

IsSchemaDS_AfterUpdate (6)

940     
941       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ IsSchemaDS_AfterUpdate
942      Private Sub IsSchemaDS_AfterUpdate() 
943       '100327, 0409
944         Call BoldMe(Me, "IsSchemaDS") 
945      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

lst_ObjSummary_MouseUp (41)

946     
947       '=======================================
948       '            Object Summary
949       '=======================================
950     
951       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ lst_ObjSummary_MouseUp
952      Private Sub lst_ObjSummary_MouseUp( _ 
953         Button As Integer _ 
954         , Shift As Integer _ 
955         , X As Single _ 
956         , Y As Single _ 
957         ) 
958       'Crystal 100327
959       'SORT Listbox with Object Summary information on the Database Information tab
960     
961          'CALLS
962          '  SetSql_ObjSummary
963     
964          'Arial 11 points -- found this by experimenting'   MsgBox X & " , " & Y
965         If Y > 240 Then Exit Sub 
966     
967          '1";2";2";2";2"
968          '1" ~ 1450
969          '72 pts/inch * 20 pts/twip = 1440 TwipsPerInch
970     
971         Const TWIPSPERINCH = 1440 
972     
973         Dim iSortBy As Integer 
974         Select Case X 
975            Case Is > (9 * TWIPSPERINCH):        iSortBy = 6 
976            Case Is > (7 * TWIPSPERINCH):        iSortBy = 5 
977            Case Is > (5 * TWIPSPERINCH):        iSortBy = 4 
978            Case Is > (3 * TWIPSPERINCH):        iSortBy = 3 
979            Case Is > (1 * TWIPSPERINCH):        iSortBy = 2 
980            Case Else:                   iSortBy = 1 
981         End Select 
982     
983         On Error Resume Next 
984         SetSql_ObjSummary Nz(Me.DbID, -99), iSortBy 
985     
986      End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

SetSql_ObjSummary (79)

987     
988     
989       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ SetSql_ObjSummary
990      Sub SetSql_ObjSummary(pDbID As Long, Optional piSortBy As Integer = 1) 
991       'SORT Listbox by specified Sort number
992       'Crystal 100326, 27, 0410, 130304
993     
994       'use table a_Objs
995     
996         On Error GoTo 0 
997     
998         Dim sSQL As String _ 
999            , sSortField As String _ 
1,000          , sSortedBy As String _ 
1,001          , iPos As Integer 
1,002   
1,003       If pDbID < 0 Then 
1,004          Me.lst_ObjSummary.RowSource = Me.lst_ObjSummary.Tag 
1,005          GoTo proc_exit 
1,006       End If 
1,007   
1,008       sSQL = "SELECT O.ObjTyp AS [Object Type" & IIf(piSortBy = 1, " *", "") & "]" _ 
1,009          & ", Min(O.dtmCreate) AS [Earliest Create" & IIf(piSortBy = 2, " *", "") & "]" _ 
1,010          & ", Min(O.dtmUpdate) AS [Earliest Update" & IIf(piSortBy = 3, " *", "") & "]" _ 
1,011          & ", Max(O.dtmCreate) AS [Last Create" & IIf(piSortBy = 4, " *", "") & "]" _ 
1,012          & ", Max(O.dtmUpdate) AS [Last Update" & IIf(piSortBy = 5, " *", "") & "]" _ 
1,013          & ", Count(O.ObjID) AS [#" & IIf(piSortBy = 6, " *", "") & "]" _ 
1,014          & ", O.ObjOrdr " _ 
1,015          & " FROM a_Objs AS O" _ 
1,016          & " WHERE (O.DbID = " & pDbID & ")" _ 
1,017          & " GROUP BY O.ObjTyp" _ 
1,018          & ", O.ObjOrdr " 
1,019   
1,020       Select Case piSortBy 
1,021       Case 2 
1,022          sSortField = "Min(O.dtmCreate)" 
1,023       Case 3 
1,024          sSortField = "Min(O.dtmUpdate)" 
1,025       Case 4 
1,026          sSortField = "Max(O.dtmCreate)" 
1,027       Case 5 
1,028          sSortField = "Max(O.dtmUpdate)" 
1,029       Case 6 
1,030          sSortField = "Count(O.ObjID)" 
1,031       Case Else   '1 
1,032          sSortField = "ObjOrdr" 
1,033       End Select 
1,034   
1,035       iPos = InStrRev(Me.lst_ObjSummary.RowSource, "ORDER BY ") 
1,036   
1,037       If iPos = 0 Then 
1,038          MsgBox "Error Sorting listbox", , "SetSql_ObjSummary Error" 
1,039          Exit Sub 
1,040       End If 
1,041   
1,042       sSortedBy = Trim(Mid(Me.lst_ObjSummary.RowSource, iPos + 9)) 
1,043   
1,044       If InStr(sSortedBy, sSortField) > 0 And _ 
1,045          InStr(sSortedBy, " DESC") = 0 Then 
1,046   
1,047           'already sorted by this column
1,048          sSQL = sSQL & " ORDER BY " & sSortField & " DESC;" 
1,049          Me.lst_ObjSummary_Label.Caption = "Object Summary sorted by " & sSortField & " descending" 
1,050   
1,051       Else 
1,052          sSQL = sSQL & " ORDER BY " & sSortField & ";" 
1,053          Me.lst_ObjSummary_Label.Caption = "Object Summary sorted by " & sSortField 
1,054       End If 
1,055   
1,056       With Me.lst_ObjSummary 
1,057          .Value = Null 
1,058          .RowSource = sSQL 
1,059          .Requery 
1,060       End With 
1,061   
1,062    proc_exit: 
1,063       Exit Sub 
1,064   
1,065    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

fra_Sort_lst_Objects_AfterUpdate (12)

1,066   
1,067     '=======================================
1,068     '            Object List
1,069     '=======================================
1,070     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Sort
1,071    Private Sub fra_Sort_lst_Objects_AfterUpdate() 
1,072     '130417
1,073        'CALLS
1,074        '  SetSql_Objects
1,075        'Call SetSql_Objects
1,076       Call SetSql_Objects(Nz(Me.DbID, -999)) 
1,077    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

Label_AZ_ZA_Click (7)

1,078   
1,079     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Label_AZ_ZA
1,080    Private Sub Label_AZ_ZA_Click() 
1,081     '100326 Crystal, 0409
1,082       Call SetSql_Objects(Nz(Me.DbID, -99)) 
1,083    End Sub 
1,084     '
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

fra_lst_Objects_Filter_AfterUpdate (7)

1,085   
1,086     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Filter
1,087    Private Sub fra_lst_Objects_Filter_AfterUpdate() 
1,088     '130418
1,089       Call SetSql_Objects(Nz(Me.DbID, -99)) 
1,090       Call BoldMe(Me, "fra_lst_Objects_Filter", 6, Me.fra_lst_Objects_Filter, 0) 
1,091    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

HideGuids_AfterUpdate (7)

1,092   
1,093     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ HideGuids
1,094    Private Sub HideGuids_AfterUpdate() 
1,095     '100327, 0409
1,096       Call BoldMe(Me, "HideGuids") 
1,097       Call SetSql_Objects(Nz(Me.DbID, -99)) 
1,098    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

HideTemps_AfterUpdate (6)

1,099   
1,100     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ HideTemps
1,101    Private Sub HideTemps_AfterUpdate() 
1,102       Call BoldMe(Me, "HideTemps") 
1,103       Call SetSql_Objects(Nz(Me.DbID, -99)) 
1,104    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

HideMSys_AfterUpdate (6)

1,105   
1,106     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ HideMSys
1,107    Private Sub HideMSys_AfterUpdate() 
1,108       Call BoldMe(Me, "HideMSys") 
1,109       Call SetSql_Objects(Nz(Me.DbID, -99)) 
1,110    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

SetSql_Objects (117)

1,111   
1,112   
1,113     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ SetSql_Objects
1,114    Sub SetSql_Objects(pDbID As Long) 
1,115     '100326 Crystal, 0409
1,116     '  CALLED BY
1,117     ' Current
1,118   
1,119     'use table a_Objs
1,120   
1,121       On Error GoTo 0 
1,122   
1,123       Dim sSQL As String _ 
1,124          , i As Integer _ 
1,125          , sSortFields As String _ 
1,126          , nSortByOption As Integer _ 
1,127          , sAZ As String 
1,128   
1,129       If pDbID < 0 Then 
1,130          With Me.lst_Objects 
1,131             .RowSource = .Tag 
1,132             .Requery 
1,133          End With 
1,134          GoTo proc_exit 
1,135       End If 
1,136   
1,137       sSQL = "SELECT O.ObjID, O.ObjTyp, O.ObjName, O.dtmCreate, O.dtmUpdate, O.ObjID_, O.DbID" _ 
1,138          & " FROM a_Objs AS O " _ 
1,139          & " WHERE (O.DbID = " & pDbID & ")" 
1,140   
1,141       If Me.HideGuids Then 
1,142          sSQL = sSQL & " AND (Left(O.ObjName,1) <> ""{"") " 
1,143       End If 
1,144   
1,145       If Me.HideTemps Then 
1,146          sSQL = sSQL & " AND (Left(O.ObjName,1) <> ""~"") " 
1,147       End If 
1,148   
1,149       If Me.HideMSys Then 
1,150          sSQL = sSQL & " AND (Left(O.ObjName,4) <> ""MSys"") " 
1,151       End If 
1,152   
1,153       Select Case Me.fra_lst_Objects_Filter   ' ------------- FUTURE: add object types for web objects 
1,154          Case 1   'tables 
1,155             sSQL = sSQL & " AND O.ObjTypN = 1 " 
1,156          Case 2   'queries 
1,157             sSQL = sSQL & " AND O.ObjTypN = 5 " 
1,158          Case 3   'forms 
1,159             sSQL = sSQL & " AND O.ObjTypN = -32768 " 
1,160          Case 4   'reports 
1,161             sSQL = sSQL & " AND O.ObjTypN = -32764 " 
1,162          Case 5   'macros 
1,163             sSQL = sSQL & " AND O.ObjTypN = -32766 " 
1,164          Case 6   'modules 
1,165             sSQL = sSQL & " AND O.ObjTypN = -32761 " 
1,166       End Select 
1,167   
1,168       nSortByOption = Nz(Me.fra_Sort_lst_Objects, 1) 
1,169   
1,170        'loop through toggel buttons and change caption
1,171       For i = 1 To 5 
1,172           'Caption without sort indicators is stored in control Tag
1,173          With Me("fra_Sort_lst_Objects" & i) 
1,174             If nSortByOption = i Then   ' button that was clicked 
1,175                .FontItalic = -1 
1,176                If Right(.Caption, 1) = ChrW(8595) Then 
1,177                   .Caption = .Tag & " " & ChrW(8593) '" **" 
1,178                   sAZ = " DESC" 
1,179                   Label_AZ_ZA.Caption = "Descending" 
1,180                Else 
1,181                   .Caption = .Tag & " " & ChrW(8595) '" *" 
1,182                   sAZ = "" 
1,183                   Label_AZ_ZA.Caption = "Ascending" 
1,184                End If 
1,185             Else 
1,186                If .Caption <> .Tag Then 
1,187                   .FontItalic = 0 
1,188                   .Caption = .Tag 
1,189                End If 
1,190             End If 
1,191          End With   'frame option 
1,192       Next i 
1,193   
1,194        'set by
1,195       Select Case nSortByOption 
1,196   
1,197       Case 2   'Name, Type 
1,198          sSortFields = "O.ObjName" & sAZ & ", O.ObjOrdr" 
1,199   
1,200       Case 3   'Date Created, Date Updated, Name 
1,201          sSortFields = "O.dtmCreate" & sAZ & ", O.dtmUpdate" & sAZ & ", O.ObjName" 
1,202   
1,203       Case 4   'Date Updated, Date Created, Name 
1,204          sSortFields = "O.dtmUpdate" & sAZ & ", O.dtmCreate" & sAZ & ", O.ObjName" 
1,205   
1,206       Case 5   'Parent, Name 
1,207          sSortFields = "O.ObjID_" & sAZ & ", O.ObjName" 
1,208   
1,209       Case Else   '1 
1,210          sSortFields = "O.ObjOrdr" & sAZ & ", O.ObjName" 
1,211          nSortByOption = 1 
1,212   
1,213       End Select 
1,214       sSQL = sSQL & " ORDER BY " & sSortFields & ";" 
1,215   
1,216   
1,217       With Me.lst_Objects 
1,218          .RowSource = sSQL 
1,219          .Requery 
1,220       End With 
1,221   
1,222       Me.fra_Sort_lst_Objects = 0   'change so that if same button is clicked again this event will be triggered 
1,223   
1,224    proc_exit: 
1,225       Exit Sub 
1,226   
1,227    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

SetSql_LinkedDBs (70)

1,228   
1,229     '=======================================
1,230     '            Linked Databases
1,231     '=======================================
1,232     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ SetSql_LinkedDBs
1,233    Sub SetSql_LinkedDBs(pDbID As Long, Optional piSortBy As Integer = 1) 
1,234     '100410, 17
1,235     'use table a_DBs
1,236   
1,237        'PARAMETERS piSortBy '150524 s4p
1,238        '2: nTbl
1,239        'else left(dbPathFile,255)
1,240       On Error GoTo 0 
1,241   
1,242       Dim sSQL As String _ 
1,243          , sSortField As String _ 
1,244          , sSortedBy As String _ 
1,245          , sCaption As String _ 
1,246          , iPos As Integer 
1,247   
1,248       If pDbID < 0 Then 
1,249          Me.lst_LinkedDBs.RowSource = Me.lst_LinkedDBs.Tag 
1,250          GoTo proc_exit 
1,251       End If 
1,252   
1,253       sSQL = "SELECT a_DBs.DbID " _ 
1,254          & ", a_DBs.nTbl AS [#Tbls]" _ 
1,255          & ", a_DBs.dbPathFile AS [DB Path and File name]" _ 
1,256          & ", a_DBs.DbIDpar" _ 
1,257          & " FROM a_DBs" _ 
1,258          & " WHERE (a_DBs.DbIDpar=" & pDbID & ")"    ' _ 
1,259          & " ORDER BY left(a_DBs.dbPathFile,150);" 
1,260   
1,261       Select Case piSortBy 
1,262       Case 2 
1,263          sSortField = "nTbl" 
1,264       Case Else   '1 
1,265          sSortField = "left(dbPathFile,255)" 
1,266       End Select 
1,267   
1,268       iPos = InStrRev(Me.lst_LinkedDBs.RowSource, "ORDER BY ") 
1,269   
1,270       If iPos = 0 Then 
1,271          MsgBox "Error Sorting listbox", , "SetSql_LinkedDBs Error" 
1,272          Exit Sub 
1,273       End If 
1,274   
1,275       sSortedBy = Trim(Mid(Me.lst_LinkedDBs.RowSource, iPos + 9)) 
1,276   
1,277       If InStr(sSortedBy, sSortField) > 0 And _ 
1,278          InStr(sSortedBy, " DESC") = 0 Then 
1,279           'already sorted by this column
1,280          sSQL = sSQL & " ORDER BY " & sSortField & " DESC;" 
1,281          sCaption = "Back Ends sorted by " & sSortField & " descending" 
1,282       Else 
1,283          sSQL = sSQL & " ORDER BY " & sSortField & ";" 
1,284          sCaption = "Back Ends sorted by " & sSortField 
1,285       End If 
1,286       Me.lst_LinkedDBs_Label.Caption = sCaption 
1,287   
1,288       With Me.lst_LinkedDBs 
1,289          .Value = Null 
1,290          .RowSource = sSQL 
1,291          .Requery 
1,292       End With 
1,293   
1,294    proc_exit: 
1,295       Exit Sub 
1,296   
1,297    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

CanReportsRun (21)

1,298   
1,299     '=======================================
1,300     '            Reports
1,301     '=======================================
1,302     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1,303    Private Function CanReportsRun() As Boolean 
1,304     '130328
1,305     '160422 s4p renamed from Report_IsDataFilled
1,306       CanReportsRun = False 
1,307       If Me.Dirty Then Me.Dirty = False 
1,308       If Me.NewRecord Then 
1,309          MsgBox "You are not on a current record", , "Cannot process report" 
1,310          Exit Function 
1,311       End If 
1,312       If Len(Trim(Me.dbTitle)) = 0 Then 
1,313          Me.dbTitle.SetFocus 
1,314          MsgBox "You have not specified a report title", , "Cannot process report" 
1,315          Exit Function 
1,316       End If 
1,317       CanReportsRun = True 
1,318    End Function 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

Report_GetCriteria (290)

1,319   
1,320    Function Report_GetCriteria( _ 
1,321       Optional psrTbls As String = "" _ 
1,322       , Optional psReportName As String = "" _ 
1,323       , Optional psAdditionalCriteria As String = "" _ 
1,324       ) As String 
1,325     '130328, 130410, 11, 150412, 161022
1,326     '150809 s4p added psReportName, pnBatchID
1,327     '160419 s4p modified for changed field names
1,328     '161022 s4p expanded criteria: toggle = and <>
1,329   
1,330        'PARAMETERS
1,331        '  psrTbls is the string of tables that can supply criteria, ie: ~T~F~
1,332        '  psReportName is the name of the report that is getting criteria
1,333   
1,334   
1,335        'gets information from listbox lst_aRptID
1,336        'aRptID, RptTitle, RptName, rTbls
1,337        '1, Table Summary, a_r_TableSummary, ~D~T~
1,338        'D = Database
1,339        'T = Table
1,340        'F = Fields
1,341        'FS = Field FldStats
1,342        'I = Index
1,343        'IF = Index Fields
1,344        'R = Relationships
1,345        'RF = Relationship Fields
1,346        'RQ = Query with Relationships + Relationship Fields
1,347        'Lk = Lookup Fields (SQL)
1,348        'Rp = Report
1,349        'C = Control
1,350        'A = All -- don't limit by DbID '161022
1,351   
1,352       On Error Resume Next 
1,353       Dim sWhere As String _ 
1,354          , varFriendly As Variant _ 
1,355          , sTblFld As String _ 
1,356          , srTbls As String _ 
1,357          , sPattern As String _ 
1,358          , sOperator As String _ 
1,359          , sMaybeNot As String 
1,360   
1,361       sTblFld = "" 
1,362       sWhere = "" 
1,363   
1,364       varFriendly = Null 
1,365       If Me.Dirty Then Me.Dirty = False 
1,366   
1,367       If InStr(psrTbls, "~A~") > 0 Then   '161022 s4p 
1,368          sWhere = "1=1" 
1,369       Else 
1,370           'use DbID as criteria
1,371          With Me.DbID 
1,372             If IsNull(.Value) Then Exit Function 
1,373             sWhere = "DbID=" & .Value 
1,374          End With 
1,375       End If 
1,376   
1,377        'get the tables from the control
1,378       With Me.lst_aRptID 
1,379           'no report specified
1,380          If IsNull(.Value) Then Exit Function 
1,381          srTbls = .Column(5) 
1,382       End With 
1,383   
1,384       If Len(psrTbls) > 0 Then 
1,385          srTbls = psrTbls 
1,386       End If 
1,387   
1,388        'Tables must be in recordsource to get this criteria
1,389       If InStr(srTbls, "~T~") > 0 Then 
1,390           'ONLY Show tables with records
1,391          If Nz(Me.rptOnlyRec.Value, False) = True Then 
1,392             sWhere = sWhere & " AND (NumRecs >" & Nz(Me.MyNumRec, 0) & ")" 
1,393             varFriendly = (varFriendly + ", ") & "Tables with >" & Nz(Me.MyNumRec, 0) & " Records" 
1,394          End If 
1,395           'Table
1,396          With Me.MyTID 
1,397             If Not IsNull(.Value) Then 
1,398                sOperator = Me.tog_TID.Caption   '161022 s4p 
1,399                sWhere = sWhere & " AND (TID " & sOperator & .Value & ")" 
1,400                  varFriendly = (varFriendly + ", ") & "Table" & sOperator & .Column(1) 
1,401             End If 
1,402          End With 
1,403           'Tablename pattern
1,404          With Me.MyTablePattern 
1,405             If Not IsNull(.Value) Then 
1,406                sPattern = .Value 
1,407                If Me.tog_TID.Caption = "<>" Then   '161022 s4p 
1,408                   sMaybeNot = "Not " 
1,409                Else 
1,410                   sMaybeNot = "" 
1,411                End If 
1,412                If Me.togStarT1 = True Then sPattern = """*" & sPattern Else sPattern = """" & sPattern 
1,413                If Me.togStarT2 = True Then sPattern = sPattern & "*""" Else sPattern = sPattern & """" 
1,414   
1,415                sWhere = sWhere & " AND (Tbl " & sMaybeNot & "LIKE " & sPattern & ")" 
1,416                varFriendly = (varFriendly + ", ") & "tablename " & sMaybeNot & "like " & sPattern 
1,417             End If 
1,418          End With 
1,419       End If 
1,420   
1,421        'Fields must be in recordsource OR "DataType" must be in the report name
1,422       If (InStr(srTbls, "~F~") > 0) _ 
1,423             Or InStr(psReportName, "DataType" > 0) Then 
1,424           'Data Type
1,425          With Me.MyDatTypN 
1,426             If Not IsNull(.Value) Then 
1,427                sOperator = Me.tog_DatTypN.Caption   '161022 s4p 
1,428                sWhere = sWhere & " AND (DatTypN " & sOperator & .Value & ")" 
1,429                varFriendly = (varFriendly + ", ") & "Data Type" & sOperator & .Column(1) 
1,430             End If 
1,431          End With 
1,432       End If 
1,433   
1,434        'Fields must be in recordsource to get this criteria
1,435       If InStr(srTbls, "~F~") > 0 Then 
1,436           'Field FID
1,437          With Me.MyFID 
1,438             If Not IsNull(.Value) Then 
1,439                sOperator = Me.tog_FID.Caption   '161022 s4p 
1,440                sTblFld = .Column(3) 
1,441                sWhere = sWhere & " AND (FID " & sOperator & .Value & ")" 
1,442                  varFriendly = (varFriendly + ", ") & sTblFld & "" & sOperator & .Column(1) 
1,443             End If 
1,444          End With 
1,445           'unique values >= X%
1,446          With Me.MyUniqPercent   '161022 s4p 
1,447             If Not IsNull(.Value) Then 
1,448                sWhere = sWhere & " AND (UniqPc >=" & .Value & ")" 
1,449                  varFriendly = (varFriendly + ", ") & "UniqPc >=" & .Value 
1,450             End If 
1,451          End With 
1,452   
1,453           'field is an AutoNumber
1,454          With Me.MyChkAutoNumber 
1,455             If Not IsNull(.Value) Then 
1,456                If .Value <> True Then   '161022 s4p 
1,457                   sMaybeNot = "Not " 
1,458                Else 
1,459                   sMaybeNot = "" 
1,460                End If 
1,461                sWhere = sWhere & " AND (aAuto=" & .Value & ")" 
1,462                varFriendly = (varFriendly + ", ") & sMaybeNot & "AutoNumber" 
1,463             End If 
1,464          End With 
1,465           'field has Unicode compression
1,466          With Me.MyChkUniCode 
1,467             If Not IsNull(.Value) Then 
1,468                If .Value <> True Then   '161022 s4p 
1,469                   sMaybeNot = "Not " 
1,470                Else 
1,471                   sMaybeNot = "" 
1,472                End If 
1,473                sWhere = sWhere & " AND (UniCpr = " & .Value & ")" 
1,474                varFriendly = (varFriendly + ", ") _ 
1,475                   & sMaybeNot & " UnicodeCompression" 
1,476             End If 
1,477          End With 
1,478           'has validation rule
1,479          With Me.MyChkHasValRule 
1,480             If Not IsNull(.Value) Then 
1,481                If .Value <> True Then   '161022 s4p 
1,482                   sMaybeNot = "Not " 
1,483                Else 
1,484                   sMaybeNot = "" 
1,485                End If 
1,486                sWhere = sWhere & " AND (" _ 
1,487                   & sMaybeNot & " IsNull(ValRule))" 
1,488                varFriendly = (varFriendly + ", " _ 
1,489                   & sMaybeNot & " Validation Rule") 
1,490             End If 
1,491          End With 
1,492   
1,493           'Fieldname pattern
1,494          With Me.MyFieldPattern 
1,495             If Not IsNull(.Value) Then 
1,496                If Me.tog_FID.Caption = "<>" Then   '161022 s4p 
1,497                   sMaybeNot = "Not " 
1,498                Else 
1,499                   sMaybeNot = "" 
1,500                End If 
1,501                sPattern = .Value 
1,502                If Me.togStarF1 = True Then sPattern = """*" & sPattern Else sPattern = """" & sPattern 
1,503                If Me.togStarF2 = True Then sPattern = sPattern & "*""" Else sPattern = sPattern & """" 
1,504   
1,505                sWhere = sWhere & " AND (Fld " & sMaybeNot & "LIKE " & sPattern & ")" 
1,506                varFriendly = (varFriendly + ", ") & "fieldname " & sMaybeNot & "like " & sPattern 
1,507             End If 
1,508          End With 
1,509       End If 
1,510   
1,511        'a_Forms1 must be in recordsource to get this criteria
1,512       If InStr(srTbls, "~FF~") > 0 Then 
1,513   
1,514           'MyFrmID
1,515          With Me.MyFrmID 
1,516             If Not IsNull(.Value) Then 
1,517                sOperator = Me.tog_FrmID.Caption   '161022 s4p 
1,518                sWhere = sWhere & " AND (FrmID" & sOperator & .Value & ")" 
1,519                varFriendly = (varFriendly + ", ") & "Form" & sOperator & .Column(1) 
1,520             End If 
1,521          End With 
1,522   
1,523           'Formname pattern
1,524          With Me.MyFormPattern 
1,525             If Not IsNull(.Value) Then 
1,526   
1,527                If Me.tog_FrmID.Caption = "<>" Then   '161022 s4p 
1,528                   sMaybeNot = "Not " 
1,529                Else 
1,530                   sMaybeNot = "" 
1,531                End If 
1,532                sPattern = .Value 
1,533                If Me.togStarFF1 = True Then sPattern = """*" & sPattern Else sPattern = """" & sPattern 
1,534                If Me.togStarFF2 = True Then sPattern = sPattern & "*""" Else sPattern = sPattern & """" 
1,535   
1,536                sWhere = sWhere & " AND (FrmName " & sMaybeNot & "LIKE " & sPattern & ")" 
1,537                varFriendly = (varFriendly + ", ") & "formname " & sMaybeNot & "like " & sPattern 
1,538             End If 
1,539          End With 
1,540   
1,541       End If 
1,542   
1,543        'a_Ctrlz1 must be in recordsource to get this criteria
1,544       If InStr(srTbls, "~C~") > 0 Then 
1,545   
1,546           'CtLID
1,547          With Me.MyCtLID 
1,548             If Not IsNull(.Value) Then 
1,549                sOperator = Me.tog_CtLID.Caption   '161022 s4p 
1,550                sWhere = sWhere & " AND (CtLID " & sOperator & .Value & ")" 
1,551                varFriendly = (varFriendly + ", ") & "CtL" & sOperator & .Column(1) 
1,552             End If 
1,553          End With 
1,554   
1,555           'ControlType                              '160419
1,556          With Me.MyControlType 
1,557             sOperator = Me.tog_ControlType.Caption   '161022 s4p 
1,558             If Not IsNull(.Value) Then 
1,559                sWhere = sWhere & " AND (c_ControlType" & sOperator & .Value & ")" 
1,560                varFriendly = (varFriendly + ", ") & "CtlType" & sOperator & .Column(1) 
1,561             End If 
1,562          End With 
1,563   
1,564           'control name pattern
1,565          With Me.MyControlPattern 
1,566             If Not IsNull(.Value) Then 
1,567                If Me.tog_CtLID.Caption = "<>" Then   '161022 s4p 
1,568                   sMaybeNot = "Not " 
1,569                Else 
1,570                   sMaybeNot = "" 
1,571                End If 
1,572                sPattern = .Value 
1,573                If Me.togStarC1 = True Then sPattern = """*" & sPattern Else sPattern = """" & sPattern 
1,574                If Me.togStarC2 = True Then sPattern = sPattern & "*""" Else sPattern = sPattern & """" 
1,575   
1,576                sWhere = sWhere & " AND (c_Name " & sMaybeNot & "LIKE " & sPattern & ")" 
1,577                varFriendly = (varFriendly + ", ") & "ctlname " & sMaybeNot & "like " & sPattern 
1,578             End If 
1,579          End With 
1,580       End If 
1,581   
1,582   
1,583        'a_Objs must be in recordsource to get this criteria
1,584       If InStr(srTbls, "~O~") > 0 Then 
1,585   
1,586           'MyobjTypN
1,587          With Me.MyobjTypN 
1,588             If Not IsNull(.Value) Then 
1,589                sOperator = Me.tog_ObjTyp.Caption   '161022 s4p 
1,590                sWhere = sWhere & " AND (ObjTypN " & sOperator & .Value & ")" 
1,591                varFriendly = (varFriendly + ", ") & "ObjType" & sOperator & .Column(1) 
1,592             End If 
1,593          End With 
1,594       End If 
1,595   
1,596        '160418 s4p added for addional criteria (ie: report controls or form controls as opposed to all controls)
1,597       If Len(Trim(psAdditionalCriteria)) > 0 Then 
1,598          sWhere = sWhere & " AND (" & psAdditionalCriteria & ")" 
1,599       End If 
1,600   
1,601    Debug.Print sWhere 
1,602   
1,603        'write friendly descrption on control so it can be read by reports
1,604       Me.txtFriendlyCriteria = varFriendly 
1,605   
1,606       Report_GetCriteria = sWhere 
1,607   
1,608    End Function 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

btnTableSummary_Click (10)

1,609   
1,610     '------------------------------------------------------ 5 basic reports
1,611    Private Sub btnTableSummary_Click() 
1,612     '130329
1,613     '   On Error Resume Next
1,614        'call CanReportsRun
1,615       If Not CanReportsRun() Then Exit Sub 
1,616       DoCmd.OpenReport "a_r_TableSummary", acViewPreview, , Report_GetCriteria() 
1,617   
1,618    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

btnFldList_Click (6)

1,619   
1,620    Private Sub btnFldList_Click() 
1,621     '130329
1,622       If Not CanReportsRun() Then Exit Sub 
1,623       DoCmd.OpenReport "a_r_FieldList", acViewPreview, , Report_GetCriteria() 
1,624    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

btnDeepAnalysis_Click (6)

1,625   
1,626    Private Sub btnDeepAnalysis_Click() 
1,627     '130329
1,628       If Not CanReportsRun() Then Exit Sub 
1,629       DoCmd.OpenReport "a_r_DeepAnalysis", acViewPreview, , Report_GetCriteria() 
1,630    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

btnRelationships_Click (6)

1,631   
1,632    Private Sub btnRelationships_Click() 
1,633     '130329
1,634       If Not CanReportsRun() Then Exit Sub 
1,635       DoCmd.OpenReport "a_r_Relationships", acViewPreview, , Report_GetCriteria() 
1,636    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

btnTableIndexes_Click (6)

1,637   
1,638    Private Sub btnTableIndexes_Click() 
1,639     '130329
1,640       If Not CanReportsRun() Then Exit Sub 
1,641       DoCmd.OpenReport "a_r_TableIndexes", acViewPreview, , Report_GetCriteria() 
1,642    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

lst_aRptID_DblClick (5)

1,643   
1,644    Private Sub lst_aRptID_DblClick(Cancel As Integer) 
1,645     '150412
1,646       Call cmd_OpenReport_Click 
1,647    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

cmd_OpenReport_Click (99)

1,648   
1,649    Private Sub cmd_OpenReport_Click() 
1,650     'Crystal 130405, 10, 20, 150515
1,651     ' 150809 s4p added parameter to Report_GetCriteria
1,652     ' 160422 s4p changed method for applying stips to use database properties
1,653        'USES
1,654        '  a_aStrip table
1,655        '
1,656        'lst_aRptID control
1,657        '     Report name, criteria categories, and additional criteria
1,658   
1,659        'CALLS
1,660        '  CanReportsRun
1,661        '  Report_GetCriteria
1,662        '  Get_Property
1,663        '  Set_Property
1,664   
1,665        'PROPERTIES
1,666        '  local_ReportDate
1,667        '  local_StripDate
1,668   
1,669       If Not CanReportsRun() Then Exit Sub 
1,670   
1,671       Dim bBoo As Boolean _ 
1,672          , dtmStrip As Date _ 
1,673          , sSQL As String _ 
1,674          , sReportName As String _ 
1,675          , sCriteriaCats As String _ 
1,676          , sAdditionalCriteria As String 
1,677   
1,678        '160422 s4p
1,679       Dim nStripDate As Date _ 
1,680          , nReportDate As Date 
1,681   
1,682       If Me.Dirty Then Me.Dirty = False 
1,683       If Me.NewRecord Then Exit Sub 
1,684   
1,685       With Me.lst_aRptID 
1,686          If IsNull(.Value) Then 
1,687             .SetFocus 
1,688             MsgBox "Please choose a report", , "Choose report" 
1,689             Exit Sub 
1,690          End If 
1,691          sReportName = .Column(3) 
1,692          sCriteriaCats = .Column(5) 
1,693          sAdditionalCriteria = .Column(6) 
1,694       End With   'Me.lst_aRptID 
1,695   
1,696   
1,697        'if changes to strips have been made since a report was opened
1,698        'then stripped tablenames need to be calculated
1,699   
1,700        'last time a report was opened
1,701       nReportDate = Get_Property("local_ReportDate", , #1/1/1900#) 
1,702        'last time a strip was changed or checked/unchecked
1,703       nStripDate = Get_Property("local_StripDate", , #12/31/2100#) 
1,704   
1,705       If nStripDate > nReportDate Then 
1,706           'strips have been changed or removed
1,707           'apply strips
1,708   
1,709     '140628 GM - embed "Now()" in SQL string to avoid problem with date formatting in non-US locales
1,710          sSQL = "UPDATE a_Tbls as T " _ 
1,711             & " SET T.TblSort = " 
1,712          If Me.chk_DoSort Then 
1,713              'when SQL runs, strips table is opened and then it will have to be closed -- currently done on AfterUpdate of stips subform
1,714             sSQL = sSQL & "GetStripString(T.Tbl)" 
1,715          Else 
1,716             sSQL = sSQL & "Null" 
1,717          End If 
1,718          sSQL = sSQL _ 
1,719             & ", dtmEdit=Now()" _ 
1,720             & " WHERE DBid=" & Me.DbID _ 
1,721             & ";" 
1,722          rSql sSQL 
1,723   
1,724     '140628 GM - embed "Now()" in SQL string to avoid problem with date formatting in non-US locales
1,725          sSQL = "UPDATE a_Objs as O " _ 
1,726             & " SET O.ObjSort = " 
1,727          If Me.chk_DoSort Then 
1,728              'when SQL runs, strips table is opened and then it will have to be closed -- currently done on AfterUpdate of stips subform
1,729             sSQL = sSQL & "GetStripString(O.ObjName)" 
1,730          Else 
1,731             sSQL = sSQL & "Null" 
1,732          End If 
1,733          sSQL = sSQL _ 
1,734             & ", dtmEdit=Now()" _ 
1,735             & " WHERE DBid=" & Me.DbID _ 
1,736             & ";" 
1,737          rSql sSQL 
1,738   
1,739       End If 
1,740   
1,741       Call Set_Property("local_ReportDate", Now(), dbDate) 
1,742   
1,743       On Error Resume Next 
1,744       DoCmd.OpenReport sReportName, acViewPreview, , Report_GetCriteria(sCriteriaCats, sReportName, sAdditionalCriteria) 
1,745   
1,746    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

cmd_Browse_Click (9)

1,747   
1,748     '=======================================
1,749     '            Analyzer
1,750     '=======================================
1,751   
1,752     '~~~~~~~~~~~~ cmd_Browse_Click
1,753    Private Sub cmd_Browse_Click() 
1,754       Call BrowseForDatabase 
1,755    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

BrowseForDatabase (199)

1,756   
1,757     '~~~~~~~~~~~~ BrowseForDatabase
1,758    Private Sub BrowseForDatabase( _ 
1,759       Optional pDatabasePathFile As String = "" _ 
1,760       ) 
1,761     'Crystal ... 130417, 130519
1,762     '150524 booRun s4p to get rigt data for form report criteria controls
1,763   
1,764        'NEEDS REFERENCE
1,765     '        Microsoft Office #.0 Object Library.
1,766     '
1,767     '0410 proc for making linked db records, check db pathfile length
1,768     '   CALLS
1,769     '     GetFile_Browse
1,770     '     Get_Property
1,771     '     Set_Property
1,772     '     Me_TurnOnStuff
1,773     '     Analyzer_0_ObjectSummary
1,774     '
1,775     '  SET and GET database properties:
1,776     '      local_CurrentDir
1,777     '
1,778     '
1,779        'On Error GoTo Proc_Err
1,780   
1,781       Dim db As DAO.Database 
1,782   
1,783       Dim sPathFile As String _ 
1,784          , sFilename As String _ 
1,785          , sStr As String _ 
1,786          , nPos As Integer _ 
1,787          , sDirectory As String _ 
1,788          , nNumRec As Long _ 
1,789          , nBatchID As Long _ 
1,790          , nDbTypID As Long _ 
1,791          , nDbID As Long _ 
1,792          , sMsg As String _ 
1,793          , booRun As Boolean _ 
1,794          , i As Integer 
1,795   
1,796   
1,797       booRun = False 
1,798       If Me.chk_AllDbs Then 
1,799          sMsg = "Pick an Access Database in the DIRECTORY to Analyze" 
1,800       Else 
1,801          sMsg = "Pick an Access Database to Analyze" 
1,802       End If 
1,803   
1,804        'get default directory for Browse
1,805       If Not IsNull(Me.dbPathFile) Then 
1,806          sPathFile = Me.dbPathFile 
1,807           'call GetFile_Browse
1,808           'parses default directory from path\file
1,809          sPathFile = GetFile_Browse(sPathFile, , sMsg, "A") 
1,810       Else 
1,811           'call Get_Property
1,812          sDirectory = Nz(Get_Property("local_CurrentDir"), "") 
1,813          If Len(sDirectory) < 5 Then 
1,814             sDirectory = CurrentProject.Path & "\" 
1,815          End If 
1,816          sPathFile = GetFile_Browse(, sDirectory, sMsg, "A") 
1,817       End If 
1,818   
1,819       If Not Len(sPathFile) > 0 Then 
1,820          Exit Sub 
1,821       End If 
1,822   
1,823        'if a file was picked, then see if there is anything to save
1,824        ' before making a new record
1,825       If Me.Dirty Then Me.Dirty = False 
1,826   
1,827        'clear the screen while the Analyzer runs
1,828       If Not Me.NewRecord Then 
1,829          DoCmd.RunCommand acCmdRecordsGoToNew 
1,830       End If 
1,831   
1,832        'in here to loop through analyzer -- not currently implemented s4p 150524
1,833     '   If Not Me.chk_AllDbs Then
1,834     '   Else
1,835     '   End If
1,836   
1,837        'ASSUMPTION: path is delimited with "\" -- future: make delimiter a variable
1,838       sFilename = Mid(sPathFile, InStrRev(sPathFile, "\") + 1) 
1,839   
1,840   
1,841   
1,842   
1,843   
1,844   
1,845        '-------------------------------------------------
1,846        'FUTURE: save directory so next time Analyzer is opened, it goes here by default
1,847        'future: create user defaults and make this an option
1,848        'ie: (1) use last directory (2) always start in specified directory
1,849       sStr = Left(sPathFile, InStrRev(sPathFile, "\")) 
1,850       If Len(Trim(sStr)) > 0 Then 
1,851           'call Set_Property
1,852          Call Set_Property("local_CurrentDir", sStr, dbText) 
1,853       End If 
1,854   
1,855       Me.dbPathFile = sPathFile 
1,856   
1,857        'call Me_TurnOnStuff -- show controls for RUN while Analyzer runs
1,858       Call Me_TurnOnStuff(False, True, False) 
1,859   
1,860       If Not Me.TabAnalyzer = 5 Then   'Reports 
1,861          Me.TabAnalyzer = 5 
1,862       End If 
1,863   
1,864        'dbTitle is limited to 100 chars
1,865       If Len(sFilename) > (200 - Len("yymmdd-hhnn")) Then 
1,866          sStr = Left(sFilename, 86) & "..." & Format(Now(), "yymmdd-hhnn") 
1,867       Else 
1,868          sStr = sFilename & ", " & Format(Now(), "yymmdd-hhnn") 
1,869       End If 
1,870   
1,871       Me.dbTitle = sStr 
1,872   
1,873       Me.Dirty = False   'save record so Autonumber will be generated 
1,874        '(in case BE is not Access)
1,875       nDbID = Me.DbID 
1,876   
1,877        '-999 is a code flag for
1,878        ' BatchID
1,879        'and
1,880        ' DbTypID
1,881        'values meaning not defined
1,882        'there is currently no way to set these BEFORE the Object Summary
1,883        ' --- UNLESS code does it or control DefaultValues are set
1,884       If Not IsNull(Me.BatchID) Then 
1,885          nBatchID = Me.BatchID 
1,886       Else 
1,887          nBatchID = -999 
1,888       End If 
1,889   
1,890       If Not IsNull(Me.DbTypID) Then 
1,891          nDbTypID = Me.DbTypID 
1,892       Else 
1,893          nDbTypID = -999 
1,894       End If 
1,895   
1,896        'now that record is saved, get current database
1,897       Set db = CurrentDb 
1,898       db.TableDefs.Refresh 
1,899       DoEvents 
1,900   
1,901        'call Analyzer_0_ObjectSummary
1,902       If Not Analyzer_0_ObjectSummary(sPathFile, nDbID) Then 
1,903          MsgBox "Error creating the Analyzer Object Summary", , "Error" 
1,904          GoTo proc_exit 
1,905       End If 
1,906   
1,907   
1,908   
1,909   
1,910   
1,911   
1,912   
1,913   
1,914   
1,915       Me.Refresh 
1,916   
1,917   
1,918        'Call DbTests_MakeQuery so options show up on Analyzer Run page
1,919       If Not DbTests_MakeQuery(db, nDbID) Then 
1,920          MsgBox "Error preparing the database test subform" _ 
1,921             & vbCrLf, , "Analyzer Note" 
1,922       End If 
1,923   
1,924   
1,925        'call Me_TurnOnStuff - show Run but not reports, requery stuff too
1,926       Call Me_TurnOnStuff(False, True, False, nDbID) 
1,927   
1,928   
1,929   
1,930        'if the tab control is not displaying the RUN tab, switch it
1,931       If Me.TabAnalyzer <> 1 Then 
1,932          Me.TabAnalyzer = 1 
1,933       End If 
1,934   
1,935    proc_exit: 
1,936       On Error Resume Next 
1,937       Set db = Nothing 
1,938       EndTime 
1,939        '150524
1,940       If booRun Then   '150524 
1,941          DoEvents 
1,942          Call Me_RequeryStuff(nDbID)   'report criteria controls 
1,943       End If 
1,944       Exit Sub 
1,945   
1,946    proc_err: 
1,947       MsgBox Err.Description, , _ 
1,948            "ERROR " & Err.Number _ 
1,949            & "   BrowseForDatabase : " & Me.Name 
1,950   
1,951       Resume proc_exit 
1,952       Resume 
1,953   
1,954    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

cmd_RunAnalyzer_Click (15)

1,955   
1,956   
1,957     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ cmd_RunAnalyzer_Click
1,958    Private Sub cmd_RunAnalyzer_Click() 
1,959   
1,960        '160330 s4p make sure Object Summary will run
1,961       Dim sSQL As String 
1,962       sSQL = "UPDATE a_Tests SET DoTst=True WHERE TestID=0 and Not DoTst=True;" 
1,963       Call rSql(sSQL) 
1,964   
1,965     '0409
1,966     '   On Error Resume Next
1,967       Call Run_AnalyzerTests 
1,968   
1,969    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

Run_AnalyzerTests (219)

1,970   
1,971     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Run_AnalyzerTests
1,972    Sub Run_AnalyzerTests() 
1,973     '100327, 0403, 0410, 130303,4, 13407, 131124
1,974     '160330
1,975   
1,976        'CALLS
1,977        '  InitializeProgressMeter
1,978        '  Set_DBLink - sets the global gDbLink object variable
1,979        '  Release_DbLink
1,980        '  Analyzer_100_DataDictionary
1,981        '  Analyzer_101_ValueAnalysis
1,982        '  Analyzer_Forms_Reports
1,983        '  DoTheTest
1,984        '  HasTestRun
1,985        '  Me_TurnOnStuff
1,986        '  ReleaseProgressMeter
1,987   
1,988        'PROGRESS METER FORM (gFormProgressMeter) by TheSmileyCoder
1,989   
1,990       Dim appAccess As Access.Application 
1,991       Dim dbCur As DAO.Database   'CurrentDb -- Analyzer 
1,992   
1,993       Dim sSQL As String _ 
1,994          , sDatabaseFilename As String _ 
1,995          , varWrkGrpFile As Variant _ 
1,996          , nBatchID As Long _ 
1,997          , nDbTypID As Long _ 
1,998          , bDoProp As Boolean _ 
1,999          , nDbID As Long _ 
2,000          , nStartTime As Date 
2,001   
2,002       nStartTime = Now() 
2,003   
2,004        'initialize and open Progress Meter form by The Smiley Coder
2,005       Call InitializeProgressMeter 
2,006   
2,007   
2,008       On Error GoTo 0   'Proc_Err 
2,009   
2,010       If Me.Dirty Then Me.Dirty = False 
2,011       If Me.NewRecord Then Exit Sub 'button shouldn't be showing on new record 
2,012   
2,013       If IsNull(Me.dbPathFile) Then 
2,014          Me.dbPathFile.SetFocus 
2,015          MsgBox "Choose a Database to analyze" _ 
2,016             , , "Cannot Execute" 
2,017          Exit Sub 
2,018       End If 
2,019   
2,020       nDbID = Me.DbID 
2,021       sDatabaseFilename = Me.dbPathFile 
2,022   
2,023       If Not GetNumTestsToRun(nDbID) > 0 Then 
2,024          MsgBox "There are not tests marked to run on this database", , "Exiting" 
2,025          GoTo proc_exit 
2,026       End If 
2,027   
2,028       If IsNull(Me.BatchID) Then 
2,029          nBatchID = -999   'indicator that there is no BatchID 
2,030       Else 
2,031          nBatchID = Me.BatchID 
2,032       End If 
2,033   
2,034     '   DoCmd.OpenForm "PleaseWait"
2,035   
2,036       If Not IsNull(Me.DbTypID) Then 
2,037          nDbTypID = Me.DbTypID 
2,038       Else 
2,039          nDbTypID = -999   'indicator that there is no DbTypID 
2,040       End If 
2,041   
2,042       If Not IsNull(Me.WrkGrpFile) Then 
2,043          varWrkGrpFile = Me.WrkGrpFile 
2,044       Else 
2,045          varWrkGrpFile = Null 
2,046       End If 
2,047   
2,048       g_sUserID = Me.uNm & "" 
2,049       g_sPWD = Me.pw & "" 
2,050   
2,051        '--------------------------------------- make sure the database to analyze can be opened
2,052        'calls code written by Bill Mosca
2,053        ' Set gDBLink
2,054       If Not Set_DBLink(sDatabaseFilename, varWrkGrpFile) Then 
2,055          MsgBox "Can't link to database", , "Aborting" 
2,056          Call Release_DBLink 
2,057          GoTo proc_exit 
2,058       End If 
2,059   
2,060        '-------------------------------------------------- Set Current Database
2,061       Set dbCur = DBEngine.Workspaces(0).Databases(0) 
2,062   
2,063        '-------------------------------------------------- Run the Analyzer
2,064       If DoTheTest(100) Then 
2,065          If Not HasTestRun(nDbID, 100) Then 
2,066              'CALL Analyzer_100_DataDictionary
2,067             If Not Analyzer_100_DataDictionary(dbCur, gDBLink, nDbID, nBatchID, nDbTypID) Then 
2,068        '               Call Analyzer_100_DataDictionary(DbCur, nDbID, nBatchID, nDbTypID)
2,069                ' MsgBox "Analyzer Data Dictionary stopped", , "Aborting Analysis" 'commented 160322 s4p
2,070                ' GoTo Proc_Exit
2,071             End If 
2,072          End If 
2,073       End If 
2,074   
2,075        'Value analysis
2,076       If DoTheTest(101) Then 
2,077          If Not HasTestRun(nDbID, 101) Then 
2,078              'CALL Analyzer_101_ValueAnalysis
2,079             Call Analyzer_101_ValueAnalysis(dbCur, gDBLink, nDbID) 
2,080             sSQL = "UPDATE a_Tbls AS T " _ 
2,081                & " INNER JOIN (a_Flds AS F INNER JOIN a_FldStats AS FS ON F.FID = FS.FID) " _ 
2,082                & " ON T.TID = F.TID SET F.UniqPc = round([Uniq]/[NumRecs],2)" _ 
2,083                & " WHERE (F.DbID=" & nDbID & ") " _ 
2,084                & " AND (T.NumRecs >0)" _ 
2,085                & ";" 
2,086             Call rSql(sSQL, , , , , dbCur) 
2,087             sSQL = "UPDATE a_Flds AS F " _ 
2,088                & " INNER JOIN a_FldStats AS FS ON F.FID = FS.FID " _ 
2,089                & " SET F.BigLen = [MaxLen]" _ 
2,090                & " WHERE (F.DbID=" & nDbID & ") " _ 
2,091                & ";" 
2,092             Call rSql(sSQL, , , , , dbCur) 
2,093          End If 
2,094       End If 
2,095   
2,096        'Lookup fields
2,097       If DoTheTest(110) Then 
2,098          If Not HasTestRun(nDbID, 110) Then 
2,099              'CALL Analyzer_110_LookupFields
2,100             Call Analyzer_110_LookupFields(dbCur, gDBLink, nDbID) 
2,101          End If 
2,102       End If 
2,103   
2,104   
2,105        '------------------------- 1604 s4p
2,106        'after this, tests need the application object
2,107        'release database object
2,108       Call Release_DBLink 
2,109       DoEvents 
2,110        'set application object
2,111       Set appAccess = OpenBypass(sDatabaseFilename) 
2,112   
2,113   
2,114        '-------------------------
2,115        'Forms
2,116       If DoTheTest(300) Then 
2,117          If Not HasTestRun(nDbID, 300) Then 
2,118              'CALL Analyzer_Forms_Reports
2,119             Call Analyzer_Forms_Reports(dbCur, nDbID, appAccess, "F", 300) 
2,120          End If 
2,121       End If 
2,122        'Reports
2,123       If DoTheTest(400) Then 
2,124          If Not HasTestRun(nDbID, 400) Then 
2,125              'CALL Analyzer_400_Forms
2,126             Call Analyzer_Forms_Reports(dbCur, nDbID, appAccess, "R", 400) 
2,127          End If 
2,128       End If 
2,129   
2,130       appAccess.CloseCurrentDatabase 
2,131       Set appAccess = Nothing 
2,132   
2,133        'update max size of MV text fields * 1.2
2,134   
2,135       sSQL = "UPDATE a_Flds AS F INNER JOIN a_FldStats AS Fs ON F.FID = Fs.FID " _ 
2,136          & " SET F.FldSize = Int([fs].[MaxLen]*1.2)" _ 
2,137          & " WHERE F.DbID=" & nDbID _ 
2,138          & ";" 
2,139       Call rSql(sSQL, , , , , dbCur) 
2,140   
2,141   
2,142        '------------ 150824 s4p Optimizer calculations
2,143       Set dbCur = CurrentDb 
2,144       dbCur.TableDefs.Refresh 
2,145       DoEvents 
2,146       Call Calculate_Data_Optimize(nDbID) 
2,147       Call Calculate_CreateRecords_Optimize(dbCur, nDbID, True) 
2,148   
2,149       MsgBox "You may now look at the Analyzer Reports" _ 
2,150          & vbCrLf & vbCrLf & "Time to execute: " _ 
2,151          & Format(DateDiff("s", nStartTime, Now) / 60, "0.#") & " minutes" _ 
2,152          , , "Analyzer done running" 
2,153   
2,154        'if the tab control is not displaying the REPORTS tab, switch it '150723
2,155       On Error Resume Next 
2,156       If Me.TabAnalyzer <> 5 Then 
2,157          Me.TabAnalyzer = 5 
2,158       End If 
2,159     '   Me.dbTitle.SetFocus
2,160   
2,161   
2,162    proc_exit: 
2,163       On Error Resume Next 
2,164       Call Release_DBLink 
2,165       appAccess.CloseCurrentDatabase 
2,166       Set appAccess = Nothing 
2,167       Call ReleaseProgressMeter 
2,168       dbCur.TableDefs.Refresh 
2,169       DoEvents 
2,170       Set dbCur = Nothing 
2,171       CurrentDb.TableDefs.Refresh 
2,172       DoEvents 
2,173   
2,174       Call Me_RequeryStuff(nDbID) 
2,175   
2,176     '   Call Me_TurnOnStuff(False, True, True, nDbID)
2,177       Call EndTime 
2,178       Exit Sub 
2,179   
2,180    proc_err: 
2,181       MsgBox Err.Description, , _ 
2,182            "ERROR " & Err.Number _ 
2,183            & "   Run_AnalyzerTests, Aborting Analyzer " 
2,184   
2,185       Resume proc_exit 
2,186       Resume 
2,187   
2,188    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

cmdSysInfo_Click (6)

2,189   
2,190   
2,191    Private Sub cmdSysInfo_Click() 
2,192     'Bill Mosca's System Information button
2,193      Call StartSysInfo 
2,194    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

cmd_Optimizer_Click (17)

2,195   
2,196     '==
2,197     '==
2,198   
2,199     '------------------------------------------------------- Optimizer
2,200     '
2,201     'Private Sub cmd_ReplaceOptimizerCalculations_Click()
2,202     ''150807 s4p
2,203     '   Call Calculate_Data_Optimize(Nz(Me.DbID, -1), True)
2,204     'End Sub
2,205   
2,206    Private Sub cmd_Optimizer_Click() 
2,207     '150802 strive4peace
2,208   
2,209       Call Do_Optimize2NewDb(Me.DbID) 
2,210   
2,211    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

cmd_EditTblA_Click (7)

2,212   
2,213    Private Sub cmd_EditTblA_Click() 
2,214     '150902 s4p
2,215       Dim nDbID As Long 
2,216       nDbID = Me.DbID 
2,217       DoCmd.OpenForm "oa_f_TblA", , , "DbID=" & nDbID 
2,218    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

cmd_EditFldA_Click (8)

2,219   
2,220    Private Sub cmd_EditFldA_Click() 
2,221     '150902 s4p
2,222       Dim nDbID As Long 
2,223       nDbID = Me.DbID 
2,224       DoCmd.OpenForm "oa_f_FldA", , , "DbID=" & nDbID 
2,225   
2,226    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

cmd_EditProperties_Click (7)

2,227   
2,228    Private Sub cmd_EditProperties_Click() 
2,229     '150807 s4p
2,230   
2,231   
2,232    End Sub 
2,233     '--------------------------------------------------------
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

BatchID_NotInList (70)

2,234   
2,235    Private Sub BatchID_NotInList( _ 
2,236       NewData As String, _ 
2,237       Response As Integer) 
2,238     '150416
2,239        '
2,240   
2,241         ' crystal (strive4peace)
2,242   
2,243         'assumption:
2,244         'the combobox first column is hidden
2,245         'and is the Autonumber record ID  for the source table
2,246   
2,247         'set up Error Handler
2,248         'On Error GoTo Proc_Err
2,249   
2,250        Dim sSQL As String 
2,251   
2,252        Dim db As DAO.Database 
2,253   
2,254          ' Display message box asking if user wants to add a new item
2,255         sSQL = "'" & NewData & "' is not in the current list. " _ 
2,256            & vbCrLf & vbCrLf _ 
2,257            & "Do you want to add it? " _ 
2,258   
2,259          ' if you want the default to be NO instead of Yes,
2,260          ' substitute --> vbYesNo + vbDefaultButton2
2,261   
2,262         Select Case MsgBox(sSQL, vbYesNo, "Add New Data") 
2,263   
2,264   
2,265         Case vbYes 
2,266   
2,267             'assume data to be added is text
2,268            sSQL = "INSERT INTO [a_batches] ([BatNm]) " _ 
2,269                & " SELECT '" & NewData & "';" 
2,270   
2,271     'comment or remove next line after this works correctly
2,272    Debug.Print "batchID NIL -- " & sSQL 
2,273   
2,274       Call rSql(sSQL) 
2,275   
2,276       DoEvents 
2,277   
2,278            'assume SQL to add was ok
2,279   
2,280           Response = acDataErrAdded 
2,281   
2,282        Case Else 
2,283            Response = acDataErrContinue 
2,284        End Select 
2,285   
2,286   
2,287    proc_exit: 
2,288       On Error Resume Next 
2,289       Set db = Nothing 
2,290       Exit Sub 
2,291   
2,292    proc_err: 
2,293        'NOTE: replace ProcedureName with the name of your procedure
2,294       MsgBox Err.Description, , _ 
2,295            "ERROR " & Err.Number _ 
2,296            & "   BatchID_NotInList" 
2,297   
2,298       Resume proc_exit 
2,299   
2,300        'if you want to single-step code to find error, CTRL-Break at MsgBox
2,301        'then set this to be the next statement
2,302       Resume 
2,303    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

cmd_Quit_Click (19)

2,304   
2,305   
2,306   
2,307   
2,308   
2,309   
2,310   
2,311     '===================================================================================
2,312     ' reads RowSource from TAG for:
2,313     'lst_LinkedDBs
2,314     'lst_Objects
2,315     'lst_ObjSummary
2,316     '..... so if you change the RowSource then change the TAG too
2,317   
2,318   
2,319   
2,320    Private Sub cmd_Quit_Click() 
2,321       Application.Quit 
2,322    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

cmd_ResetRptCrit_Click (50)

2,323   
2,324    Private Sub cmd_ResetRptCrit_Click() 
2,325     '150415, 150809 s4p MyBatchID
2,326       Me.MyChkAutoNumber = Null 
2,327       Me.MyChkHasValRule = Null 
2,328       Me.MyChkUniCode = Null 
2,329       Me.MyTID = Null 
2,330       Me.MyTablePattern = Null 
2,331       Me.MyFID = Null 
2,332       Me.MyFieldPattern = Null 
2,333       Me.rptDesc = True 
2,334       Me.rptOnlyRec = False 
2,335       Me.rptConnec = False 
2,336   
2,337       Me.MyFrmID = Null 
2,338       Me.MyCtLID = Null 
2,339       Me.MyFormPattern = Null 
2,340       Me.MyControlPattern = Null 
2,341   
2,342       Me.MyDatTypN = Null 
2,343       Me.MyControlType = Null 
2,344       Me.MyobjTypN = Null 
2,345   
2,346       Me.MyBatchID = Null   '150809 s4p 
2,347   
2,348       With Me.togStarT1 
2,349           .Value = True 
2,350           .Caption = "*" 
2,351       End With 
2,352       With Me.togStarT2: .Value = True: .Caption = "*": End With 
2,353       With Me.togStarF1: .Value = True: .Caption = "*": End With 
2,354       With Me.togStarF2: .Value = True: .Caption = "*": End With 
2,355       With Me.togStarFF1: .Value = True: .Caption = "*": End With 
2,356       With Me.togStarFF2: .Value = True: .Caption = "*": End With 
2,357       With Me.togStarC1: .Value = True: .Caption = "*": End With 
2,358       With Me.togStarC2: .Value = True: .Caption = "*": End With 
2,359   
2,360        '161022
2,361       With Me.tog_TID: .Value = True: .Caption = "=": End With 
2,362       With Me.tog_FID: .Value = True: .Caption = "=": End With 
2,363       With Me.tog_DatTypN: .Value = True: .Caption = "=": End With 
2,364       With Me.tog_FrmID: .Value = True: .Caption = "=": End With 
2,365       With Me.tog_CtLID: .Value = True: .Caption = "=": End With 
2,366       With Me.tog_ControlType: .Value = True: .Caption = "=": End With 
2,367       With Me.tog_ObjTyp: .Value = True: .Caption = "=": End With 
2,368   
2,369   
2,370       Me.MyNumRec = 0 
2,371   
2,372    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

cmd_SetOptimizer_Click (5)

2,373   
2,374    Private Sub cmd_SetOptimizer_Click() 
2,375     '150902
2,376       Call SetOptimizerTests2Run(True) 
2,377    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

cmd_ClearOptimizer_Click (5)

2,378   
2,379    Private Sub cmd_ClearOptimizer_Click() 
2,380     '150902
2,381       Call SetOptimizerTests2Run(False) 
2,382    End Sub 
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

SetOptimizerTests2Run (15)

2,383   
2,384    Private Function SetOptimizerTests2Run(pBoo As Boolean) As Long 
2,385     '150902
2,386       Dim sSQL As String _ 
2,387          , nRecs As Long 
2,388       sSQL = "UPDATE a_Tests AS Tst SET Tst.DoTst = " & pBoo _ 
2,389          & " WHERE (Tst.tstCatID = 1)" _ 
2,390          & " AND (Tst.DoTst <> " & pBoo & ")" _ 
2,391          & ";" 
2,392       nRecs = rSql(sSQL) 
2,393       Me.oa_f_OptTests_sub.Form.Requery 
2,394       MsgBox nRecs & " Optimizer Tests changed to " _ 
2,395          & IIf(pBoo <> True, "NOT ", "") & "Run" 
2,396    End Function 
2,397   
      Goto Top       Goto Form_a_f_ANALYZER_MENU       Goto Index

Form_a_f_DbTests_sub (180)

PROCEDURES       Goto Top       Goto Form_a_f_DbTests_sub       Goto Forms       Goto Index
  1. cmd_DoTst_Click (166)
  2. Declaration Lines (2)
  3. Form_BeforeUpdate (5)
  4. TestID__MouseUp (7)

Declaration Lines (2)

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

cmd_DoTst_Click (166)

3       
4         '============================================================ LICENSE NOTICE -- must not be modified
5         ' The Analyzer 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        '
25        '
26        ' Join Analyzer Developer Project at http://analyzer.codeplex.com/
27        '
28        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140605
29        ' END LICENSE NOTICE
30        '============================================================
31        'MODIFICATIONS:
32        '
33        '140628 Graham Mandeno (GM) : changes to circumvent problems of date formatting in non-US locales
34        '
35        '============================================================
36        '
37        'Private Sub Form_Current()
38        ''130409
39        '   Me.DoTst.Enabled = IsNull(Me.dtmTst1)
40        'End Sub
41      
42       Private Sub cmd_DoTst_Click() 
43        'Crystal 130409, 11, 14, 17
44           'flip DoTst
45      
46        'change table a_Tests
47      
48           'CALLS
49           '  CanTestRun
50        '     GetNumTestsMarked
51        '     GetNumTestsStarted
52        '     GetNumTestsFailed
53        '     GetNumTestsToRun
54      
55          Dim db As DAO.Database 
56      
57          Dim bBoo As Boolean _ 
58             , sSQL As String _ 
59             , nTestID As Long _ 
60             , nNumTests As Long _ 
61             , nNumTestsMarked As Long _ 
62             , nNumTestsStarted As Long _ 
63             , nNumTestsFailed As Long _ 
64             , nNumTestsToRun As Long _ 
65             , sCrit As String _ 
66             , sMsg As String _ 
67             , nDbID As Long 
68      
69          nTestID = Me.TestID 
70          nNumTests = 0 
71      
72          bBoo = Not Me.DoTst 
73      
74          nDbID = Nz(Me.DbID, 0) 
75      
76           'user wants to run the test
77          If bBoo Then 
78              ' make sure test has not already run
79             If Not IsNull(Me.dtmtst1) Then 
80                 '-------------- Maybe just exit without message?
81                MsgBox "Test has already run -- cannot change", , "cannot change" 
82                Exit Sub 
83             End If 
84      
85              'see if there is a parent test specified that must be [/set to] run
86             If Not IsNull(Me.TestID_) Then 
87                 'CALL CanTestRun
88                If Not CanTestRun(nDbID, Me.TestName, Me.TestID_) Then 
89                    'message if problem in CanTestRun
90                   Exit Sub 
91                End If 
92             End If 
93          End If 
94      
95           'ok to change
96        '140628 GM - embed "Now()" in SQL string to avoid problem with date formatting in non-US locales
97          sSQL = "UPDATE a_Tests AS Tst " _ 
98             & " SET Tst.DoTst = " & bBoo _ 
99             & ", dtmEdit=Now()" _ 
100            & " WHERE (Tst.TestID=" & nTestID & ")" _ 
101            & ";" 
102         nNumTests = rSql(sSQL) 
103     
104         sCrit = "(a_Tests.TestID_ =" & nTestID & ")" _ 
105               & " AND (a_Tests.DoTst = True) " _ 
106               & " AND (a_Tests.IsActiv = True)" 
107     
108          'test will not be run
109         If Not bBoo Then 
110             'uncheck tests where this test is a parent
111             ' and it is set to run
112             ' and it is Active
113     
114            sSQL = "UPDATE a_Tests " _ 
115               & " SET a_Tests.DoTst = False " _ 
116               & " WHERE " & sCrit _ 
117               & ";" 
118            nNumTests = nNumTests + rSql(sSQL) 
119     
120         End If 
121     
122         If nNumTests > 0 Then 
123            Set db = CurrentDb 
124             'make sure changes are available immediately
125            db.TableDefs.Refresh 
126            DoEvents 
127             'show new values on form
128            Me.Refresh 
129     
130            If Me.Parent.chk_ShowTestChanges Then 
131     
132               nNumTestsMarked = GetNumTestsMarked() 
133               nNumTestsStarted = GetNumTestsStarted(nDbID) 
134               nNumTestsFailed = GetNumTestsFailed(nDbID) 
135               nNumTestsToRun = GetNumTestsToRun(nDbID) 
136     
137               sMsg = Space(6) & nNumTests & " Test" _ 
138                     & IIf(nNumTests <> 1, "s", "") _ 
139                     & " CHANGED to " & IIf(Not bBoo, " NOT ", "") & " Run" _ 
140                  & vbCrLf & "------------------------" _ 
141                  & vbCrLf _ 
142                  & vbCrLf & Space(3) & Format(nNumTestsMarked, "#;#;'NO';") & " test" _ 
143                     & IIf(nNumTestsMarked <> 1, "s", "") _ 
144                     & " are marked" _ 
145                  & vbCrLf _ 
146                  & vbCrLf & Space(3) & Format(nNumTestsStarted, "#;#;'NONE';") & " already run" _ 
147                  & IIf(nNumTestsFailed > 0, vbCrLf & Space(3) & Format(nNumTestsFailed, "#;#;'NO';") & " test" _ 
148                     & IIf(nNumTestsFailed <> 1, "s", "") _ 
149                     & " failed", "") _ 
150                  & vbCrLf _ 
151                  & vbCrLf & "========================" _ 
152                  & vbCrLf _ 
153                  & vbCrLf & " " & Format(nNumTestsToRun, "#;#;'NO';") & " test" _ 
154                     & IIf(nNumTestsToRun <> 1, "s", "") _ 
155                     & " to run" _ 
156                  & "" 
157     
158               MsgBox sMsg _ 
159                  , , "Analyzer Tests" 
160            End If   'report changes 
161         End If   'something changed 
162     
163      proc_exit:   '150802 s4p -- added release code 
164         On Error Resume Next 
165          'release object variables
166         Set db = Nothing 
167         Exit Sub 
168      End Sub 
      Goto Top       Goto Form_a_f_DbTests_sub       Goto Index

Form_BeforeUpdate (5)

169     
170      Private Sub Form_BeforeUpdate(Cancel As Integer) 
171       '130407
172         Me.dtmEdit = Now() 
173      End Sub 
      Goto Top       Goto Form_a_f_DbTests_sub       Goto Index

TestID__MouseUp (7)

174     
175      Private Sub TestID__MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
176       '130417
177         Me.ActiveControl.Dropdown 
178      End Sub 
179     
180     
      Goto Top       Goto Form_a_f_DbTests_sub       Goto Index

Form_a_f_Login (33)

PROCEDURES       Goto Top       Goto Form_a_f_Login       Goto Forms       Goto Index
  1. cmdCancel_Click (5)
  2. cmdOK_Click (7)
  3. Declaration Lines (13)
  4. Form_Open (8)

Declaration Lines (13)

1         'Properties Setter
2         '
3         'That'll Do IT
4         '
5         'Copyright 2001 Bill Mosca
6         'Warning: This software is protected by copyright law.
7         'Unauthorized reproduction or distribution of this program,
8         'or any portion of it, may result in severe civil and criminal penalties.
9         '
10        'Author: Bill Mosca, wrmosca@thatlldoit.com
11      
12       Option Compare Database 
13       Option Explicit 
      Goto Top       Goto Form_a_f_Login       Goto Index

cmdCancel_Click (5)

14      
15       Private Sub cmdCancel_Click() 
16           DoCmd.Close 
17      
18       End Sub 
      Goto Top       Goto Form_a_f_Login       Goto Index

cmdOK_Click (7)

19      
20       Private Sub cmdOK_Click() 
21           g_sUserID = txtUserID 
22           g_sPWD = txtPassword 
23           DoCmd.Close 
24      
25       End Sub 
      Goto Top       Goto Form_a_f_Login       Goto Index

Form_Open (8)

26      
27       Private Sub Form_Open(Cancel As Integer) 
28           If Me.OpenArgs = "Hide UserID" Then 
29               Me.lblUserID.Visible = False 
30               Me.txtUserID.Visible = False 
31           End If 
32      
33       End Sub 
      Goto Top       Goto Form_a_f_Login       Goto Index

Form_a_f_strip (41)

PROCEDURES       Goto Top       Goto Form_a_f_strip       Goto Forms       Goto Index
  1. Declaration Lines (2)
  2. Form_AfterUpdate (6)
  3. Form_BeforeUpdate (33)

Declaration Lines (2)

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

Form_BeforeUpdate (33)

3       
4         '============================================================ LICENSE NOTICE -- must not be modified
5         ' The Analyzer 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        '
25        '
26        ' Join Analyzer Developer Project at http://analyzer.codeplex.com/
27        '
28        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140605
29        ' END LICENSE NOTICE
30        '============================================================
31      
32       Private Sub Form_BeforeUpdate(Cancel As Integer) 
33        '130405
34          Me.dtmEdit = Now() 
35       End Sub 
      Goto Top       Goto Form_a_f_strip       Goto Index

Form_AfterUpdate (6)

36      
37       Private Sub Form_AfterUpdate() 
38        '140723 WP
39          Call Set_Property("local_StripDate", Now()) 
40           Call mod_Analyzer_SortStrips.ResetStrips 
41       End Sub 
      Goto Top       Goto Form_a_f_strip       Goto Index

Form_f_COLOR_PICKER (108)

PROCEDURES       Goto Top       Goto Form_f_COLOR_PICKER       Goto Forms       Goto Index
  1. CmdClose_Click (17)
  2. Declaration Lines (2)
  3. Form_Activate (14)
  4. Form_Load (17)
  5. OpgStyle_AfterUpdate (18)
  6. TbColors_Change (40)

Declaration Lines (2)

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

CmdClose_Click (17)

3         '
4         'written by AD Tejpal
5         ' modified by Crystal 7-6-08 5am EST
6         '
7        Private Sub CmdClose_Click() 
8        On Error GoTo ErrTrap 
9       
10           DoCmd.Close acForm, Me.Name, acSaveYes 
11      
12       ExitPoint: 
13           On Error GoTo 0 
14           Exit Sub 
15      
16       ErrTrap: 
17           MsgBox Err.Number & " - " & Err.Description 
18           Resume ExitPoint 
19       End Sub 
      Goto Top       Goto Form_f_COLOR_PICKER       Goto Index

Form_Activate (14)

20      
21       Private Sub Form_Activate() 
22       On Error GoTo ErrTrap 
23      
24           DoCmd.Restore 
25      
26       ExitPoint: 
27           On Error GoTo 0 
28           Exit Sub 
29      
30       ErrTrap: 
31           MsgBox Err.Number & " - " & Err.Description 
32           Resume ExitPoint 
33       End Sub 
      Goto Top       Goto Form_f_COLOR_PICKER       Goto Index

Form_Load (17)

34      
35       Private Sub Form_Load() 
36       On Error GoTo ErrTrap 
37      
38            ' Comply with the settings for default page
39            ' of tab control and default value of option group.
40           TbColors_Change 
41           OpgStyle_AfterUpdate 
42      
43       ExitPoint: 
44           On Error GoTo 0 
45           Exit Sub 
46      
47       ErrTrap: 
48           MsgBox Err.Number & " - " & Err.Description 
49           Resume ExitPoint 
50       End Sub 
      Goto Top       Goto Form_f_COLOR_PICKER       Goto Index

OpgStyle_AfterUpdate (18)

51      
52       Private Sub OpgStyle_AfterUpdate() 
53       On Error GoTo ErrTrap 
54      
55           If Me.OpgStyle = 2 Then 
56               Me.SF_Colors_Edit.SourceObject = "F_Colors_Edit_B" 
57           Else 
58               Me.SF_Colors_Edit.SourceObject = "F_Colors_Edit_A" 
59           End If 
60      
61       ExitPoint: 
62           On Error GoTo 0 
63           Exit Sub 
64      
65       ErrTrap: 
66           MsgBox Err.Number & " - " & Err.Description 
67           Resume ExitPoint 
68       End Sub 
      Goto Top       Goto Form_f_COLOR_PICKER       Goto Index

TbColors_Change (40)

69      
70       Private Sub TbColors_Change() 
71       On Error GoTo ErrTrap 
72      
73           Select Case Me.TbColors.Value 
74               Case 2 
75                   Me.OpgStyle.Visible = False 
76                   Me.LbMsg.Caption = "This is a non-editable crosstab " & _ 
77                                   "display (Based upon data in table " & _ 
78                                   "named T_Colors_MyFavorites) - " & _ 
79                                   "Click column head - for custom sort" 
80                   Me.LbMsg.Visible = True 
81               Case 1 
82                   Me.OpgStyle.Visible = False 
83                   Me.LbMsg.Caption = "This is a special " & _ 
84                                   "display - Simulated cont form " & _ 
85                                   "(non-editable) - of data from " & _ 
86                                   "page1 " & "(Based " & _ 
87                                   "upon table named Colors) - " & _ 
88                                   "All controls are unbound" 
89                   Me.LbMsg.Visible = True 
90               Case Else     ' Value is zero (i.e. page 1) 
91                   Me.OpgStyle.Visible = True 
92      
93                   Me.LbMsg.Visible = False 
94           End Select 
95      
96            ' Note - TbColorsValue - 0 for first page,
97            '            1 for second page and so on.
98            '            (Tab control page numbers are zero based)
99      
100      ExitPoint: 
101          On Error GoTo 0 
102          Exit Sub 
103     
104      ErrTrap: 
105          MsgBox Err.Number & " - " & Err.Description 
106          Resume ExitPoint 
107      End Sub 
108     
      Goto Top       Goto Form_f_COLOR_PICKER       Goto Index

Form_F_Colors_AtAGlance (467)

PROCEDURES       Goto Top       Goto Form_F_Colors_AtAGlance       Goto Forms       Goto Index
  1. CmdFirst_Click (5)
  2. CmdLast_Click (27)
  3. CmdNext_Click (4)
  4. CmdPgDn_Click (9)
  5. CmdPgUp_Click (9)
  6. CmdPrev_Click (4)
  7. Declaration Lines (12)
  8. Fn_HighLightCurRec (24)
  9. Fn_SetSortOrder (38)
  10. Form_Close (7)
  11. Form_Load (51)
  12. Form_Open (16)
  13. P_FillControls (28)
  14. P_Next (66)
  15. P_Prev (46)
  16. P_SetNulls (26)
  17. P_SetStatusNavBtns (55)
  18. P_SetValues (40)

Declaration Lines (12)

1        Option Compare Database 
2        Option Explicit 
3       
4         ' written by A.D. Tejpal
5       
6        Private rst As DAO.Recordset 
7        Private RecCount As Long 
8        Private FirstID As Long, LastID As Long 
9        Private SortString As String 
10      
11        ' Number of displayed rows on the form
12       Private Const BlockSize As Long = 12 
      Goto Top       Goto Form_F_Colors_AtAGlance       Goto Index

CmdFirst_Click (5)

13      
14       Private Sub CmdFirst_Click() 
15            ' Similar to first load
16           P_Next 0 
17       End Sub 
      Goto Top       Goto Form_F_Colors_AtAGlance       Goto Index

CmdLast_Click (27)

18      
19       Private Sub CmdLast_Click() 
20       On Error GoTo ErrTrap 
21      
22           Dim Abp As Long 
23      
24            ' Set recordset's absolute pos in such a manner
25            ' that last record and max possible preceding
26            ' records get displayed
27           Abp = RecCount - BlockSize 
28           Abp = IIf(Abp >= 0, Abp, 0) 
29           rst.AbsolutePosition = Abp 
30      
31           P_FillControls 
32      
33           Me.LbRecNo.Caption = Abp + 1 & "  To  " & RecCount 
34      
35           P_SetStatusNavBtns 
36      
37       ExitPoint: 
38           On Error GoTo 0 
39           Exit Sub 
40      
41       ErrTrap: 
42           MsgBox Err.Number & " - " & Err.Description 
43           Resume ExitPoint 
44       End Sub 
      Goto Top       Goto Form_F_Colors_AtAGlance       Goto Index

CmdNext_Click (4)

45      
46       Private Sub CmdNext_Click() 
47           P_Next 1 
48       End Sub 
      Goto Top       Goto Form_F_Colors_AtAGlance       Goto Index

CmdPgDn_Click (9)

49      
50       Private Sub CmdPgDn_Click() 
51            ' The step size has been kept 1 less than
52            ' the total number of displayed rows, so
53            ' as to mainain continuity of display. On
54            ' clicking PgDn button, the contents of
55            ' bottom row move to top row.
56           P_Next BlockSize - 1 
57       End Sub 
      Goto Top       Goto Form_F_Colors_AtAGlance       Goto Index

CmdPgUp_Click (9)

58      
59       Private Sub CmdPgUp_Click() 
60            ' The step size has been kept 1 less than
61            ' the total number of displayed rows, so
62            ' as to mainain continuity of display. On
63            ' clicking PgUp button, the contents of
64            ' top row move to bottom row.
65           P_Prev BlockSize - 1 
66       End Sub 
      Goto Top       Goto Form_F_Colors_AtAGlance       Goto Index

CmdPrev_Click (4)

67      
68       Private Sub CmdPrev_Click() 
69           P_Prev 1 
70       End Sub 
      Goto Top       Goto Form_F_Colors_AtAGlance       Goto Index

Form_Close (7)

71      
72       Private Sub Form_Close() 
73           On Error Resume Next 
74           rst.Close 
75           Set rst = Nothing 
76           On Error GoTo 0 
77       End Sub 
      Goto Top       Goto Form_F_Colors_AtAGlance       Goto Index

Form_Load (51)

78      
79       Private Sub Form_Load() 
80       On Error GoTo ErrTrap 
81      
82           Dim ct As Control 
83      
84            ' Assign function Fn_HighLightCurRec()
85            ' to OnEnter event property of each control
86            ' in detail section. This is meant for highlighting
87            ' first column of current row.
88           For Each ct In Me.Detail.Controls 
89               ct.OnEnter = "=Fn_HighLightCurRec(" & _ 
90                                   CLng(Right(ct.Name, 2)) & ")" 
91           Next 
92      
93            ' This recordset will get closed in form's
94            ' close event.
95           Set rst = Me.RecordsetClone 
96           Me.LbSort.Caption = "Sorted By:  " & SortString & _ 
97                                           "  - (Click column head for custom sort)" 
98      
99           If rst.EOF And rst.BOF Then 
100              P_SetStatusNavBtns 
101              MsgBox "No Records" 
102              GoTo ExitPoint 
103          End If 
104     
105          rst.MoveLast 
106          RecCount = rst.RecordCount 
107          LastID = rst.Fields("ColorID") 
108          rst.MoveFirst 
109          FirstID = rst.Fields("ColorID") 
110     
111           ' Mark first column of first row as current record.
112          Call Fn_HighLightCurRec(1) 
113     
114           ' First Load (signified by step size argument = 0)
115          P_Next 0 
116     
117          Me.LbRecMsg.Caption = "Of  " & RecCount 
118     
119      ExitPoint: 
120          On Error Resume Next 
121          Set ct = Nothing 
122          On Error GoTo 0 
123          Exit Sub 
124     
125      ErrTrap: 
126          MsgBox Err.Number & " - " & Err.Description 
127          Resume ExitPoint 
128      End Sub 
      Goto Top       Goto Form_F_Colors_AtAGlance       Goto Index

P_SetStatusNavBtns (55)

129     
130      Private Sub P_SetStatusNavBtns() 
131      On Error GoTo ErrTrap 
132     
133           ' Sets enabled / disabled status of navigation buttons.
134          Dim TopRec As Long, Cnt As Long 
135          Dim Id1 As Long, Id2 As Long 
136          Dim Rtv As Variant 
137     
138           ' Check whether at last record
139           ' (or whether last row is blank)
140          Rtv = Me("ID_" & Format(BlockSize, "00")) 
141          If IsNull(Rtv) Or Rtv = LastID Then 
142              Me.CmdPgUp.Enabled = True 
143              Me.CmdPrev.Enabled = True 
144              Me.CmdFirst.Enabled = True 
145     
146              Me.CmdPgUp.SetFocus 
147     
148              Me.CmdPgDn.Enabled = False 
149              Me.CmdNext.Enabled = False 
150              Me.CmdLast.Enabled = False 
151          Else 
152              Me.CmdPgDn.Enabled = True 
153              Me.CmdNext.Enabled = True 
154              Me.CmdLast.Enabled = True 
155          End If 
156     
157           ' Check whether at first record
158           ' (or whether first row is blank - No Data)
159          Rtv = Me("ID_01") 
160          If IsNull(Rtv) Or Rtv = FirstID Then 
161              Me.CmdPgDn.Enabled = True 
162              Me.CmdNext.Enabled = True 
163              Me.CmdLast.Enabled = True 
164     
165              Me.CmdPgDn.SetFocus 
166     
167              Me.CmdPgUp.Enabled = False 
168              Me.CmdPrev.Enabled = False 
169              Me.CmdFirst.Enabled = False 
170          Else 
171              Me.CmdPgUp.Enabled = True 
172              Me.CmdPrev.Enabled = True 
173              Me.CmdFirst.Enabled = True 
174          End If 
175     
176      ExitPoint: 
177          On Error GoTo 0 
178          Exit Sub 
179     
180      ErrTrap: 
181          MsgBox Err.Number & " - " & Err.Description 
182          Resume ExitPoint 
183      End Sub 
      Goto Top       Goto Form_F_Colors_AtAGlance       Goto Index

P_Next (66)

184     
185      Private Sub P_Next(Optional _ 
186                  StepSize As Long = 0) 
187      On Error GoTo ErrTrap 
188     
189           ' StepSize = number of records to be stepped
190           ' (0 for first load)
191          Dim Id1 As Variant, Id2 As Variant 
192          Dim Abp1 As Long, Abp2 As Long 
193          Dim Jump As Long, BalRec As Long 
194          Dim RecShownUpto As Long 
195     
196           ' Restrict max step size to one less than
197           ' BlockSize, so that there is continuity of display
198           ' (BlockSize is the number of displayed rows).
199          StepSize = IIf(StepSize < BlockSize, _ 
200                                      StepSize, BlockSize - 1) 
201     
202          rst.MoveFirst 
203          If StepSize > 0 Then 
204              Id1 = Me("ID_01") 
205              If Not IsNull(Id1) Then 
206                  rst.FindFirst "ColorID = " & Id1 
207                  If Not rst.NoMatch Then 
208                      Abp1 = rst.AbsolutePosition 
209                  End If 
210              End If 
211     
212              Id2 = Me("ID_" & Format(BlockSize, "00")) 
213              If Id2 = LastID Or IsNull(Id2) Then 
214                   ' No more records
215                  GoTo ExitPoint 
216              Else 
217                  rst.FindFirst "ColorID = " & Id2 
218                  If Not rst.NoMatch Then 
219                      Abp2 = rst.AbsolutePosition 
220                  End If 
221              End If 
222     
223              BalRec = RecCount - (Abp2 + 1) 
224              Jump = IIf(BalRec >= StepSize, StepSize, BalRec) 
225          Else 
226              Jump = 0 
227          End If 
228     
229           ' Set new starting position
230          rst.AbsolutePosition = Abp1 + Jump 
231     
232          P_FillControls 
233     
234          RecShownUpto = IIf(RecCount - (Abp1 + Jump) > BlockSize, _ 
235                                      Abp1 + Jump + BlockSize, RecCount) 
236     
237          Me.LbRecNo.Caption = Abp1 + 1 + Jump & "  To  " & RecShownUpto 
238     
239      ExitPoint: 
240          On Error Resume Next 
241          P_SetStatusNavBtns 
242          On Error GoTo 0 
243          Exit Sub 
244     
245      ErrTrap: 
246          MsgBox Err.Number & " - " & Err.Description 
247          Resume ExitPoint 
248     
249      End Sub 
      Goto Top       Goto Form_F_Colors_AtAGlance       Goto Index

P_Prev (46)

250     
251      Private Sub P_Prev(Optional StepSize As Long = 1) 
252      On Error GoTo ErrTrap 
253     
254           ' StepSize = number of records to be stepped
255          Dim Id1 As Variant, Jump As Long 
256          Dim Abp1 As Long, RecShownUpto As Long 
257     
258           ' Restrict max step size to one less than
259           ' BlockSize, so that there is continuity of display
260           ' (BlockSize is the number of displayed rows).
261          StepSize = IIf(StepSize < BlockSize, _ 
262                                      StepSize, BlockSize - 1) 
263     
264          rst.MoveFirst 
265          Id1 = Me("ID_01") 
266          If Not IsNull(Id1) Then 
267              rst.FindFirst "ColorID = " & Id1 
268              If Not rst.NoMatch Then 
269                  Abp1 = rst.AbsolutePosition 
270              End If 
271          End If 
272     
273          Jump = IIf(Abp1 >= StepSize, StepSize, Abp1) 
274     
275           ' Set new starting position
276          rst.AbsolutePosition = Abp1 - Jump 
277     
278          P_FillControls 
279     
280          RecShownUpto = IIf(RecCount - (Abp1 - Jump) > BlockSize, _ 
281                                      Abp1 - Jump + BlockSize, RecCount) 
282     
283          Me.LbRecNo.Caption = Abp1 + 1 - Jump & "  To  " & RecShownUpto 
284     
285      ExitPoint: 
286          On Error Resume Next 
287          P_SetStatusNavBtns 
288          On Error GoTo 0 
289          Exit Sub 
290     
291      ErrTrap: 
292          MsgBox Err.Number & " - " & Err.Description 
293          Resume ExitPoint 
294     
295      End Sub 
      Goto Top       Goto Form_F_Colors_AtAGlance       Goto Index

P_FillControls (28)

296     
297      Private Sub P_FillControls() 
298      On Error GoTo ErrTrap 
299     
300          Dim Cnt As Long 
301     
302          Cnt = 1 
303          Do Until (Cnt > 12 Or rst.EOF) 
304              P_SetValues Cnt 
305     
306              Cnt = Cnt + 1 
307              rst.MoveNext 
308          Loop 
309     
310          If Cnt <= 12 Then 
311              For Cnt = Cnt To 12 
312                  P_SetNulls Cnt 
313              Next 
314          End If 
315     
316      ExitPoint: 
317          On Error GoTo 0 
318          Exit Sub 
319     
320      ErrTrap: 
321          MsgBox Err.Number & " - " & Err.Description 
322          Resume ExitPoint 
323      End Sub 
      Goto Top       Goto Form_F_Colors_AtAGlance       Goto Index

P_SetValues (40)

324     
325      Private Sub P_SetValues(Cnt As Long) 
326      On Error GoTo ErrTrap 
327     
328          Dim CNum As Long 
329     
330          Me("RN_" & Format(Cnt, "00")) = rst.AbsolutePosition + 1 
331          Me("ID_" & Format(Cnt, "00")) = rst.Fields("ColorID") 
332          Me("BW_" & Format(Cnt, "00")) = rst.Fields("BW") 
333          Me("C_" & Format(Cnt, "00")) = rst.Fields("ColorName") 
334          Me("S_" & Format(Cnt, "00")) = rst.Fields("Shad") 
335          Me("R_" & Format(Cnt, "00")) = rst.Fields("R") 
336          Me("G_" & Format(Cnt, "00")) = rst.Fields("G") 
337          Me("B_" & Format(Cnt, "00")) = rst.Fields("B") 
338     
339          CNum = Nz(rst.Fields("ColorNumber"), 16777215) 
340          Me("CN_" & Format(Cnt, "00")) = CNum 
341     
342          Me("C_" & Format(Cnt, "00")).BackColor = CNum 
343          Me("S_" & Format(Cnt, "00")).BackColor = CNum 
344          Me("CN_" & Format(Cnt, "00")).BackColor = CNum 
345     
346          If rst.Fields("BW") = "W" Then 
347              Me("C_" & Format(Cnt, "00")).ForeColor = 16777215 
348              Me("S_" & Format(Cnt, "00")).ForeColor = 16777215 
349              Me("CN_" & Format(Cnt, "00")).ForeColor = 16777215 
350          Else 
351              Me("C_" & Format(Cnt, "00")).ForeColor = 0 
352              Me("S_" & Format(Cnt, "00")).ForeColor = 0 
353              Me("CN_" & Format(Cnt, "00")).ForeColor = 0 
354          End If 
355     
356      ExitPoint: 
357          On Error GoTo 0 
358          Exit Sub 
359     
360      ErrTrap: 
361          MsgBox Err.Number & " - " & Err.Description 
362          Resume ExitPoint 
363      End Sub 
      Goto Top       Goto Form_F_Colors_AtAGlance       Goto Index

P_SetNulls (26)

364     
365      Private Sub P_SetNulls(Cnt As Long) 
366      On Error GoTo ErrTrap 
367     
368          Me("RN_" & Format(Cnt, "00")) = Null 
369          Me("ID_" & Format(Cnt, "00")) = Null 
370          Me("BW_" & Format(Cnt, "00")) = Null 
371          Me("C_" & Format(Cnt, "00")) = Null 
372          Me("S_" & Format(Cnt, "00")) = Null 
373          Me("R_" & Format(Cnt, "00")) = Null 
374          Me("G_" & Format(Cnt, "00")) = Null 
375          Me("B_" & Format(Cnt, "00")) = Null 
376          Me("CN_" & Format(Cnt, "00")) = Null 
377     
378          Me("C_" & Format(Cnt, "00")).BackColor = 16777215 
379          Me("S_" & Format(Cnt, "00")).BackColor = 16777215 
380          Me("CN_" & Format(Cnt, "00")).BackColor = 16777215 
381     
382      ExitPoint: 
383          On Error GoTo 0 
384          Exit Sub 
385     
386      ErrTrap: 
387          MsgBox Err.Number & " - " & Err.Description 
388          Resume ExitPoint 
389      End Sub 
      Goto Top       Goto Form_F_Colors_AtAGlance       Goto Index

Fn_HighLightCurRec (24)

390     
391      Private Function Fn_HighLightCurRec(RowNum As Long) 
392      On Error GoTo ErrTrap 
393     
394          Dim Cnt As Long 
395     
396           ' Clear any existing highlight
397          For Cnt = 1 To 12 
398              Me("RN_" & Format(Cnt, "00")).BackColor = 16777215 
399              Me("RN_" & Format(Cnt, "00")).ForeColor = 8388608 
400          Next 
401     
402           ' Set highlight for curent row - in first column.
403          Me("RN_" & Format(RowNum, "00")).BackColor = 8421504      ' 3355443 
404          Me("RN_" & Format(RowNum, "00")).ForeColor = 16777215 
405     
406      ExitPoint: 
407          On Error GoTo 0 
408          Exit Function 
409     
410      ErrTrap: 
411          MsgBox Err.Number & " - " & Err.Description 
412          Resume ExitPoint 
413      End Function 
      Goto Top       Goto Form_F_Colors_AtAGlance       Goto Index

Fn_SetSortOrder (38)

414     
415      Private Function Fn_SetSortOrder(Field1 As String, _ 
416                                          Optional field2 As Variant, _ 
417                                          Optional field3 As Variant) 
418      On Error GoTo ErrTrap 
419          Dim Qst As String, Mode As String 
420     
421     
422          Qst = "SELECT * FROM Q_Colors_AtAGlance " & _ 
423                                      "ORDER BY " 
424     
425           ' Build the field string for ORDER BY clause
426          If InStr(Me.RecordSource, "ORDER BY " & Field1) > 0 Then 
427               ' Toggle primary sort order
428              Mode = IIf(InStr(Me.RecordSource, "Desc") > 0, "Asc", "Desc") 
429          Else 
430              Mode = "Asc" 
431          End If 
432     
433          SortString = Field1 & " " & Mode 
434          If Not IsMissing(field2) Then 
435              SortString = SortString & ", " & field2 
436          End If 
437          If Not IsMissing(field3) Then 
438              SortString = SortString & ", " & field3 
439          End If 
440     
441          Me.RecordSource = Qst & SortString & ";" 
442          Form_Load 
443     
444      ExitPoint: 
445          On Error GoTo 0 
446          Exit Function 
447     
448      ErrTrap: 
449          MsgBox Err.Number & " - " & Err.Description 
450          Resume ExitPoint 
451      End Function 
      Goto Top       Goto Form_F_Colors_AtAGlance       Goto Index

Form_Open (16)

452     
453      Private Sub Form_Open(Cancel As Integer) 
454      On Error GoTo ErrTrap 
455     
456          SortString = "ColorName Asc, Ordr" 
457          Me.RecordSource = "SELECT * FROM Q_Colors_AtAGlance " & _ 
458                                      "ORDER BY " & SortString & ";" 
459     
460      ExitPoint: 
461          On Error GoTo 0 
462          Exit Sub 
463     
464      ErrTrap: 
465          MsgBox Err.Number & " - " & Err.Description 
466          Resume ExitPoint 
467      End Sub 
      Goto Top       Goto Form_F_Colors_AtAGlance       Goto Index

Form_f_Colors_Edit_A (343)

PROCEDURES       Goto Top       Goto Form_f_Colors_Edit_A       Goto Forms       Goto Index
  1. B_KeyDown (25)
  2. BW_KeyDown (25)
  3. colorID_KeyDown (25)
  4. ColorName_KeyDown (25)
  5. ColorNumber_KeyDown (25)
  6. Declaration Lines (47)
  7. Form_BeforeUpdate (4)
  8. Form_Load (12)
  9. G_KeyDown (25)
  10. IsActive_AfterUpdate (4)
  11. Label_emailCrystal_Click (5)
  12. MeRequery (4)
  13. R_KeyDown (25)
  14. ShadeID_KeyDown (25)
  15. ShadeID_NotInList (29)
  16. ShowColor (38)

Declaration Lines (47)

1        Option Compare Database 
2        Option Explicit 
3         '
4         '============================================================ LICENSE NOTICE -- must not be modified
5         ' The Analyzer 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        '
25        '
26        ' Join Analyzer Developer Project at http://analyzer.codeplex.com/
27        '
28        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140605
29        ' END LICENSE NOTICE
30        '============================================================
31        '
32        ' Crystal
33        ' created 2007, modified July 4, 2008
34        '
35        ' enhancements made by A.D. Tejpal July 7, 2008
36        '
37        ' added arrow-key actions by Mark Davis 4-30-2013
38        '
39        '=======================================================
40        '
41        'CALLS
42        '  x_Sort123
43        '
44        ' Control Events call -->
45        ' x_DropMe(False)
46        ' x_DropMeIfNull()
47        ' x_ZoomMe()
      Goto Top       Goto Form_f_Colors_Edit_A       Goto Index

MeRequery (4)

48      
49       Private Function MeRequery() 
50          Me.Requery 
51       End Function 
      Goto Top       Goto Form_f_Colors_Edit_A       Goto Index

ShowColor (38)

52      
53       Private Function ShowColor() 
54       On Error GoTo ErrTrap 
55      
56           Dim Frc As Long, Bkc As Long 
57           Dim Cdn As String 
58      
59           If IsNull(Me.colorID) Then 
60               Bkc = 16777215 
61           Else 
62               Bkc = Me.ColorNumber 
63           End If 
64      
65           If Nz(Me.BW, "B") = "W" Then 
66               Frc = 16777215 
67           Else 
68               Frc = 0 
69           End If 
70      
71            ' Apply conditional formatting to ColorName field
72           Cdn = "ColorID = " & Me.colorID 
73           P_SetNewCondFormat Me.ColorName, Cdn, Bkc, Frc 
74      
75            ' Display current color in footer label also
76           Me.LbColor.Caption = Me.ColorName _ 
77             & (" (" + Me.ShadeID.Column(1) + ")") _ 
78             & vbCrLf & Bkc 
79           Me.LbColor.BackColor = Bkc 
80           Me.LbColor.ForeColor = Frc 
81      
82       ExitPoint: 
83           On Error GoTo 0 
84           Exit Function 
85      
86       ErrTrap: 
87           MsgBox Err.Number & " - " & Err.Description 
88           Resume ExitPoint 
89       End Function 
      Goto Top       Goto Form_f_Colors_Edit_A       Goto Index

IsActive_AfterUpdate (4)

90      
91       Private Sub IsActive_AfterUpdate() 
92          Me.Dirty = False 
93       End Sub 
      Goto Top       Goto Form_f_Colors_Edit_A       Goto Index

B_KeyDown (25)

94      
95       Private Sub B_KeyDown(KeyCode As Integer, Shift As Integer) 
96       On Error GoTo nav_err 
97      
98           Select Case KeyCode 
99               Case 37   ' Left Arrow 
100                  Me.G.SetFocus 
101              Case 38   ' Up Arrow 
102                  DoCmd.GoToRecord , , acPrevious 
103              Case 39   ' Right Arrow 
104                  Me.ColorNumber.SetFocus 
105              Case 40   ' Down Arrow 
106                  DoCmd.GoToRecord , , acNext 
107          End Select 
108     
109      exit_nav: 
110          Exit Sub 
111     
112      nav_err: 
113          If Err.Number = 2501 Then 
114              KeyCode = 0 
115              Resume exit_nav 
116          End If 
117     
118      End Sub 
      Goto Top       Goto Form_f_Colors_Edit_A       Goto Index

BW_KeyDown (25)

119     
120      Private Sub BW_KeyDown(KeyCode As Integer, Shift As Integer) 
121      On Error GoTo nav_err 
122     
123          Select Case KeyCode 
124              Case 37   ' Left Arrow 
125                  Me.colorID.SetFocus 
126              Case 38   ' Up Arrow 
127                  DoCmd.GoToRecord , , acPrevious 
128              Case 39   ' Right Arrow 
129                  Me.ColorName.SetFocus 
130              Case 40   ' Down Arrow 
131                  DoCmd.GoToRecord , , acNext 
132          End Select 
133     
134      exit_nav: 
135          Exit Sub 
136     
137      nav_err: 
138          If Err.Number = 2501 Then 
139              KeyCode = 0 
140              Resume exit_nav 
141          End If 
142     
143      End Sub 
      Goto Top       Goto Form_f_Colors_Edit_A       Goto Index

colorID_KeyDown (25)

144     
145      Private Sub colorID_KeyDown(KeyCode As Integer, Shift As Integer) 
146      On Error GoTo nav_err 
147     
148          Select Case KeyCode 
149              Case 37   ' Left Arrow 
150                  Me.ColorNumber.SetFocus 
151              Case 38   ' Up Arrow 
152                  DoCmd.GoToRecord , , acPrevious 
153              Case 39   ' Right Arrow 
154                  Me.BW.SetFocus 
155              Case 40   ' Down Arrow 
156                  DoCmd.GoToRecord , , acNext 
157          End Select 
158     
159      exit_nav: 
160          Exit Sub 
161     
162      nav_err: 
163          If Err.Number = 2501 Then 
164              KeyCode = 0 
165              Resume exit_nav 
166          End If 
167     
168      End Sub 
      Goto Top       Goto Form_f_Colors_Edit_A       Goto Index

ColorName_KeyDown (25)

169     
170      Private Sub ColorName_KeyDown(KeyCode As Integer, Shift As Integer) 
171      On Error GoTo nav_err 
172     
173          Select Case KeyCode 
174              Case 37   ' Left Arrow 
175                  Me.BW.SetFocus 
176              Case 38   ' Up Arrow 
177                  DoCmd.GoToRecord , , acPrevious 
178              Case 39   ' Right Arrow 
179                  Me.ShadeID.SetFocus 
180              Case 40   ' Down Arrow 
181                  DoCmd.GoToRecord , , acNext 
182          End Select 
183     
184      exit_nav: 
185          Exit Sub 
186     
187      nav_err: 
188          If Err.Number = 2501 Then 
189              KeyCode = 0 
190              Resume exit_nav 
191          End If 
192     
193      End Sub 
      Goto Top       Goto Form_f_Colors_Edit_A       Goto Index

ColorNumber_KeyDown (25)

194     
195      Private Sub ColorNumber_KeyDown(KeyCode As Integer, Shift As Integer) 
196      On Error GoTo nav_err 
197     
198          Select Case KeyCode 
199              Case 37   ' Left Arrow 
200                  Me.B.SetFocus 
201              Case 38   ' Up Arrow 
202                  DoCmd.GoToRecord , , acPrevious 
203              Case 39   ' Right Arrow 
204                  Me.colorID.SetFocus 
205              Case 40   ' Down Arrow 
206                  DoCmd.GoToRecord , , acNext 
207          End Select 
208     
209      exit_nav: 
210          Exit Sub 
211     
212      nav_err: 
213          If Err.Number = 2501 Then 
214              KeyCode = 0 
215              Resume exit_nav 
216          End If 
217     
218      End Sub 
      Goto Top       Goto Form_f_Colors_Edit_A       Goto Index

Form_BeforeUpdate (4)

219     
220      Private Sub Form_BeforeUpdate(Cancel As Integer) 
221         Me.ColorNumber = RGB(Nz(Me.R), Nz(Me.G), Nz(Me.B)) 
222      End Sub 
      Goto Top       Goto Form_f_Colors_Edit_A       Goto Index

Form_Load (12)

223     
224      Private Sub Form_Load() 
225           ' Clear any existing form level sort or filter
226          Me.OrderByOn = False 
227          Me.FilterOn = False           ' (A) 
228     
229           ' Note - Statement (A) is redundant, as default
230           '            status of FilterOn is False when the form
231           '            loads. However it is included as abundant
232           '            precaution (if there is any change in future
233           '            versions).
234      End Sub 
      Goto Top       Goto Form_f_Colors_Edit_A       Goto Index

G_KeyDown (25)

235     
236      Private Sub G_KeyDown(KeyCode As Integer, Shift As Integer) 
237      On Error GoTo nav_err 
238     
239          Select Case KeyCode 
240              Case 37   ' Left Arrow 
241                  Me.R.SetFocus 
242              Case 38   ' Up Arrow 
243                  DoCmd.GoToRecord , , acPrevious 
244              Case 39   ' Right Arrow 
245                  Me.B.SetFocus 
246              Case 40   ' Down Arrow 
247                  DoCmd.GoToRecord , , acNext 
248          End Select 
249     
250      exit_nav: 
251          Exit Sub 
252     
253      nav_err: 
254          If Err.Number = 2501 Then 
255              KeyCode = 0 
256              Resume exit_nav 
257          End If 
258     
259      End Sub 
      Goto Top       Goto Form_f_Colors_Edit_A       Goto Index

Label_emailCrystal_Click (5)

260     
261      Private Sub Label_emailCrystal_Click() 
262         Application.FollowHyperlink _ 
263            "mailto: strive4peace2010@yahoo.com?subject=Color Picker v.3 comment from Analyzer" 
264      End Sub 
      Goto Top       Goto Form_f_Colors_Edit_A       Goto Index

R_KeyDown (25)

265     
266      Private Sub R_KeyDown(KeyCode As Integer, Shift As Integer) 
267      On Error GoTo nav_err 
268     
269          Select Case KeyCode 
270              Case 37   ' Left Arrow 
271                  Me.ShadeID.SetFocus 
272              Case 38   ' Up Arrow 
273                  DoCmd.GoToRecord , , acPrevious 
274              Case 39   ' Right Arrow 
275                  Me.G.SetFocus 
276              Case 40   ' Down Arrow 
277                  DoCmd.GoToRecord , , acNext 
278          End Select 
279     
280      exit_nav: 
281          Exit Sub 
282     
283      nav_err: 
284          If Err.Number = 2501 Then 
285              KeyCode = 0 
286              Resume exit_nav 
287          End If 
288     
289      End Sub 
      Goto Top       Goto Form_f_Colors_Edit_A       Goto Index

ShadeID_KeyDown (25)

290     
291      Private Sub ShadeID_KeyDown(KeyCode As Integer, Shift As Integer) 
292      On Error GoTo nav_err 
293     
294          Select Case KeyCode 
295              Case 37   ' Left Arrow 
296                  Me.ColorName.SetFocus 
297              Case 38   ' Up Arrow 
298                  DoCmd.GoToRecord , , acPrevious 
299              Case 39   ' Right Arrow 
300                  Me.R.SetFocus 
301              Case 40   ' Down Arrow 
302                  DoCmd.GoToRecord , , acNext 
303          End Select 
304     
305      exit_nav: 
306          Exit Sub 
307     
308      nav_err: 
309          If Err.Number = 2501 Then 
310              KeyCode = 0 
311              Resume exit_nav 
312          End If 
313     
314      End Sub 
      Goto Top       Goto Form_f_Colors_Edit_A       Goto Index

ShadeID_NotInList (29)

315     
316      Private Sub ShadeID_NotInList( _ 
317         NewData As String, _ 
318         Response As Integer) 
319     
320          Dim s As String _ 
321            , mRecordID As Long _ 
322            , mText As String 
323     
324           'convert to ProperCase
325          mText = StrConv(NewData, vbProperCase) 
326     
327          s = "INSERT INTO Shades(Shad) " _ 
328             & " SELECT '" & mText & "';" 
329     
330        '~~~~~~~~~~~~~~~~~~~~~~~~
331     
332       'comment or remove next line after this works correctly
333      Debug.Print s 
334     
335          CurrentDb.Execute s 
336     
337          DoEvents 
338     
339         Response = acDataErrAdded 
340       '   Me.ShadeID = mRecordID
341     
342      End Sub 
343       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      Goto Top       Goto Form_f_Colors_Edit_A       Goto Index

Form_F_Colors_Edit_B (517)

PROCEDURES       Goto Top       Goto Form_F_Colors_Edit_B       Goto Forms       Goto Index
  1. B_AfterUpdate (30)
  2. ColorNumber_DblClick (25)
  3. Declaration Lines (64)
  4. Form_Current (35)
  5. Form_Load (32)
  6. G_AfterUpdate (30)
  7. IsActive_AfterUpdate (4)
  8. Label_emailCrystal_Click (5)
  9. P_PopulateSliderBarsForNewDataSource (29)
  10. P_SetColorNumber (17)
  11. P_SetSlider (32)
  12. R_AfterUpdate (30)
  13. SB_MouseDown (18)
  14. SB_MouseMove (18)
  15. SB_MouseUp (5)
  16. SG_MouseDown (17)
  17. SG_MouseMove (18)
  18. SG_MouseUp (5)
  19. ShadeID_NotInList (29)
  20. ShowColor (34)
  21. SR_MouseDown (17)
  22. SR_MouseMove (18)
  23. SR_MouseUp (5)

Declaration Lines (64)

1        Option Compare Database 
2        Option Explicit 
3         '
4         '============================================================ LICENSE NOTICE -- must not be modified
5         ' The Analyzer 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        '
25        '
26        ' Join Analyzer Developer Project at http://analyzer.codeplex.com/
27        '
28        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140605
29        ' END LICENSE NOTICE
30        '============================================================
31        '
32        ' Crystal
33        ' created 2007, modified July 4, 2008
34        '
35        ' enhancements made by A.D. Tejpal July 7, 2008
36        '
37        '=======================================================
38        '
39        'CALLS
40        '  x_Sort123
41        '
42        ' Control Events call -->
43        ' x_DropMe(False)
44        ' x_DropMeIfNull()
45        ' x_ZoomMe()
46      
47        ' This part is based upon SliderBar written by Bill Mosca
48        ' (Modified by A.D.Tejpal)
49        '==========================================
50        'This will be used to determine if the mouse button is down or not.
51       Private pbolMouseDown As Boolean 
52      
53        ' Width of SliderControl
54       Private SliderWidth As Long 
55      
56        'This is our top range.
57       Private Const plngTop As Long = 255 
58      
59        ' Character used for slider string
60       Private Const SlideChr As String = "I" 
61      
62        ' Coversion factor - Control width to text length
63        ' (This is for I character, size 8, Times New Roman)
64       Private Const WidthFactor As Single = 61.6 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

P_SetSlider (32)

65      
66       Private Sub P_SetSlider(ControlName As String, X As Single) 
67       On Error GoTo ErrTrap 
68      
69            ' Allow for X > SliderWidth when pressed mouse
70            ' is dragged fast upto & beyond right edge of slider)
71           If X > SliderWidth - 5 Then       ' Safety margin = 5 
72               Me(ControlName) = plngTop 
73           Else 
74               Me(ControlName) = Int((X / SliderWidth) * plngTop) 
75           End If 
76      
77           Select Case ControlName 
78               Case "R" 
79                   R_AfterUpdate 
80               Case "G" 
81                   G_AfterUpdate 
82               Case "B" 
83                   B_AfterUpdate 
84           End Select 
85      
86        '    Screen.ActiveControl.SelStart = 0           ' Not effective
87        '    Screen.ActiveControl.SelLength = 0        ' Not effective
88      
89       ExitPoint: 
90           On Error GoTo 0 
91           Exit Sub 
92      
93       ErrTrap: 
94           MsgBox Err.Number & " - " & Err.Description 
95           Resume ExitPoint 
96       End Sub 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

P_SetColorNumber (17)

97      
98       Private Sub P_SetColorNumber() 
99       On Error GoTo ErrTrap 
100     
101          Me.ColorNumber = RGB(Me.R, Me.G, Me.B) 
102     
103          Call ShowColor 
104     
105      ExitPoint: 
106          On Error GoTo 0 
107          Exit Sub 
108     
109      ErrTrap: 
110          MsgBox Err.Number & " - " & Err.Description 
111          Resume ExitPoint 
112     
113      End Sub 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

P_PopulateSliderBarsForNewDataSource (29)

114     
115      Private Sub P_PopulateSliderBarsForNewDataSource() 
116           ' To be used only once if the source table is changed.
117          On Error GoTo ErrTrap 
118     
119          Dim rst As DAO.Recordset 
120     
121          Set rst = Me.Recordset 
122     
123          Do Until rst.EOF 
124               ' Synchronize Slider Bars
125              R_AfterUpdate 
126              G_AfterUpdate 
127              B_AfterUpdate 
128     
129              rst.MoveNext 
130          Loop 
131          rst.MoveFirst 
132     
133      ExitPoint: 
134          On Error Resume Next 
135          Set rst = Nothing 
136          On Error GoTo 0 
137          Exit Sub 
138     
139      ErrTrap: 
140          MsgBox Err.Number & " - " & Err.Description 
141          Resume ExitPoint 
142      End Sub 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

ColorNumber_DblClick (25)

143     
144      Private Sub ColorNumber_DblClick(Cancel As Integer) 
145      On Error GoTo ErrTrap 
146     
147           ' Restore old values
148          Me.R = Me.R_Old 
149          Me.G = Me.G_Old 
150          Me.B = Me.B_Old 
151     
152           ' Synchronize Slider Bars
153          R_AfterUpdate 
154          G_AfterUpdate 
155          B_AfterUpdate 
156     
157       '    Screen.ActiveControl.SelStart = 0           ' Not effective
158       '    Screen.ActiveControl.SelLength = 0        ' Not effective
159     
160      ExitPoint: 
161          On Error GoTo 0 
162          Exit Sub 
163     
164      ErrTrap: 
165          MsgBox Err.Number & " - " & Err.Description 
166          Resume ExitPoint 
167      End Sub 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

SB_MouseDown (18)

168     
169      Private Sub SB_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 
170          On Error GoTo ErrTrap 
171     
172           'Capture MouseDown event and get the rating based
173           'on the mouse pointer position.
174          pbolMouseDown = True 
175          P_SetSlider "B", X 
176     
177      ExitPoint: 
178          On Error Resume Next 
179          On Error GoTo 0 
180          Exit Sub 
181     
182      ErrTrap: 
183          MsgBox Err.Number & " - " & Err.Description 
184          Resume ExitPoint 
185      End Sub 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

SB_MouseMove (18)

186     
187      Private Sub SB_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 
188      On Error GoTo ErrTrap 
189     
190           'Determine if mouse is down. If it is, resize the rating label and
191           'assign a value to the Rating textbox.
192          If pbolMouseDown Then 
193              P_SetSlider "B", X 
194          End If 
195     
196      ExitPoint: 
197          On Error GoTo 0 
198          Exit Sub 
199     
200      ErrTrap: 
201          MsgBox Err.Number & " - " & Err.Description 
202          Resume ExitPoint 
203      End Sub 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

SB_MouseUp (5)

204     
205      Private Sub SB_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
206           'Clear MouseDown event
207          pbolMouseDown = False 
208      End Sub 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

SG_MouseDown (17)

209     
210      Private Sub SG_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 
211      On Error GoTo ErrTrap 
212     
213           'Capture MouseDown event and get the rating based
214           'on the mouse pointer position.
215          pbolMouseDown = True 
216          P_SetSlider "G", X 
217     
218      ExitPoint: 
219          On Error GoTo 0 
220          Exit Sub 
221     
222      ErrTrap: 
223          MsgBox Err.Number & " - " & Err.Description 
224          Resume ExitPoint 
225      End Sub 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

SG_MouseMove (18)

226     
227      Private Sub SG_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 
228      On Error GoTo ErrTrap 
229     
230           'Determine if mouse is down. If it is, resize the rating label and
231           'assign a value to the Rating textbox.
232          If pbolMouseDown Then 
233              P_SetSlider "G", X 
234          End If 
235     
236      ExitPoint: 
237          On Error GoTo 0 
238          Exit Sub 
239     
240      ErrTrap: 
241          MsgBox Err.Number & " - " & Err.Description 
242          Resume ExitPoint 
243      End Sub 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

SG_MouseUp (5)

244     
245      Private Sub SG_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
246           'Clear MouseDown event
247          pbolMouseDown = False 
248      End Sub 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

SR_MouseDown (17)

249     
250      Private Sub SR_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 
251      On Error GoTo ErrTrap 
252     
253           'Capture MouseDown event and get the rating based
254           'on the mouse pointer position.
255          pbolMouseDown = True 
256          P_SetSlider "R", X 
257     
258      ExitPoint: 
259          On Error GoTo 0 
260          Exit Sub 
261     
262      ErrTrap: 
263          MsgBox Err.Number & " - " & Err.Description 
264          Resume ExitPoint 
265      End Sub 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

SR_MouseMove (18)

266     
267      Private Sub SR_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 
268      On Error GoTo ErrTrap 
269     
270           'Determine if mouse is down. If it is, resize the rating label and
271           'assign a value to the Rating textbox.
272          If pbolMouseDown Then 
273              P_SetSlider "R", X 
274          End If 
275     
276      ExitPoint: 
277          On Error GoTo 0 
278          Exit Sub 
279     
280      ErrTrap: 
281          MsgBox Err.Number & " - " & Err.Description 
282          Resume ExitPoint 
283      End Sub 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

SR_MouseUp (5)

284     
285      Private Sub SR_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
286           'Clear MouseDown event
287          pbolMouseDown = False 
288      End Sub 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

B_AfterUpdate (30)

289     
290      Private Sub B_AfterUpdate() 
291      On Error GoTo ErrTrap 
292     
293          Dim Rtv As Long, StrSize As Long 
294     
295          Rtv = Nz(Me.B, 0) 
296          Rtv = IIf(Rtv >= 0, Rtv, 0) 
297          Rtv = IIf(Rtv <= plngTop, Rtv, plngTop) 
298          Me.B = Rtv 
299     
300           ' Set slider bar SB (pertaining to value in field B)
301           ' (A string of I's)
302          StrSize = Int((SliderWidth / WidthFactor) * (Rtv / plngTop)) 
303          If StrSize > 0 Then 
304              Me.SB = String(StrSize, SlideChr) 
305          Else 
306              Me.SB = Null 
307          End If 
308     
309          P_SetColorNumber 
310     
311      ExitPoint: 
312          On Error GoTo 0 
313          Exit Sub 
314     
315      ErrTrap: 
316          MsgBox Err.Number & " - " & Err.Description 
317          Resume ExitPoint 
318      End Sub 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

G_AfterUpdate (30)

319     
320      Private Sub G_AfterUpdate() 
321      On Error GoTo ErrTrap 
322     
323          Dim Rtv As Long, StrSize As Long 
324     
325          Rtv = Nz(Me.G, 0) 
326          Rtv = IIf(Rtv >= 0, Rtv, 0) 
327          Rtv = IIf(Rtv <= plngTop, Rtv, plngTop) 
328          Me.G = Rtv 
329     
330           ' Set slider bar SG (pertaining to value in field G)
331           ' (A string of I's)
332          StrSize = Int((SliderWidth / WidthFactor) * (Rtv / plngTop)) 
333          If StrSize > 0 Then 
334              Me.SG = String(StrSize, SlideChr) 
335          Else 
336              Me.SG = Null 
337          End If 
338     
339          P_SetColorNumber 
340     
341      ExitPoint: 
342          On Error GoTo 0 
343          Exit Sub 
344     
345      ErrTrap: 
346          MsgBox Err.Number & " - " & Err.Description 
347          Resume ExitPoint 
348      End Sub 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

R_AfterUpdate (30)

349     
350      Private Sub R_AfterUpdate() 
351      On Error GoTo ErrTrap 
352     
353          Dim Rtv As Long, StrSize As Long 
354     
355          Rtv = Nz(Me.R, 0) 
356          Rtv = IIf(Rtv >= 0, Rtv, 0) 
357          Rtv = IIf(Rtv <= plngTop, Rtv, plngTop) 
358          Me.R = Rtv 
359     
360           ' Set slider bar SR (pertaining to value in field R)
361           ' (A string of I's)
362          StrSize = Int((SliderWidth / WidthFactor) * (Rtv / plngTop)) 
363          If StrSize > 0 Then 
364              Me.SR = String(StrSize, SlideChr) 
365          Else 
366              Me.SR = Null 
367          End If 
368     
369          P_SetColorNumber 
370     
371      ExitPoint: 
372          On Error GoTo 0 
373          Exit Sub 
374     
375      ErrTrap: 
376          MsgBox Err.Number & " - " & Err.Description 
377          Resume ExitPoint 
378      End Sub 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

Form_Current (35)

379     
380      Private Sub Form_Current() 
381      On Error GoTo ErrTrap 
382     
383          If Me.NewRecord = True Then 
384              GoTo ExitPoint 
385          End If 
386     
387           ' Highlight colors for current record
388          Call ShowColor 
389     
390           ' Store existing values for ready ref.
391          Me.R_Old = Me.R 
392          Me.G_Old = Me.G 
393          Me.B_Old = Me.B 
394     
395           ' Synchronize Slider Bars
396           ' (only if all are blank)
397          If Len(Me.SR) > 0 Or _ 
398                      Len(Me.SG) > 0 _ 
399                      Or Len(Me.SB) > 0 Then 
400          Else 
401              R_AfterUpdate 
402              G_AfterUpdate 
403              B_AfterUpdate 
404          End If 
405     
406      ExitPoint: 
407          On Error GoTo 0 
408          Exit Sub 
409     
410      ErrTrap: 
411          MsgBox Err.Number & " - " & Err.Description 
412          Resume ExitPoint 
413      End Sub 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

Form_Load (32)

414     
415      Private Sub Form_Load() 
416      On Error GoTo ErrTrap 
417     
418           ' Clear any existing form level sort or filter
419          Me.OrderByOn = False 
420          Me.FilterOn = False           ' (A) 
421     
422           ' Note - Statement (A) is redundant, as default
423           '            status of FilterOn is False when the form
424           '            loads. However it is included as abundant
425           '            precaution (if there is any change in future
426           '            versions).
427     
428           ' Get effective width of slider bar text box
429           ' (making allowance for side margins)
430          SliderWidth = Me.SR.Width - 25 
431     
432           ' Following subroutine is to be used only once
433           ' (if the source table is changed). Therefore,
434           ' normally kept disabled.
435       '    P_PopulateSliderBarsForNewDataSource
436     
437      ExitPoint: 
438          On Error GoTo 0 
439          Exit Sub 
440     
441      ErrTrap: 
442          MsgBox Err.Number & " - " & Err.Description 
443          Resume ExitPoint 
444      End Sub 
445       '==========================================
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

ShowColor (34)

446     
447      Private Function ShowColor() 
448      On Error GoTo ErrTrap 
449     
450          Dim Frc As Long, Bkc As Long 
451          Dim Cdn As String 
452     
453          If IsNull(Me.colorID) Then 
454              Bkc = 16777215 
455          Else 
456              Bkc = Me.ColorNumber 
457          End If 
458     
459          If Nz(Me.BW, "B") = "W" Then 
460              Frc = 16777215 
461          Else 
462              Frc = 0 
463          End If 
464     
465           ' Apply conditional formatting to ColorName,
466           ' ShadeID and ColorNumber controls
467          Cdn = "ColorID = " & Me.colorID 
468          P_SetNewCondFormat Me.ColorName, Cdn, Bkc, Frc 
469          P_SetNewCondFormat Me.ShadeID, Cdn, Bkc, Frc 
470          P_SetNewCondFormat Me.ColorNumber, Cdn, Bkc, Frc 
471     
472      ExitPoint: 
473          On Error GoTo 0 
474          Exit Function 
475     
476      ErrTrap: 
477          MsgBox Err.Number & " - " & Err.Description 
478          Resume ExitPoint 
479      End Function 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

IsActive_AfterUpdate (4)

480     
481      Private Sub IsActive_AfterUpdate() 
482         Me.Dirty = False 
483      End Sub 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

Label_emailCrystal_Click (5)

484     
485      Private Sub Label_emailCrystal_Click() 
486         Application.FollowHyperlink _ 
487            "mailto: strive4peace2010@yahoo.com?subject=Color Picker v.2 comment from Analyzer" 
488      End Sub 
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

ShadeID_NotInList (29)

489     
490      Private Sub ShadeID_NotInList( _ 
491         NewData As String, _ 
492         Response As Integer) 
493     
494          Dim s As String _ 
495            , mRecordID As Long _ 
496            , mText As String 
497     
498           'convert to ProperCase
499          mText = StrConv(NewData, vbProperCase) 
500     
501          s = "INSERT INTO Shades(Shad) " _ 
502             & " SELECT '" & mText & "';" 
503     
504        '~~~~~~~~~~~~~~~~~~~~~~~~
505     
506       'comment or remove next line after this works correctly
507      Debug.Print s 
508     
509          CurrentDb.Execute s 
510     
511          DoEvents 
512     
513         Response = acDataErrAdded 
514       '   Me.ShadeID = mRecordID
515     
516      End Sub 
517       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      Goto Top       Goto Form_F_Colors_Edit_B       Goto Index

Form_f_Colors_MyFavorites (337)

PROCEDURES       Goto Top       Goto Form_f_Colors_MyFavorites       Goto Forms       Goto Index
  1. BW_KeyDown (25)
  2. ColorName_KeyDown (25)
  3. Declaration Lines (9)
  4. Form_Current (24)
  5. Form_Load (35)
  6. P_ShowColors (94)
  7. Shade_1_KeyDown (25)
  8. Shade_2_KeyDown (25)
  9. Shade_3_KeyDown (25)
  10. Shade_4_KeyDown (25)
  11. Shade_5_KeyDown (25)

Declaration Lines (9)

1        Option Compare Database 
2        Option Explicit 
3         '
4         ' written by A.D. Tejpal
5         ' based on ideas from Crystal
6         '
7         ' added arrow-key actions by Mark Davis 4-30-2013
8         '
9        Private TotRec As Long 
      Goto Top       Goto Form_f_Colors_MyFavorites       Goto Index

BW_KeyDown (25)

10      
11       Private Sub BW_KeyDown(KeyCode As Integer, Shift As Integer) 
12       On Error GoTo nav_err 
13      
14           Select Case KeyCode 
15               Case 37   ' Left Arrow 
16                   Me.Shade_5.SetFocus 
17               Case 38   ' Up Arrow 
18                   DoCmd.GoToRecord , , acPrevious 
19               Case 39   ' Right Arrow 
20                   Me.ColorName.SetFocus 
21               Case 40   ' Down Arrow 
22                   DoCmd.GoToRecord , , acNext 
23           End Select 
24      
25       exit_nav: 
26           Exit Sub 
27      
28       nav_err: 
29           If Err.Number = 2501 Then 
30               KeyCode = 0 
31               Resume exit_nav 
32           End If 
33      
34       End Sub 
      Goto Top       Goto Form_f_Colors_MyFavorites       Goto Index

ColorName_KeyDown (25)

35      
36       Private Sub ColorName_KeyDown(KeyCode As Integer, Shift As Integer) 
37       On Error GoTo nav_err 
38      
39           Select Case KeyCode 
40               Case 37   ' Left Arrow 
41                   Me.BW.SetFocus 
42               Case 38   ' Up Arrow 
43                   DoCmd.GoToRecord , , acPrevious 
44               Case 39   ' Right Arrow 
45                   Me.Shade_1.SetFocus 
46               Case 40   ' Down Arrow 
47                   DoCmd.GoToRecord , , acNext 
48           End Select 
49      
50       exit_nav: 
51           Exit Sub 
52      
53       nav_err: 
54           If Err.Number = 2501 Then 
55               KeyCode = 0 
56               Resume exit_nav 
57           End If 
58      
59       End Sub 
      Goto Top       Goto Form_f_Colors_MyFavorites       Goto Index

Form_Current (24)

60      
61       Private Sub Form_Current() 
62       On Error GoTo ErrTrap 
63      
64           Dim AbsPos As Long, CurRec As Long 
65      
66           CurRec = Me.CurrentRecord 
67           If TotRec - CurRec >= 2 Then 
68               AbsPos = CurRec - 1 
69           Else 
70               AbsPos = TotRec - 3 
71           End If 
72           AbsPos = IIf(AbsPos >= 0, AbsPos, 0) 
73      
74           P_ShowColors Me.RecordsetClone, AbsPos 
75      
76       ExitPoint: 
77           On Error GoTo 0 
78           Exit Sub 
79      
80       ErrTrap: 
81           MsgBox Err.Number & " - " & Err.Description 
82           Resume ExitPoint 
83       End Sub 
      Goto Top       Goto Form_f_Colors_MyFavorites       Goto Index

Form_Load (35)

84      
85       Private Sub Form_Load() 
86       On Error GoTo ErrTrap 
87      
88           Dim rst As DAO.Recordset 
89      
90            ' Clear any existing form level sort or filter
91           Me.OrderByOn = False 
92           Me.FilterOn = False           ' (A) 
93      
94            ' Note - Statement (A) is redundant, as default
95            '            status of FilterOn is False when the form
96            '            loads. However it is included as abundant
97            '            precaution (if there is any change in future
98            '            versions).
99      
100          Set rst = Me.RecordsetClone 
101          If rst.EOF Then 
102              TotRec = 0 
103          Else 
104              rst.MoveLast 
105              TotRec = rst.RecordCount 
106          End If 
107     
108      ExitPoint: 
109          On Error Resume Next 
110          rst.Close 
111          Set rst = Nothing 
112          On Error GoTo 0 
113          Exit Sub 
114     
115      ErrTrap: 
116          MsgBox Err.Number & " - " & Err.Description 
117          Resume ExitPoint 
118      End Sub 
      Goto Top       Goto Form_f_Colors_MyFavorites       Goto Index

P_ShowColors (94)

119     
120      Private Sub P_ShowColors(rst As DAO.Recordset, _ 
121                                                  AbsPos As Long) 
122          On Error Resume Next 
123          Dim Cdn() As String, Cnm As String 
124          Dim Bkc() As Long, Frc() As Long 
125          Dim Cnt As Long, Ctr As Long 
126     
127           ' Exit if no records
128          If TotRec > 0 Then 
129          Else 
130              GoTo ExitPoint 
131          End If 
132     
133           ' Cycle through controls named Shade_1 to 5
134           ' and build up conditional format arguments for
135           ' three rows, starting with. current row
136          For Ctr = 1 To 5 
137               ' Get control name
138              Cnm = "Shade_" & Ctr 
139     
140               ' Go to position matching current record
141              rst.AbsolutePosition = AbsPos 
142     
143               ' Clear and set dimensions for array variables -
144               ' for format condition, back color and fore color
145              ReDim Cdn(3) 
146              ReDim Bkc(3) 
147              ReDim Frc(3) 
148     
149               ' Get conditional arguments for three rows
150              For Cnt = 1 To 3 
151                  Cdn(Cnt) = "ColorName = '" & _ 
152                                              rst.Fields("ColorName") & "'" 
153                  Bkc(Cnt) = rst.Fields(Cnm) 
154                  Frc(Cnt) = IIf(Ctr >= 3 And _ 
155                              Nz(rst.Fields("BW")) = "W", 16777215, 0) 
156     
157                  rst.MoveNext 
158                  If rst.EOF Then 
159                      Exit For 
160                  End If 
161              Next 
162     
163               ' Resume original position of recordset
164               ' matching current record
165              rst.AbsolutePosition = AbsPos 
166     
167               ' Set conditional formats for Shade fields
168               ' depending upon the number of meaningful
169               ' arguments
170              If Len(Cdn(3)) > 0 Then 
171                  P_SetNewCondFormat Me(Cnm), _ 
172                                  Cdn(1), Bkc(1), Frc(1), _ 
173                                  Cdn(2), Bkc(2), Frc(2), _ 
174                                  Cdn(3), Bkc(3), Frc(3) 
175                   ' Set cond format for ColorName also
176                   ' to match middle shade (Shade_3)
177                  If Ctr = 3 Then 
178                      P_SetNewCondFormat Me.ColorName, _ 
179                                              Cdn(1), Bkc(1), Frc(1), _ 
180                                              Cdn(2), Bkc(2), Frc(2), _ 
181                                              Cdn(3), Bkc(3), Frc(3) 
182                  End If 
183              Else 
184                  If Len(Cdn(2)) > 0 Then 
185                      P_SetNewCondFormat Me(Cnm), _ 
186                                      Cdn(1), Bkc(1), Frc(1), _ 
187                                      Cdn(2), Bkc(2), Frc(2) 
188                       ' Set cond format for ColorName also
189                       ' to match middle shade (Shade_3)
190                      If Ctr = 3 Then 
191                          P_SetNewCondFormat Me.ColorName, _ 
192                                                  Cdn(1), Bkc(1), Frc(1), _ 
193                                                  Cdn(2), Bkc(2), Frc(2) 
194                      End If 
195                  Else 
196                      P_SetNewCondFormat Me(Cnm), _ 
197                                      Cdn(1), Bkc(1), Frc(1) 
198                       ' Set cond format for ColorName also
199                       ' to match middle shade (Shade_3)
200                      If Ctr = 3 Then 
201                          P_SetNewCondFormat Me.ColorName, _ 
202                                                  Cdn(1), Bkc(1), Frc(1) 
203                      End If 
204                  End If 
205              End If 
206          Next 
207     
208      ExitPoint: 
209          rst.Close 
210          Set rst = Nothing 
211          On Error GoTo 0 
212      End Sub 
      Goto Top       Goto Form_f_Colors_MyFavorites       Goto Index

Shade_1_KeyDown (25)

213     
214      Private Sub Shade_1_KeyDown(KeyCode As Integer, Shift As Integer) 
215      On Error GoTo nav_err 
216     
217          Select Case KeyCode 
218              Case 37   ' Left Arrow 
219                  Me.ColorName.SetFocus 
220              Case 38   ' Up Arrow 
221                  DoCmd.GoToRecord , , acPrevious 
222              Case 39   ' Right Arrow 
223                  Me.Shade_2.SetFocus 
224              Case 40   ' Down Arrow 
225                  DoCmd.GoToRecord , , acNext 
226          End Select 
227     
228      exit_nav: 
229          Exit Sub 
230     
231      nav_err: 
232          If Err.Number = 2501 Then 
233              KeyCode = 0 
234              Resume exit_nav 
235          End If 
236     
237      End Sub 
      Goto Top       Goto Form_f_Colors_MyFavorites       Goto Index

Shade_2_KeyDown (25)

238     
239      Private Sub Shade_2_KeyDown(KeyCode As Integer, Shift As Integer) 
240      On Error GoTo nav_err 
241     
242          Select Case KeyCode 
243              Case 37   ' Left Arrow 
244                  Me.Shade_1.SetFocus 
245              Case 38   ' Up Arrow 
246                  DoCmd.GoToRecord , , acPrevious 
247              Case 39   ' Right Arrow 
248                  Me.Shade_3.SetFocus 
249              Case 40   ' Down Arrow 
250                  DoCmd.GoToRecord , , acNext 
251          End Select 
252     
253      exit_nav: 
254          Exit Sub 
255     
256      nav_err: 
257          If Err.Number = 2501 Then 
258              KeyCode = 0 
259              Resume exit_nav 
260          End If 
261     
262      End Sub 
      Goto Top       Goto Form_f_Colors_MyFavorites       Goto Index

Shade_3_KeyDown (25)

263     
264      Private Sub Shade_3_KeyDown(KeyCode As Integer, Shift As Integer) 
265      On Error GoTo nav_err 
266     
267          Select Case KeyCode 
268              Case 37   ' Left Arrow 
269                  Me.Shade_2.SetFocus 
270              Case 38   ' Up Arrow 
271                  DoCmd.GoToRecord , , acPrevious 
272              Case 39   ' Right Arrow 
273                  Me.Shade_4.SetFocus 
274              Case 40   ' Down Arrow 
275                  DoCmd.GoToRecord , , acNext 
276          End Select 
277     
278      exit_nav: 
279          Exit Sub 
280     
281      nav_err: 
282          If Err.Number = 2501 Then 
283              KeyCode = 0 
284              Resume exit_nav 
285          End If 
286     
287      End Sub 
      Goto Top       Goto Form_f_Colors_MyFavorites       Goto Index

Shade_4_KeyDown (25)

288     
289      Private Sub Shade_4_KeyDown(KeyCode As Integer, Shift As Integer) 
290      On Error GoTo nav_err 
291     
292          Select Case KeyCode 
293              Case 37   ' Left Arrow 
294                  Me.Shade_3.SetFocus 
295              Case 38   ' Up Arrow 
296                  DoCmd.GoToRecord , , acPrevious 
297              Case 39   ' Right Arrow 
298                  Me.Shade_5.SetFocus 
299              Case 40   ' Down Arrow 
300                  DoCmd.GoToRecord , , acNext 
301          End Select 
302     
303      exit_nav: 
304          Exit Sub 
305     
306      nav_err: 
307          If Err.Number = 2501 Then 
308              KeyCode = 0 
309              Resume exit_nav 
310          End If 
311     
312      End Sub 
      Goto Top       Goto Form_f_Colors_MyFavorites       Goto Index

Shade_5_KeyDown (25)

313     
314      Private Sub Shade_5_KeyDown(KeyCode As Integer, Shift As Integer) 
315      On Error GoTo nav_err 
316     
317          Select Case KeyCode 
318              Case 37   ' Left Arrow 
319                  Me.BW.SetFocus 
320              Case 38   ' Up Arrow 
321                  DoCmd.GoToRecord , , acPrevious 
322              Case 39   ' Right Arrow 
323                  Me.Shade_4.SetFocus 
324              Case 40   ' Down Arrow 
325                  DoCmd.GoToRecord , , acNext 
326          End Select 
327     
328      exit_nav: 
329          Exit Sub 
330     
331      nav_err: 
332          If Err.Number = 2501 Then 
333              KeyCode = 0 
334              Resume exit_nav 
335          End If 
336     
337      End Sub 
      Goto Top       Goto Form_f_Colors_MyFavorites       Goto Index

Form_f_DataDICTIONARY_DisplayControl (508)

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 (2)
  13. fltrTablename_AfterUpdate (5)
  14. Form_Load (24)
  15. Form_Open (43)
  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 (2)

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

Form_Open (43)

3       
4         '============================================================ LICENSE NOTICE -- must not be modified
5         ' The Analyzer 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        '
25        '
26        ' Join Analyzer Developer Project at http://analyzer.codeplex.com/
27        '
28        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140605
29        ' END LICENSE NOTICE
30        '============================================================
31        '  CALLS
32        '     SetDisplayControlCheckbox
33        '     SetDisplayControlTextbox
34        '     GetPropertyValue
35        '     GetDataType
36        '     GetControlType
37        '     CanGet_ObjectProperty (CanGet_PropertyValue)
38      
39       Private Sub Form_Open(Cancel As Integer) 
40        '120426 Crystal
41          RowSource_Tablename 
42          With Me.lstFieldname 
43             .RowSource = "Pick Table" 
44          End With 
45       End Sub 
      Goto Top       Goto Form_f_DataDICTIONARY_DisplayControl       Goto Index

Form_Load (24)

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

fltrTablename_AfterUpdate (5)

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

chkSys_AfterUpdate (4)

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

chkExclusive_Click (5)

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

chkHid_Click (5)

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

chkLinked_Click (5)

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

chkODBC_Click (5)

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

chkSavePW_Click (5)

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

RowSource_TablenameForm (6)

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

RowSource_Tablename (76)

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

Tablename_AfterUpdate (5)

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

RowSource_Fieldlist (116)

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

Tablename_MouseUp (10)

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

cmd_Design_Click (10)

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

cmd_Open_Click (8)

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

cmd_Checkbox_Click (4)

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

cmd_Textbox_Click (4)

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

Label_By_Click (6)

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

MakeTheChanges (37)

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

lstFieldname_AfterUpdate (61)

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

cmdRename_Click (62)

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

Form_f_SplashScreen (30)

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

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         ' 140723 WP
6       
7           Me.lblTitle.Caption = "Analyzer for Microsoft Access" & vbCrLf & _ 
8                                   "... LOADING, PLEASE WAIT ..." 
9       
10       End Sub 
      Goto Top       Goto Form_f_SplashScreen       Goto Index

Form_Timer (20)

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      
18        ' Using the timer event will ensure any time consuimg tasks are started after the splashscreen is displayed to the user
19          Me.TimerInterval = 0    ' To ensure we only get called once (which ). 
20      
21        ' Do any potnetially time-consuming startup tasks here
22          Call InitializeVBWatchdog 
23      
24        ' Now close the splash screen and open the main analyzer menu (maximized)
25          DoCmd.Close acForm, Me.Name 
26          DoCmd.OpenForm "a_f_ANALYZER_MENU", acNormal 
27          DoCmd.Maximize 
28      
29       End Sub 
30      
      Goto Top       Goto Form_f_SplashScreen       Goto Index

Form_frm_Test (104)

PROCEDURES       Goto Top       Goto Form_frm_Test       Goto Forms       Goto Index
  1. btn_Test_Click (81)
  2. Declaration Lines (23)

Declaration Lines (23)

1        Option Compare Database 
2        Option Explicit 
3       
4         ' API calls updated for 64-bit by SuperShadow 06/23/2014
5        #If VBA7 Then             '  Code is running in the new VBA7 editor 
6          #If Win64 Then          '  Code is running in 64-bit version of Microsoft Office 
7            Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 
8          #Else                   '  Code is running in 32-bit version of Microsoft Office 
9            Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 
10         #End If 
11       #Else                     ' Code is running in VBA version 6 or earlier 
12         Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 
13       #End If 
14        '
15        ' TheSmileyCoders Progress Form (Simple version)
16        ' Version info: 1.0
17        '
18        ' This progress meter form and code is licensed under
19        ' the Creative Commons Attribution 3.0 license.
20        ' This means you may use, redistribute, alter and include in your application
21        ' without charge, as long as the attribution and disclaimer notice is kept
22        ' in each module.
23        '
      Goto Top       Goto Form_frm_Test       Goto Index

btn_Test_Click (81)

24      
25       Private Sub btn_Test_Click()   'not used by Analyzer 
26        '---------------------------------------------------------------------------------------
27        '---------------------------------------------------------------------------------------
28        ' Procedure : btn_Test_Click
29        ' Author    : AEC - Anders Ebro Christensen / TheSmileyCoder
30        ' Date      : 2013-03-17
31        ' Version   : 1.0
32        ' Purpose   : Simulate a test of the progress form, and demo example usage
33        ' Bugs?     : Email: SmileyCoderTools@gmail.com
34        '---------------------------------------------------------------------------------------
35        '---------------------------------------------------------------------------------------
36       On Error GoTo Err_Handler 
37      
38         Dim i As Integer 
39      
40          'Init progress form
41         Dim oPFprivate As TSC_PF_Simple 
42         Set oPFprivate = New TSC_PF_Simple 
43      
44          'Show the form
45          'Progress Meter (oPFprivate) by Smiley
46         oPFprivate.title = "Importing Objects" & vbNewLine & "Please wait..." 
47         oPFprivate.UpdateTask 0, "Preparing Import" 
48         oPFprivate.Show 
49      
50          'Since this is just a demo, I simulate a series of slow tasks by using the sleep
51         oPFprivate.UpdateTask 0, "Gathering Form information: " & vbNewLine & 1 & " of 10" 
52         For i = 1 To 10 
53           Sleep 100 
54           oPFprivate.UpdateTask i / 10, "Gathering Form information: " & vbNewLine & i & " of 10" 
55         Next 
56      
57          'The progress form allows the user to cancel a running process, however, not that
58          'the cancel is only reacted to when the progress form is updated.
59      
60          'If you want to allow the user the possibility to cancel, set the Allowcancel property to true
61          'If user cancels an an error 8101 is raised.
62         oPFprivate.AllowCancel = True 
63      
64          'Simulate another task running
65         oPFprivate.UpdateTask 0, "Importing Queries:" & vbNewLine & "1 of 10" 
66         For i = 1 To 5 
67           Sleep 500 
68           oPFprivate.UpdateTask i / 5, "Importing Queries:" & vbNewLine & i & " of 10" 
69         Next 
70      
71          'Simulate a third task running, but now disallow cancel for this part
72         oPFprivate.AllowCancel = False 
73          'Also change the titel. Note how the form expands to accomodate the long text
74         oPFprivate.title = oPFprivate.title & vbNewLine & "Do not turn of or unplug your device at this point" 
75      
76         oPFprivate.UpdateTask 0, "Importing tables:" & vbNewLine & "0 of 100" 
77         For i = 1 To 100 
78           Sleep 25 
79           oPFprivate.UpdateTask i / 100, "Importing tables:" & vbNewLine & i & " of 100" 
80         Next 
81      
82          'Update title before closure. Note how the built in close delay gives just
83          'enough time for the user to see this message.
84         oPFprivate.title = "Succes" & vbNewLine & "All Done" 
85      
86       Exit_Sub: 
87          'Cleanup
88         Set oPFprivate = Nothing 
89         On Error GoTo 0 
90         Exit Sub 
91      
92       Err_Handler: 
93          'Check for user cancel
94         If Err.Number = TSCe_ErrCodes.PF_UserCancel Then 
95            'User has clicked cancel. How you wish to react is of course entirely based on your demands
96            'If you do not wish to bother with this, just leave the AllowCancel at the default False setting.
97           MsgBox "Process aborted by user" 
98           Resume Exit_Sub 
99         End If 
100     
101         'Some other other
102        MsgBox "Error in btn_Test_Click" & vbNewLine & "[" & Err.Number & "] - " & Err.Description, vbOKOnly 
103        Resume Exit_Sub 
104      End Sub 
      Goto Top       Goto Form_frm_Test       Goto Index

Form_frmFilePropertyViewer (93)

PROCEDURES       Goto Top       Goto Form_frmFilePropertyViewer       Goto Forms       Goto Index
  1. btnClose_Click (6)
  2. btnOpenFile_Click (12)
  3. Declaration Lines (7)
  4. EnumProperties (51)
  5. VarToStr (17)

Declaration Lines (7)

1        Option Explicit 
2         'download this free tool :
3         'Accessing detailed file information provided by the Operating System
4         '  by Wayne Phillips
5         'http://www.everythingaccess.com/tutorials.asp?ID=Accessing-detailed-file-information-provided-by-the-Operating-System
6       
7        Public m_CurrentFileProperties As FileProperties 
      Goto Top       Goto Form_frmFilePropertyViewer       Goto Index

btnOpenFile_Click (12)

8       
9        Private Sub btnOpenFile_Click() 
10      
11            ' For this example, we will use the BrowseAndOpenFile method.
12            ' Ordinarily you'd more likely need the OpenFile(PathName) method instead
13           Set m_CurrentFileProperties = FilePropertyExplorer.BrowseAndOpenFile() 
14      
15           lblFilePath.Caption = m_CurrentFileProperties.FilePath 
16      
17           lstProperties.Requery 
18      
19       End Sub 
      Goto Top       Goto Form_frmFilePropertyViewer       Goto Index

btnClose_Click (6)

20      
21       Private Sub btnClose_Click() 
22      
23           DoCmd.Close acForm, Me.Name 
24      
25       End Sub 
      Goto Top       Goto Form_frmFilePropertyViewer       Goto Index

EnumProperties (51)

26      
27        ' This is used as a callback for populating the list box  (see the list box RowSource property)
28       Function EnumProperties(Fld As Control, ID As Variant, _ 
29                               RowNumber As Variant, ColumnNumber As Variant, _ 
30                               Code As Variant) As Variant 
31      
32           If Not m_CurrentFileProperties Is Nothing Then 
33      
34               Select Case Code 
35      
36                   Case acLBInitialize 
37      
38                       EnumProperties = True 
39      
40                   Case acLBOpen 
41      
42                       EnumProperties = Timer                                    ' Returns a unique identifier 
43      
44                   Case acLBGetRowCount 
45      
46                       EnumProperties = m_CurrentFileProperties.Count + 1        ' Add one for row header 
47      
48                   Case acLBGetValue 
49      
50                       If RowNumber = 0 Then 
51                            ' Populate the header row data
52                           Select Case ColumnNumber 
53                               Case 0:    EnumProperties = "PROPERTY ID" 
54                               Case 1:    EnumProperties = "PROPERTY NAME" 
55                               Case 2:    EnumProperties = "PROPERTY DESCRIPTION" 
56                               Case 3:    EnumProperties = "PROPERTY VALUE" 
57                               Case 4:    EnumProperties = "PROPERTY VALUE DESCRIPTION" 
58                           End Select 
59                       Else 
60                            ' Populate the item row data (offset -1 due to row header)
61                           Select Case ColumnNumber 
62                               Case 0:    EnumProperties = m_CurrentFileProperties.Item(RowNumber - 1).ID 
63                               Case 1:    EnumProperties = m_CurrentFileProperties.Item(RowNumber - 1).Name 
64                               Case 2:    EnumProperties = m_CurrentFileProperties.Item(RowNumber - 1).NameDesc 
65                               Case 3:    EnumProperties = VarToStr(m_CurrentFileProperties.Item(RowNumber - 1).Value) 
66                               Case 4:    EnumProperties = m_CurrentFileProperties.Item(RowNumber - 1).ValueDesc 
67                           End Select 
68                       End If 
69      
70                   Case acLBEnd 
71      
72               End Select 
73      
74           End If 
75      
76       End Function 
      Goto Top       Goto Form_frmFilePropertyViewer       Goto Index

VarToStr (17)

77      
78       Private Function VarToStr(ByVal Value As Variant) As String 
79      
80           On Error GoTo ErrorHandler 
81      
82           If IsArray(Value) Then 
83               VarToStr = Join(Value, ", ") 
84           Else 
85               VarToStr = CStr(Value) 
86           End If 
87      
88           Exit Function 
89      
90       ErrorHandler: 
91           VarToStr = "## UNSUPPORTED VB DATATYPE ##" 
92      
93       End Function 
      Goto Top       Goto Form_frmFilePropertyViewer       Goto Index

Form_oa_f_FldA (33)

PROCEDURES       Goto Top       Goto Form_oa_f_FldA       Goto Forms       Goto Index
  1. cmd_Keep_Click (5)
  2. Declaration Lines (2)
  3. Form_BeforeUpdate (5)
  4. Label_DatTypeS_Click (5)
  5. Label_Fld_Click (5)
  6. Label_Tbl_Click (5)
  7. Label_TblA_Click (6)

Declaration Lines (2)

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

cmd_Keep_Click (5)

3       
4        Private Sub cmd_Keep_Click() 
5         '150902
6           Me.FldA = Null 
7        End Sub 
      Goto Top       Goto Form_oa_f_FldA       Goto Index

Form_BeforeUpdate (5)

8       
9        Private Sub Form_BeforeUpdate(Cancel As Integer) 
10        '150902
11          Me.dtmEdit = Now() 
12       End Sub 
      Goto Top       Goto Form_oa_f_FldA       Goto Index

Label_DatTypeS_Click (5)

13      
14       Private Sub Label_DatTypeS_Click() 
15        '150902
16          Call Sort123(Me, "DatTypeS", "Fld", "Tbl") 
17       End Sub 
      Goto Top       Goto Form_oa_f_FldA       Goto Index

Label_Fld_Click (5)

18      
19       Private Sub Label_Fld_Click() 
20        '150902
21          Call Sort123(Me, "Fld", "Tbl") 
22       End Sub 
      Goto Top       Goto Form_oa_f_FldA       Goto Index

Label_Tbl_Click (5)

23      
24       Private Sub Label_Tbl_Click() 
25        '150902
26          Call Sort123(Me, "Tbl", "Fld") 
27       End Sub 
      Goto Top       Goto Form_oa_f_FldA       Goto Index

Label_TblA_Click (6)

28      
29       Private Sub Label_TblA_Click() 
30        '150902
31          Call Sort123(Me, "FldA", "Tbl") 
32       End Sub 
33      
      Goto Top       Goto Form_oa_f_FldA       Goto Index

Form_oa_f_Optimize (12)

PROCEDURES       Goto Top       Goto Form_oa_f_Optimize       Goto Forms       Goto Index
  1. Declaration Lines (2)
  2. Form_BeforeUpdate (5)
  3. MixedCase_MouseUp (5)

Declaration Lines (2)

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

Form_BeforeUpdate (5)

3       
4        Private Sub Form_BeforeUpdate(Cancel As Integer) 
5         '150902
6           Me.dtmEdit = Now() 
7        End Sub 
      Goto Top       Goto Form_oa_f_Optimize       Goto Index

MixedCase_MouseUp (5)

8       
9        Private Sub MixedCase_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
10        '150902
11          Me.ActiveControl.Dropdown 
12       End Sub 
      Goto Top       Goto Form_oa_f_Optimize       Goto Index

Form_oa_f_OptTests_sub (44)

PROCEDURES       Goto Top       Goto Form_oa_f_OptTests_sub       Goto Forms       Goto Index
  1. Declaration Lines (32)
  2. Detail_Click (6)
  3. Form_BeforeUpdate (6)

Declaration Lines (32)

1        Option Compare Database 
2        Option Explicit 
3         '
4         '150802 this subform was copied from a_f_DBTests and modified for the Optimizer Tests subform
5         '
6         '============================================================ LICENSE NOTICE -- must not be modified
7         ' The Analyzer 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        '
27        '
28        ' Join Analyzer Developer Project at http://analyzer.codeplex.com/
29        '
30        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140605
31        ' END LICENSE NOTICE
32        '============================================================
      Goto Top       Goto Form_oa_f_OptTests_sub       Goto Index

Detail_Click (6)

33      
34       Private Sub Detail_Click() 
35        '160421
36          MsgBox "test" 
37      
38       End Sub 
      Goto Top       Goto Form_oa_f_OptTests_sub       Goto Index

Form_BeforeUpdate (6)

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

Form_oa_f_TblA (23)

PROCEDURES       Goto Top       Goto Form_oa_f_TblA       Goto Forms       Goto Index
  1. cmd_Keep_Click (6)
  2. Declaration Lines (2)
  3. Form_BeforeUpdate (5)
  4. Label_Tbl_Click (5)
  5. Label_TblA_Click (5)

Declaration Lines (2)

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

cmd_Keep_Click (6)

3       
4        Private Sub cmd_Keep_Click() 
5         '150902
6            'keep original name
7           Me.TblA = Null 
8        End Sub 
      Goto Top       Goto Form_oa_f_TblA       Goto Index

Form_BeforeUpdate (5)

9       
10       Private Sub Form_BeforeUpdate(Cancel As Integer) 
11        '150902
12          Me.dtmEdit = Now() 
13       End Sub 
      Goto Top       Goto Form_oa_f_TblA       Goto Index

Label_Tbl_Click (5)

14      
15       Private Sub Label_Tbl_Click() 
16        '150902
17          Call Sort123(Me, "Tbl") 
18       End Sub 
      Goto Top       Goto Form_oa_f_TblA       Goto Index

Label_TblA_Click (5)

19      
20       Private Sub Label_TblA_Click() 
21        '150902
22          Call Sort123(Me, "TblA") 
23       End Sub 
      Goto Top       Goto Form_oa_f_TblA       Goto Index

Form_TSC_ProgressMeter (62)

PROCEDURES       Goto Top       Goto Form_TSC_ProgressMeter       Goto Forms       Goto Index
  1. btn_Cancel_Click (8)
  2. Declaration Lines (44)
  3. Label_Smiley_Click (5)
  4. Label_Smiley_Link_Click (5)

Declaration Lines (44)

1        Option Compare Database 
2        Option Explicit 
3         '---------------------------------------------------------------------------------------
4         ' Object    : TheSmileyCoder's Progress form
5         ' Author    : AEC - Anders Ebro Christensen / TheSmileyCoder
6         ' Date      : 2013-04-14
7         ' Version   : 1.0
8         ' Purpose   : * Present a pleasing looking progress form that is easy for the developer
9         '           :   to implement.
10        '           : * Special features involve auto resize of text (Thank you Stephen Leban)
11        '           : * Possibility to for user cancel in-between steps
12        '
13        ' Usage     : See frm_Test for example usage.
14        '           : All objects except the frm_Test must be imported into your database.
15      
16        ' License   : Licensed under Creative Commons 3.0 Attribution
17        '           : For more details see http://creativecommons.org/licenses/by/3.0/"
18        '           : This means that you may use, alter, redistribute and include this code in
19        '           : your application without paying me a dime,
20        '           : PROVIDED that you include the attribution details and this license.
21        '
22        ' Updates   : See www.TheSmileyCoder.com for news on updates, or other neat VBA tools
23        '---------------------------------------------------------------------------------------
24      
25        'DISCLAIMER OF WARRANTIES AND LIMITATION OF LIABILITY
26        '
27        'The software is supplied “as is” and all use is at your own risk. TheSmileyCoder
28        'aka Anders Ebro disclaims all warranties of any kind, either express or implied, as to
29        'the software, including, but not limited to, implied warranties of fitness for a
30        'particular purpose, merchantability or non-infringement of proprietary rights.
31        'Neither this agreement nor any documentation furnished under it is intended to
32        'express or imply any warranty that the operation of the software will be
33        'uninterrupted, timely, or error-free.
34        'Under no circumstances shall TheSmileyCoder/Anders Ebro be liable to any user for
35        'direct, indirect, incidental, consequential, special, or exemplary damages, arising
36        'from or relating to this agreement, the software, or user's use or misuse of the
37        'software or any other services provided by TheSmileyCoder/Anders Ebro. Such
38        'limitation of liability shall apply whether the damages arise from the use or
39        'misuse of the software or any other services supplied by TheSmileyCoder/Anders Ebro
40        '(including such damages incurred by third parties), or errors of the software.
41      
42        '140626 s4p -- removed MODAL property so developers can check stuff while Analyzer is running
43      
44       Public bCancelled As Boolean 
      Goto Top       Goto Form_TSC_ProgressMeter       Goto Index

btn_Cancel_Click (8)

45        'To use this form as a instanced form, it must have a module.
46        'Please do not remove this module.
47       Private Sub btn_Cancel_Click() 
48           'Set the bCancelled flag
49             bCancelled = True 
50             Me.btn_Cancel.Caption = "Cancelled" 
51           'This will raise an error next time the progress is updated.
52       End Sub 
      Goto Top       Goto Form_TSC_ProgressMeter       Goto Index

Label_Smiley_Click (5)

53      
54       Private Sub Label_Smiley_Click() 
55        '131014
56          Application.FollowHyperlink "http://thesmileycoder.com/" 
57       End Sub 
      Goto Top       Goto Form_TSC_ProgressMeter       Goto Index

Label_Smiley_Link_Click (5)

58      
59       Private Sub Label_Smiley_Link_Click() 
60        '131014
61          Application.FollowHyperlink "http://thesmileycoder.com/" 
62       End Sub 
      Goto Top       Goto Form_TSC_ProgressMeter       Goto Index

Modules

  1. bas_Convert_TEMP (57)
  2. bas_crystal_BackupRestore (446)
  3. bas_crystal_code_general_0905_1204_1004_1304 (2,815)
  4. bas_Crystal_Properties_0806_130410_0429 (393)
  5. bas_Crystal_RunSQL_130501 (469)
  6. bas_ListFiles_080217_130519 (447)
  7. bas_Optimizer (1,478)
  8. ErrEx (408)
  9. ErrEx_Helper (289)
  10. ErrExCallstack (121)
  11. ErrExDialogOptions (381)
  12. ErrExVariables (71)
  13. FileProperties (53)
  14. FileProperty (65)
  15. FilePropertyExplorer (309)
  16. FilePropertyExplorer_Helper (41)
  17. mod_AllenBrowne_GetFileFormat (114)
  18. mod_Analyzer_0_ObjectSummary (553)
  19. mod_Analyzer_100_DataDictionary (1,590)
  20. mod_Analyzer_101_ValueAnalysis (578)
  21. mod_Analyzer_110_LookupFields (222)
  22. mod_Analyzer_300_Forms_400_Reports (633)
  23. mod_Analyzer_301_Controls (142)
  24. mod_Analyzer_Attachments (602)
  25. mod_Analyzer_Automate2Word (6)
  26. mod_Analyzer_GetDataType (373)
  27. mod_Analyzer_Helpers (617)
  28. mod_Analyzer_menu (134)
  29. mod_Analyzer_MV (437)
  30. mod_Analyzer_NotUsed (436)
  31. mod_Analyzer_Properties (402)
  32. mod_Analyzer_Properties_enum (231)
  33. mod_Analyzer_Public (689)
  34. mod_Analyzer_Query_SQL (104)
  35. mod_Analyzer_Reports (83)
  36. mod_Analyzer_SortStrips (142)
  37. mod_Analyzer_Tests (367)
  38. mod_BillMosca_LinkDB (207)
  39. mod_BillMosca_SysInfo (144)
  40. mod_BillMosca_XbasUtil (183)
  41. mod_BrentSpaulding_SortStringArray (105)
  42. mod_Bypass_ReadOnly_NeoPa (134)
  43. mod_Colors (269)
  44. mod_crystal_DataDICTIONARY_DisplayControl (368)
  45. mod_crystal_GetFile_Browse (150)
  46. mod_showUsers (49)
  47. mod_TerryKreft_API_Clipboard_Copy_Paste (259)
  48. mod_TSC_LebansTextHeightWidth (206)
  49. mod_TSC_ProgressMeter (167)
  50. mod_WaynePhillips_FileProperties_DBs (120)
  51. mod_WaynePhillips_vbWatchDog (219)
  52. Tools_crystal_SubDatasheet (88)
  53. TSC_PF_Simple (276)
  54. zmod_test__ (202)
Goto END of Modules       Goto Top       Goto Index

bas_Convert_TEMP (57)

PROCEDURES       Goto Top       Goto bas_Convert_TEMP       Goto Modules       Goto Index
  1. Declaration Lines (2)
  2. runTest_ResizeFields (4)
  3. Test_ResizeFields (51)

Declaration Lines (2)

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

runTest_ResizeFields (4)

3       
4        Public Sub runTest_ResizeFields() 
5           Test_ResizeFields 3 
6        End Sub 
      Goto Top       Goto bas_Convert_TEMP       Goto Index

Test_ResizeFields (51)

7       
8        Public Sub Test_ResizeFields(pDbID As Long) 
9         '150721 strive4peace
10      
11          Dim sSQL As String _ 
12             , sPathFileSource As String _ 
13             , sPath As String _ 
14             , sFile As String _ 
15             , sFileNEW As String _ 
16             , sPathFileTarget As String 
17      
18          sPathFileSource = DLookup("dbPathFile", "a_DBs", "DbID=" & pDbID) 
19          sPath = Get_PathFromPathFile(sPathFileSource, sFile) 
20      
21          sFileNEW = "NEW_" & sFile 
22          sPathFileTarget = sPath & "\" & sFile 
23      
24           'make a new database
25      
26          Dim dbNew As DAO.Database 
27      
28           'Set dbNew = CreateDatabase(sPathFileTarget)
29      
30      
31          sSQL = "SELECT T.Tbl" _ 
32             & " , F.Fld" _ 
33             & " , F.FldSize" _ 
34             & " , Fs.MaxLen" _ 
35             & " , DMin" _ 
36                & " (""NewSize"",""a_FldSizeNew""" _ 
37                & " ,""[NewSize] > ("" & [MaxLen] & ""* 1.2"" & "")"") AS newSize" _ 
38             & " , Fs.Filled" _ 
39             & " , T.NumRecs" _ 
40             & " , Nz([filled],0)/Nz([numrecs],1) AS FracFilled" _ 
41             & " , F.DbID" _ 
42             & " , T.TID" _ 
43             & " , F.FID" _ 
44             & " , F.DatTypN" _ 
45             & " , F.NewSize" _ 
46             & " , F.dtmEdit" _ 
47             & " , F.IDedit " _ 
48             & " FROM (a_Tbls AS T INNER JOIN a_Flds AS F ON T.TID = F.TID)  " _ 
49             & " INNER JOIN a_FldStats AS Fs ON F.FID = Fs.FID " _ 
50             & " WHERE (((F.FldSize)>([MaxLen]+100))  " _ 
51             & " AND ((Fs.Filled)>10)  " _ 
52             & " AND ((Nz([filled],0)/Nz([numrecs],1))>0.5)  " _ 
53             & " AND ((F.DatTypN)=10))" _ 
54             & ";" 
55      
56      
57       End Sub 
      Goto Top       Goto bas_Convert_TEMP       Goto Index

bas_crystal_BackupRestore (446)

PROCEDURES       Goto Top       Goto bas_crystal_BackupRestore       Goto Modules       Goto Index
  1. BackupOne (22)
  2. BackupRestoreObjects (220)
  3. Declaration Lines (7)
  4. DeleteTemporaryQueries (19)
  5. EnumContainerProperties (112)
  6. Local_CorrectName (37)
  7. RestoreOne (10)
  8. runBackupRestoreObjects (11)
  9. runBackupRestoreObjects_justBack (8)

Declaration Lines (7)

1         'Option Compare Database
2        Option Explicit   'forces variable declaration to be required in module -- always a good idea 
3         '================================================================================
4         'Module Name: bas_crystal_BackupRestore <<== NOTE! This MUST be the name of this module
5         '================================================================================
6         'Crystal
7         '4-26-07, 100329
      Goto Top       Goto bas_crystal_BackupRestore       Goto Index

runBackupRestoreObjects_justBack (8)

8       
9        Public Sub runBackupRestoreObjects_justBack() 
10           'click in this code and press F5 to just create backup TXT files
11           'keep in mind the file extensions will indicate object type
12      
13        '   BackupRestoreObjects False
14      
15       End Sub 
      Goto Top       Goto bas_crystal_BackupRestore       Goto Index

runBackupRestoreObjects (11)

16      
17       Public Sub runBackupRestoreObjects() 
18           'click in this code and press F5 to run
19           'make sure you have backup up the database first!
20          If MsgBox("If you have backed up your database and are ready, click Yes" _ 
21             , vbYesNo + vbDefaultButton2 _ 
22             , "Backup and Restore Queries, Forms, Reports, Macros, and Modules?") = vbNo Then Exit Sub 
23      
24        '   BackupRestoreObjects True
25      
26       End Sub 
      Goto Top       Goto bas_crystal_BackupRestore       Goto Index

BackupRestoreObjects (220)

27      
28      
29      
30       Public Function BackupRestoreObjects(db As DAO.Database _ 
31          , Optional pBooRestore As Boolean = False) 
32      
33           'backup to text files: Queries, Forms, Reports, Macros, and Modules
34           ' OR Restore: delete these objects from the databse and restore them from text files
35      
36           '(bas_crystal_BackupRestore is NOT restored as that is where this code is)
37           'DELETES temporary queries -- those starting with "~"
38           'after running this, compile the databse
39      
40           'does NOT backup and restore tables
41      
42           'this module must be called --> bas_crystal_BackupRestore
43      
44           'NEEDS REFERENCE TO
45           'Microsoft DAO Object Library
46      
47           'written by Crystal strive4peace2007 at yahoo.com
48           'based on code by:
49           '-- Arvin Meyer   http://www.datastrat.com/Code/DocDatabase.txt
50           '-- Brent Spauling (datAdrenaline)
51      
52           'PARAMETERS
53           'pBooRestore - True = restore also, False = backup only
54           '(if not specified, will backup only)
55      
56           'text files will be saved in a directory below the database called BAK_TEXT
57      
58          On Error GoTo proc_err 
59      
60          Dim Cnt As DAO.Container _ 
61             , Doc As DAO.Document 
62      
63          Dim sPath As String _ 
64             , sFilename As String _ 
65             , sFilenameCorrected As String _ 
66             , sFileExt As String _ 
67             , i As Integer _ 
68             , sContainerName As String _ 
69             , nObjType As Long _ 
70             , sMsg As String _ 
71             , sDocName As String 
72      
73          sPath = CurrentProject.Path & "\BAK_TEXT\" 
74          If Len(Dir(sPath, vbDirectory)) = 0 Then 
75             MkDir sPath 
76             DoEvents 
77          End If 
78      
79      
80          With db 
81              'close all open forms, reports, queries
82             For i = Forms.Count To 1 Step -1 
83                DoCmd.Close acForm, Forms(i) 
84             Next i 
85             For i = Reports.Count To 1 Step -1 
86                DoCmd.Close acReport, Reports(i) 
87             Next i 
88             On Error Resume Next 
89             For i = .QueryDefs.Count - 1 To 0 Step -1 
90                DoCmd.Close acQuery, .QueryDefs(i - 1) 
91             Next i 
92             On Error GoTo proc_err 
93              '-------------------------
94      
95             For i = 1 To 4 
96                Select Case i 
97                 '---------- FORMS
98                Case 1 
99                   sContainerName = "Forms" 
100                  nObjType = acForm 
101                  sFileExt = ".frm" 
102     
103                '---------- REPORTS
104               Case 2 
105                  sContainerName = "Reports" 
106                  nObjType = acReport 
107                  sFileExt = ".rpt" 
108     
109                '---------- MACROS
110               Case 3 
111                  sContainerName = "Scripts" 
112                  nObjType = acMacro 
113                  sFileExt = ".mac" 
114     
115                '---------- MODULES
116               Case 4 
117                  sContainerName = "Modules" 
118                  nObjType = acModule 
119                  sFileExt = ".mod" 
120     
121               End Select 
122     
123     
124               Set Cnt = db.Containers(sContainerName) 
125     
126               Debug.Print "---" & sContainerName & "---" 
127               For Each Doc In Cnt.Documents 
128                  sDocName = Doc.Name 
129     
130                  sFilename = sPath & Doc.Name & sFileExt 
131                  sFilenameCorrected = sPath & "Correct_" & Local_CorrectName(Doc.Name) & sFileExt 
132     
133                  sMsg = "backed up " 
134                   'delete file if it already exists
135                  If Len(Dir(sFilenameCorrected)) > 0 Then 
136                     Kill sFilenameCorrected 
137                     DoEvents 
138                  End If 
139     
140                   'Backup object
141                  Application.SaveAsText nObjType, sDocName, sFilenameCorrected 
142     
143                   'copy filename to actual name of object if different than corrected name
144                  If sFilenameCorrected <> sFilename Then 
145                     FileCopy sFilenameCorrected, sFilename 
146                  End If 
147     
148                   'delete object and restore from text file
149                  If Doc.Name <> "bas_crystal_BackupRestore" Then 
150                     If pBooRestore Then 
151                        DoCmd.DeleteObject nObjType, sDocName 
152                        On Error Resume Next 
153                        DoEvents 
154                        On Error GoTo proc_err 
155                        LoadFromText nObjType, sDocName, sFilenameCorrected 
156                        sMsg = sMsg & "and restored " 
157                     End If 
158                  End If 
159     
160                  sMsg = sMsg & "--> " & sDocName 
161                  Debug.Print sMsg 
162     
163               Next Doc 
164     
165            Next i 
166     
167         End With 
168     
169          '---------- QUERIES
170         Debug.Print "--- Queries ---" 
171         For i = db.QueryDefs.Count - 1 To 0 Step -1 
172            sMsg = "backed up " 
173            sDocName = db.QueryDefs(i).Name 
174            If Left(sDocName, 1) <> "~" Then 
175               sFilename = sPath & sDocName & ".qry" 
176               sFilenameCorrected = sPath & "Correct_" & Local_CorrectName(sDocName) & ".qry" 
177     
178                'delete file if it already exists
179               If Len(Dir(sFilenameCorrected)) > 0 Then 
180                  Kill sFilenameCorrected 
181                  DoEvents 
182               End If 
183     
184                'Backup object
185               If sFilename <> sFilenameCorrected Then 
186                  If Len(Dir(sFilename)) > 0 Then 
187                     Kill sFilename 
188                     DoEvents 
189                  End If 
190               End If 
191               Application.SaveAsText acQuery, sDocName, sFilenameCorrected 
192               If sFilenameCorrected <> sFilename Then 
193                  FileCopy sFilenameCorrected, sFilename 
194               End If 
195     
196                'restore object
197               If pBooRestore Then 
198                  sMsg = sMsg & "and restored " 
199                  DoCmd.DeleteObject acQuery, sDocName 
200                  On Error Resume Next 
201                  DoEvents 
202                  On Error GoTo proc_err 
203                  LoadFromText acQuery, sDocName, sFilenameCorrected 
204               End If 
205               sMsg = sMsg & "--> " & sDocName 
206               Debug.Print sMsg 
207            End If 
208         Next i 
209     
210     
211     
212         If pBooRestore Then 
213            sMsg = "backed up and restored objects" _ 
214               & vbCrLf & vbCrLf _ 
215               & "Compile the database then Compact/Repair" 
216         Else 
217            sMsg = "backed up objects" 
218         End If 
219     
220         sMsg = sMsg & vbCrLf & vbCrLf & " deleted " _ 
221            & DeleteTemporaryQueries() & " temporary queries" 
222         DoEvents 
223     
224         MsgBox sMsg, , "Done" 
225     
226      proc_exit: 
227         On Error Resume Next 
228          'close and release object variables
229         Set Doc = Nothing 
230         Set Cnt = Nothing 
231     
232         Exit Function 
233     
234     
235      proc_err: 
236         MsgBox Err.Description, , _ 
237              "ERROR " & Err.Number _ 
238              & "   BackupRestoreObjects" 
239     
240          'press F8 to step through code and debug
241          'remove next line after debugged
242         Stop:    Resume Next 
243     
244         Resume proc_exit 
245     
246      End Function 
      Goto Top       Goto bas_crystal_BackupRestore       Goto Index

Local_CorrectName (37)

247     
248      Private Function Local_CorrectName(pName) As String 
249          'this is a copy of a function that is usually in my main general library
250          'included here for convenience
251     
252          'written by Crystal strive4peace2007 at yahoo.com
253     
254         Dim i As Integer _ 
255            , mChar As String * 1 _ 
256            , mName As String _ 
257            , mLastChar As String * 1 _ 
258            , mNewChar As String 
259     
260         If IsNull(pName) Then Exit Function 
261     
262         pName = LTrim(Trim(pName)) 
263     
264         For i = 1 To Len(pName) 
265            mChar = Mid(pName, i, 1) 
266       '      use this line if you also want to replaces spaces
267            If InStr("`!@#$%^&*()+=|\:;""'<>,.?/ ", mChar) > 0 Then 
268       '      If InStr("`!@#$%^&*()+=|\:;""'<>,.?/", mChar) > 0 Then
269               mNewChar = "_" 
270            Else 
271               mNewChar = mChar 
272            End If 
273     
274            If mLastChar = "_" And mNewChar = "_" Then 
275            Else 
276               mName = mName & mNewChar 
277            End If 
278     
279            mLastChar = mNewChar 
280         Next i 
281         Local_CorrectName = mName 
282     
283      End Function 
      Goto Top       Goto bas_crystal_BackupRestore       Goto Index

DeleteTemporaryQueries (19)

284     
285      Function DeleteTemporaryQueries() As Integer 
286         Dim qdf As DAO.QueryDef _ 
287            , i As Integer 
288         i = 0 
289         Debug.Print "--- deleted temporary queries ---" 
290         For Each qdf In CurrentDb.QueryDefs 
291            If Left(qdf.Name, 1) = "~" Then 
292               Debug.Print qdf.Name 
293               DoCmd.DeleteObject acQuery, qdf.Name 
294               i = i + 1 
295            End If 
296         Next qdf 
297         CurrentDb.QueryDefs.Refresh 
298         Debug.Print "--> " & i & " temporary queries deleted" 
299         DeleteTemporaryQueries = i 
300     
301         Set qdf = Nothing 
302      End Function 
      Goto Top       Goto bas_crystal_BackupRestore       Goto Index

BackupOne (22)

303     
304     
305       '**********************************************
306     
307     
308       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
309      Sub BackupOne() 
310         On Error GoTo proc_err 
311         Application.SaveAsText acForm, "FormName" _ 
312           , "c:\path\FormName.txt" 
313         MsgBox "done saving FormName" 
314     
315      proc_exit: 
316         Exit Sub 
317     
318      proc_err: 
319         MsgBox Err.Description, , _ 
320              "ERROR " & Err.Number _ 
321              & "   BackupOne " 
322         Resume proc_exit 
323         Resume 
324      End Sub 
      Goto Top       Goto bas_crystal_BackupRestore       Goto Index

RestoreOne (10)

325     
326       ' After saving to text, delete the form
327       ' make sure you backed up the database first
328       ' Then...
329     
330      Sub RestoreOne() 
331         LoadFromText acForm, "FormName" _ 
332          , "c:\path\FormName.txt" 
333         MsgBox "done restoring FormName" 
334      End Sub 
      Goto Top       Goto bas_crystal_BackupRestore       Goto Index

EnumContainerProperties (112)

335     
336       '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
337       'Application. is the parent for LoadFromText too ... but it is not 'necessary to specify.  If you do specify it, the intellisense will 'kick in -- for some reason, I forget the "SaveAsText" keyword...
338     
339     
340       '===============================================
341       '=============================================== ENUM
342     
343     
344     
345      Public Sub EnumContainerProperties() 
346       '160320 s4p
347     
348         On Error GoTo proc_err 
349     
350         Dim db As DAO.Database _ 
351            , Cnt As DAO.Container _ 
352            , Doc As DAO.Document _ 
353            , prop As Property 
354     
355         Dim i As Integer _ 
356            , sContainerName As String _ 
357            , sDocName As String 
358     
359         Set db = CurrentDb 
360     
361         With db 
362       '      'close all open forms, reports, queries
363       '      For i = Forms.Count To 1 Step -1
364       '         DoCmd.Close acForm, Forms(i)
365       '      Next i
366       '      For i = Reports.Count To 1 Step -1
367       '         DoCmd.Close acReport, Reports(i)
368       '      Next i
369       '      On Error Resume Next
370       '      For i = .QueryDefs.Count - 1 To 0 Step -1
371       '         DoCmd.Close acQuery, .QueryDefs(i - 1)
372       '      Next i
373       '      On Error GoTo Proc_Err
374             '-------------------------
375     
376            For i = 1 To 4 
377               Select Case i 
378                '---------- FORMS
379               Case 1 
380                  sContainerName = "Forms" 
381     
382                '---------- REPORTS
383               Case 2 
384                  sContainerName = "Reports" 
385     
386                '---------- MACROS
387               Case 3 
388                  sContainerName = "Scripts" 
389     
390                '---------- MODULES
391               Case 4 
392                  sContainerName = "Modules" 
393     
394               End Select 
395     
396     
397               Set Cnt = db.Containers(sContainerName) 
398     
399               Debug.Print "---" & sContainerName & "---" 
400               Set Doc = Cnt.Documents(0) 
401               sDocName = Doc.Name 
402               Debug.Print sDocName 
403               For Each prop In Doc.Properties 
404                  Debug.Print prop.Name & " = "; 
405                  Debug.Print prop.Value 
406               Next prop 
407     
408            Next i 
409     
410         End With 
411     
412          '---------- QUERIES
413         Debug.Print "--- Queries ---" 
414         sDocName = db.QueryDefs(0).Name 
415         Debug.Print sDocName 
416         For Each prop In db.QueryDefs(0).Properties 
417            Debug.Print prop.Name & " = "; 
418            Debug.Print prop.Value 
419         Next prop 
420     
421         MsgBox "Done", , "Done" 
422     
423      proc_exit: 
424         On Error Resume Next 
425          'close and release object variables
426         Set Doc = Nothing 
427         Set Cnt = Nothing 
428         Set db = Nothing 
429     
430         Exit Sub 
431     
432     
433      proc_err: 
434          'MsgBox Err.Description, , _
435               "ERROR " & Err.Number _
436               & "   EnumContainerProperties"
437     
438          'press F8 to step through code and debug
439          'remove next line after debugged
440          'Stop
441         Resume Next 
442     
443         Resume proc_exit 
444     
445      End Sub 
446     
      Goto Top       Goto bas_crystal_BackupRestore       Goto Index

bas_crystal_code_general_0905_1204_1004_1304 (2815)

PROCEDURES       Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Modules       Goto Index
  1. AddFieldDesc (69)
  2. AddFieldToTable (132)
  3. BoldMe (209)
  4. CancelMe (11)
  5. CapString (14)
  6. ClearList (17)
  7. CloseMe (43)
  8. CorrectName (199)
  9. CorrectProper (23)
  10. Declaration Lines (77)
  11. DoesControlExistOnForm (21)
  12. DoesExist (56)
  13. DoesExistDelete (60)
  14. DropMe (31)
  15. DropMeIfNull (13)
  16. EMailReport (74)
  17. ExitAccess (9)
  18. FindRecordN (110)
  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 (70)
  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. RenameFields (59)
  46. RenameTrackingFields (46)
  47. RequeryMe (21)
  48. ResetStuff (14)
  49. RunAddFieldsToTable_Tracking (104)
  50. RunLoopAndCombine (16)
  51. RunLoopCombineVar (20)
  52. SetGBlockDrop (11)
  53. SetRecordSource (59)
  54. SetReportFilter (57)
  55. ShowHideControls (58)
  56. Sort123 (112)
  57. SQLDate (11)
  58. TableHasField (46)
  59. Update_dtmEdit_to_dtmAdd (68)
  60. UpperCase (27)
  61. ZoomMe (21)

Declaration Lines (77)

1         'this can be weeded ... Analyzer doesn't use all this stuff
2        Option Compare Database    'comparison default --> ABC=abc 
3        Option Explicit    'require variable declaration -- always a good practice 
4         '
5         '=======================================================
6         '
7         ' module name: bas_crystal_code_general_0905_1204_1004_1304
8         '
9         '============================================================ LICENSE NOTICE -- must not be modified
10        ' The Analyzer 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        ' Download tested versions of the Analyzer at http://www.AccessMVP.com/strive4peace/Analyzer.htm#download
30        '
31        ' Join Analyzer Developer Project at http://analyzer.codeplex.com/
32        '
33        ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140605
34        ' END LICENSE NOTICE
35        '============================================================
36        '
37        '  includes code written by Brent Spauling (datAdrenaline)
38        '     IsTable
39        '
40        ' categories of procedures:
41        '   FORMS
42        '   OPEN OBJECTS
43        '   REPORTS
44        '   EMAIL
45        '   MAKE OBJECTS
46        '   DATA STRUCTURE
47        '   LIST OBJECTS
48        '   TEST OBJECTS
49        '   CONTROLS
50        '   STRING
51        '   NUMERIC
52        '   DATE
53        '   APPLICATION
54        '   DIRECTORIES
55        '
56        ' NEEDS REFERENCE to -->
57           'a Microsoft DAO Library
58           ' -- OR --
59           ' Microsoft Office 12.0 Access Database Engine Object Library
60        '============================================================
61        'MODIFICATIONS:
62        '
63        ' modified 4-11-09
64        ' 5-12-09 c_ tables
65        ' 5-18-09 RunAddFieldsToTable_Tracking -- DefaultValue for datEdit
66        ' 12-3-09 dbFailOnError
67        ' 12-3 Microsoft Office 12.0 Access Database Engine Object Library
68        '
69        '110323 removed GetDataType
70        '130304 DoesExist
71        '130417 MakeMyQuery, 130418 BoldMe
72      
73        '140628 Graham Mandeno (GM) : changes to circumvent problems of date formatting in non-US locales
74        '140628 Graham Mandeno (GM) : add function SQLDate to format dates for SQL statements
75        '============================================================
76        '
77       Dim gBlockDrop As Boolean 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

CancelMe (11)

78      
79        '===================================================== FORMS
80        '~~~~~~~~~~~~~~~~~~~~~~~~~~ CancelMe
81       Function CancelMe() As Byte 
82        ' Crystal (strive4peace)
83           'example useage: OnClick event of an Undo command button
84           ' = CancelMe()
85           'if there is nothing to Undo, this will create an error -- just ignore
86         On Error Resume Next 
87         DoCmd.RunCommand acCmdUndo 
88       End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

CloseMe (43)

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

RecordFirst (28)

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

RecordPrev (27)

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

RecordNext (28)

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

RecordLast (25)

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

RecordNew (45)

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

RecordDelete (60)

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

IsSubform (17)

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

Sort123 (112)

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

FindRecordN (110)

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

open_Form (25)

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

open_Form_Filter (22)

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

open_Query (14)

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

open_Report (21)

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

SetRecordSource (59)

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

SetReportFilter (57)

725     
726       '~~~~~~~~~~~~~~~~~~~~~~~~~~ SetReportFilter
727      Sub SetReportFilter(pReportName As String _ 
728         , pFilter As String) 
729       ' Crystal (strive4peace)
730     
731          'Save a filter to the specified report
732          'You can do this before you send a report in an email message
733          'You can use this to filter subreports instead of putting criteria in the recordset
734     
735          ' USEAGE:
736          ' example: in code that processes reports for viewing, printing, or email
737          '   SetReportFilter "MyReportname","someID=1000"
738          '   SetReportFilter "MyAppointments","City='Denver' AND dt_appt=#9/18/05#"
739     
740          ' written by Crystal
741          ' strive4peace2010@yahoo.com
742     
743          ' PARAMETERS:
744          ' pReportName is the name of your report
745          ' pFilter is a valid filter string
746     
747         On Error GoTo proc_err 
748     
749          '---------- declare variables
750         Dim Rpt As Report 
751     
752          '---------- open design view of report in Hidden mode (> Access 2000)
753         DoCmd.OpenReport pReportName, acViewDesign   ', , , acHidden 
754     
755          '---------- set object variable to report
756         Set Rpt = Reports(pReportName) 
757     
758          '---------- set report filter and turn it on
759         Rpt.Filter = pFilter 
760         Rpt.FilterOn = IIf(Len(pFilter) > 0, True, False) 
761     
762          '---------- Save and Close report
763         DoCmd.Close acReport, pReportName, acSaveYes 
764     
765      proc_exit: 
766          '----------  Release object variable
767         Set Rpt = Nothing 
768         Exit Sub 
769     
770      proc_err: 
771         Resume Next 
772     
773         MsgBox Err.Description, , "ERROR " & Err.Number & "  SetReportFilter" 
774     
775         Resume proc_exit 
776     
777          'if you want to single-step code to find error, CTRL-Break at MsgBox
778          'then set this to be the next statement
779         Resume 
780     
781      End Sub 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

EMailReport (74)

782     
783       '=========================== Email
784       'SendObject
785       '[objecttype]
786       '[, objectname]
787       '[, outputformat]
788       '[, to]
789       '[, cc]
790       '[, bcc]
791       '[, subject]
792       '[, messagetext]
793       '[, editmessage]
794       '[, templatefile]
795     
796       '~~~~~~~~~~~~~~~~~~~~~~~~~~ EMailReport
797      Sub EMailReport(pReportName As String _ 
798         , pEmailAddress As String _ 
799         , Optional pFriendlyName As String = "" _ 
800         , Optional pBooEditMessage As Boolean = True _ 
801         , Optional pWhoFrom As String = "" _ 
802         , Optional pFormat As String = "SNP") 
803       ' Crystal (strive4peace)
804     
805          'Email a report to someone and construct the subject and message
806          'SNAPSHOT or RTF Format
807     
808          'example useage: on the command button code to process a report
809          ' EMailReport "rptSonglist", "anyone@mymailbox.com", _
810                "A List of the Original Songs from an upcoming Star", _
811                false, "Susan Manager"
812     
813          'PARAMETERS
814          'pReportName --> "rptSonglist"
815          'pEmailAddress --> "anyone@mymailbox.com"
816          'pFriendlyName --> "A List of the Original Songs from an upcoming Star"
817          'pBooEditMessage --> true if you want to edit the message before mail is sent
818          '                --> false if you want it to get sent automatically
819          'pWhoFrom --> "Susan Manager"
820     
821         On Error GoTo proc_err 
822     
823         Dim mFormat As String 
824     
825         Select Case pFormat 
826            Case "RTF": mFormat = acFormatRTF 
827            Case "SNP": mFormat = acFormatSNP 
828       '      Case "PDF": mFormat = acFormatPDF 'can uncomment for later versions of Access
829            Case "HTML": mFormat = acFormatHTML 
830            Case "TXT": mFormat = acFormatTXT 
831            Case "XLS": mFormat = acFormatXLS 
832         End Select 
833     
834        DoCmd.SendObject acSendReport, pReportName, acFormatRTF, pEmailAddress _ 
835         , , , pFriendlyName & Format(Now(), " ddd m-d-yy h:nn am/pm"), _ 
836         pFriendlyName & " is attached  ---    " _ 
837         & "Regards, " & pWhoFrom, pBooEditMessage 
838     
839         Exit Sub 
840     
841      proc_exit: 
842         Resume Next 
843         Exit Sub 
844     
845      proc_err: 
846     
847         MsgBox Err.Description _ 
848            , , "ERROR " & Err.Number & "  SetReportFilter" 
849     
850         Resume proc_exit 
851     
852          'if you want to single-step code to find error, CTRL-Break at MsgBox
853          'then set this to be the next statement
854         Resume 
855      End Sub 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

MakeMyQuery (70)

856     
857       '===================================================== MAKE OBJECTS
858     
859       '~~~~~~~~~~~~~~~~~~~~~~~~~~ MakeMyQuery
860     
861      Function MakeMyQuery( _ 
862         ByVal pQryName As String _ 
863         , ByVal pSQL As String _ 
864         , Optional pDb As DAO.Database _ 
865         ) As Boolean 
866     
867       'crystal, strive4peace2010@yahoo.com
868       '... 6-3-08, 130417, 21
869     
870          'CALLED BY ANALYZER 130417
871          'DbTests_MakeQuery
872     
873         On Error GoTo proc_err 
874     
875         MakeMyQuery = False 
876     
877         Dim db As DAO.Database 
878     
879         If Not pDb Is Nothing Then 
880            Set db = pDb 
881         Else 
882            Set db = CurrentDb 
883         End If 
884     
885       '   Debug.Print pQryName & " > " & pSql
886     
887          'if query already exists, update the SQL
888          'if not, create the query
889     
890         With db 
891       '      If Nz(DLookup("[Name]", "MSysObjects", _
892       '          "[Name]='" & pQryName _
893       '          & "' And [Type]=5"), "") = "" Then
894       '          .CreateQueryDef pQryName, pSql
895                'if query is open, close it
896            On Error Resume Next 
897            DoCmd.Close acQuery, pQryName, acSaveNo 
898            Err.Clear 
899            .QueryDefs(pQryName).SQL = pSQL 
900            If Err.Number > 0 Then 
901               On Error GoTo proc_err 
902               .CreateQueryDef pQryName, pSQL 
903            Else 
904               On Error GoTo proc_err 
905            End If 
906     
907         End With   'db 
908     
909         MakeMyQuery = True 
910     
911      proc_exit: 
912         On Error Resume Next 
913         db.QueryDefs.Refresh 
914         DoEvents 
915         Set db = Nothing 
916         Exit Function 
917     
918      proc_err: 
919         MsgBox Err.Description, , _ 
920           "ERROR " & Err.Number & "  MakeMyQuery" 
921     
922         Resume proc_exit 
923         Resume 
924     
925      End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

AddFieldToTable (132)

926       '===================================================== DATA STRUCTURE
927       '~~~~~~~~~~~~~~~~~~~~~~~~~~ AddFieldToTable
928      Function AddFieldToTable( _ 
929         pTableName As String, _ 
930         pFldName As String, _ 
931         pDataType As Integer, _ 
932         Optional pFieldSize As Integer, _ 
933         Optional pDefaultValue As String = "", _ 
934         Optional pDesc As String = "", _ 
935         Optional pSkipMessage As Boolean = True, _ 
936         Optional pDb As DAO.Database _ 
937         ) _ 
938         As Boolean 
939     
940          'written by Crystal
941          'strive4peace2010 at yahoo.com
942          'modified 8-28-07, 12-3-09, 150911 pdb
943     
944          'PARAMETERS
945          'pTablename --> name of table to modify structure of
946          'pFldname --> name of field to create
947          'pDataType --> dbText, dbLong, dbDate, etc
948          'pFieldSize --> length for text fields
949          'pDefaultValue --> *AN* = autonumber
950          '         --> *Null* --> DefaultValue = Null
951          '         --> *Now* --> DefaultValue = Now()
952          '         --> otherwise whatever is specified
953     
954          'NEEDS Reference to
955          'a Microsoft DAO Library
956          ' -- OR --
957          ' Microsoft Office 12.0 Access Database Engine Object Library
958     
959         On Error GoTo proc_err 
960     
961         AddFieldToTable = False 
962     
963         Dim db As DAO.Database, Fld As DAO.Field 
964     
965          'you could make this a passed parameter
966          ' and open another database
967     
968         If pDb Is Nothing Then 
969            Set db = CurrentDb 
970         Else 
971            Set db = pDb 
972         End If 
973     
974         With db.TableDefs(pTableName) 
975     
976            Select Case pDataType 
977              Case dbText 
978                   'Text
979                  Set Fld = .CreateField(pFldName, _ 
980                    pDataType, pFieldSize) 
981     
982              Case Else 
983                   'Long Integer, Date, etc
984                  Set Fld = .CreateField(pFldName, pDataType) 
985     
986            End Select 
987     
988            If Len(pDefaultValue) > 0 Then 
989               Select Case pDefaultValue 
990               Case "*AN*" 
991                   'Autonumber
992                  Fld.Attributes = dbAutoIncrField 
993               Case "*Null*" 
994                   'Null for DefaultValue
995                  Fld.DefaultValue = "Null" 
996               Case "*Now*" 
997                   'Now for DefaultValue
998                  Fld.DefaultValue = "=Now()" 
999               Case Else 
1,000                 'Now for DefaultValue
1,001                Fld.DefaultValue = "=" & pDefaultValue 
1,002             End Select 
1,003          End If 
1,004   
1,005   
1,006          If pDataType = dbText Then 
1,007             Fld.AllowZeroLength = True 
1,008          End If 
1,009   
1,010          .Fields.Append Fld 
1,011   
1,012          If Len(pDesc) > 0 Then 
1,013             On Error Resume Next 
1,014             Fld.Properties("Description") = pDesc 
1,015             If Err > 0 Then 
1,016                Fld.Properties.Append Fld.CreateProperty("Description" _ 
1,017                   , dbText, pDesc) 
1,018             End If 
1,019             On Error GoTo proc_err 
1,020          End If 
1,021       End With 
1,022   
1,023       db.TableDefs.Refresh 
1,024       DoEvents 
1,025   
1,026       If Not pSkipMessage Then 
1,027         MsgBox "Added --> " & pFldName _ 
1,028          & " to --> " & pTableName, , "Done" 
1,029       End If 
1,030   
1,031       AddFieldToTable = True 
1,032   
1,033    proc_exit: 
1,034       On Error Resume Next 
1,035       If Not Fld Is Nothing Then Set Fld = Nothing 
1,036   
1,037        'if db is external and you OPENed it,
1,038        'you will need to close it too
1,039       If Not db Is Nothing Then Set db = Nothing 
1,040   
1,041       Exit Function 
1,042   
1,043    proc_err: 
1,044        'if the field is already there, ignore error
1,045       If Err = 3191 Then Resume proc_exit 
1,046        'linked table
1,047       If Err.Number = 3057 Or Err.Number = 3211 Then Resume proc_exit 
1,048       MsgBox Err.Description, , _ 
1,049         "ERROR " & Err.Number & "   AddFieldToTable" 
1,050   
1,051       Resume proc_exit 
1,052   
1,053        'if you want to single-step code to find error, CTRL-Break at MsgBox
1,054        'then set this to be the next statement
1,055       Resume 
1,056   
1,057    End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

AddFieldDesc (69)

1,058   
1,059     '~~~~~~~~~~~~~~~~~~~~~~~~~~ AddFieldDesc
1,060    Function AddFieldDesc( _ 
1,061       pTableName As String, _ 
1,062       pFldName As String, _ 
1,063       pDesc As String, _ 
1,064       Optional pSkipMessage As Boolean = True) _ 
1,065       As Boolean 
1,066     ' Crystal (strive4peace)
1,067   
1,068       On Error GoTo proc_err 
1,069   
1,070       AddFieldDesc = False 
1,071   
1,072       Dim db As DAO.Database _ 
1,073          , Fld As DAO.Field _ 
1,074          , prop As DAO.Property 
1,075   
1,076        'you could make this a passed parameter
1,077        ' and open another database
1,078   
1,079       Set db = CurrentDb 
1,080   
1,081       With db.TableDefs(pTableName) 
1,082   
1,083          On Error Resume Next 
1,084          .Fields(pFldName).Properties("Description") = pDesc 
1,085   
1,086          If Err.Number = 3270 Then 
1,087             On Error GoTo proc_err 
1,088             Set prop = .Fields(pFldName).CreateProperty("Description" _ 
1,089                , dbText, pDesc) 
1,090             .Fields(pFldName).Properties.Append prop 
1,091          Else 
1,092             On Error GoTo proc_err 
1,093          End If 
1,094   
1,095       End With 
1,096   
1,097       If Not pSkipMessage Then 
1,098         MsgBox "Added/Updated --> " & pDesc _ 
1,099          & vbCrLf & " as Description to --> " & pTableName & "." & pFldName, , "Done" 
1,100       End If 
1,101   
1,102       AddFieldDesc = True 
1,103   
1,104    proc_exit: 
1,105       On Error Resume Next 
1,106       If Not prop Is Nothing Then Set prop = Nothing 
1,107       If Not Fld Is Nothing Then Set Fld = Nothing 
1,108   
1,109       If Not db Is Nothing Then Set db = Nothing 
1,110       Exit Function 
1,111   
1,112    proc_err: 
1,113        'if the field is already there, ignore error
1,114       If Err = 3191 Then Resume proc_exit 
1,115        'linked table
1,116       If Err = 3057 Then Resume proc_exit 
1,117       MsgBox Err.Description, , _ 
1,118         "ERROR " & Err.Number & "   AddFieldDesc" 
1,119   
1,120       Resume proc_exit 
1,121   
1,122        'if you want to single-step code to find error, CTRL-Break at MsgBox
1,123        'then set this to be the next statement
1,124       Resume 
1,125   
1,126    End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

TableHasField (46)

1,127   
1,128   
1,129   
1,130     '~~~~~~~~~~~~~~~~~~~~~~~~~~ TableHasField
1,131    Function TableHasField( _ 
1,132       pTbl As String _ 
1,133       , pFldName As String _ 
1,134       ) As Boolean 
1,135     ' Crystal (strive4peace)
1,136   
1,137       On Error GoTo proc_err 
1,138   
1,139       TableHasField = False 
1,140       Dim db As DAO.Database _ 
1,141          , tdf As DAO.TableDef _ 
1,142          , Fld As DAO.Field 
1,143   
1,144       Set db = CurrentDb 
1,145       Set tdf = db.TableDefs(pTbl) 
1,146   
1,147       For Each Fld In tdf.Fields 
1,148          If Fld.Name = pFldName Then 
1,149             TableHasField = True 
1,150             GoTo proc_exit 
1,151          End If 
1,152       Next Fld 
1,153   
1,154    proc_exit: 
1,155       Set Fld = Nothing 
1,156       Set tdf = Nothing 
1,157       Set db = Nothing 
1,158       Exit Function 
1,159   
1,160    proc_err: 
1,161       MsgBox Err.Description, , _ 
1,162            "ERROR " & Err.Number _ 
1,163            & "   TableHasField" 
1,164   
1,165       Resume proc_exit 
1,166   
1,167        'if you want to single-step code to find error, CTRL-Break at MsgBox
1,168        'then set this to be the next statement
1,169       Resume 
1,170   
1,171    End Function 
1,172     '===================================================== LIST OBJECTS
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

listQuerySQL (21)

1,173   
1,174     '~~~~~~~~~~~~~~~~~~~~~~~~~~ listQuerySQL
1,175    Sub listQuerySQL() 
1,176       Dim qdf As DAO.QueryDef, db As DAO.Database 
1,177       Dim i As Integer 
1,178   
1,179       Set db = CurrentDb   'or whatever 
1,180       i = 0 
1,181       For Each qdf In db.QueryDefs 
1,182          i = i + 1 
1,183   
1,184          If MsgBox(qdf.SQL, vbOKCancel, _ 
1,185             i & " " & qdf.Name) = vbCancel Then Exit Sub 
1,186   
1,187          Debug.Print "--- " & i & " -- " & qdf.Name & " ---" 
1,188          Debug.Print qdf.SQL 
1,189       Next qdf 
1,190   
1,191        'Set qdf = Nothing --> not necessary -- looses scope at end of loop
1,192       Set db = Nothing 
1,193    End Sub 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

ListIndexes (19)

1,194   
1,195     '~~~~~~~~~~~~~~~~~~~~~~~~~~ ListIndexes
1,196    Sub ListIndexes(pt As String) 
1,197     '11-11-07
1,198       Dim db As DAO.Database _ 
1,199          , tdf As TableDef _ 
1,200          , Idx As DAO.Index 
1,201   
1,202       Set db = CurrentDb 
1,203       Set tdf = db.TableDefs(pt) 
1,204   
1,205       For Each Idx In tdf.Indexes 
1,206          Debug.Print Idx.Name, Idx.Fields.Count, Idx.Fields(0).Name 
1,207       Next Idx 
1,208   
1,209       Set tdf = Nothing 
1,210       Set db = Nothing 
1,211   
1,212    End Sub 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

IsTable (20)

1,213   
1,214     '===================================================== TEST OBJECTS
1,215   
1,216     '~~~~~~~~~~~~~~~~~~~~~~~~~~ IsTable
1,217    Public Function IsTable( _ 
1,218       strTableName As String _ 
1,219       ) As Boolean 
1,220        'return TRUE if table or query exists in current database
1,221        'written by Brent Spauling (datAdrenaline)
1,222   
1,223        With CurrentProject.Connection 
1,224            IsTable = .OpenSchema(20, Array(Empty, Empty, strTableName)).EOF   'adSchemaTables = 20 
1,225        End With 
1,226        Exit Function 
1,227   
1,228         'for Access 97...
1,229        IsTable = (DCount("Name", "MSysObjects", _ 
1,230                    "Name = '" & strTableName & "' And Type In (1,4,6)") <> 0) 
1,231   
1,232    End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

DoesExist (56)

1,233   
1,234     '~~~~~~~~~~~~~~~~~~~~~~~~~~ DoesExist
1,235    Function DoesExist( _ 
1,236       sTblOrQryName As String _ 
1,237       , Optional sTQ As String = "" _ 
1,238       ) As Boolean 
1,239     'Crystal 100421, 130304
1,240   
1,241        'checks table and queries to see if the name exists
1,242        'example useage: call before Appending records to a table.  If not there, make the table
1,243        ' If not DoesExist("SummaryTable") then Call MakeTheTable("SummaryTable")
1,244      DoesExist = False 
1,245      Dim i As Integer 
1,246   
1,247   
1,248      Dim db As DAO.Database 
1,249      Set db = CurrentDb 
1,250   
1,251      Dim sName As String 
1,252   
1,253      If sTQ = "Q" Then GoTo TestForQuery 
1,254   
1,255       On Error Resume Next 
1,256       With db 
1,257          .TableDefs.Refresh 
1,258          sName = .TableDefs(sTblOrQryName).Name 
1,259          If Err.Number > 0 Then 
1,260             Err.Clear 
1,261          Else 
1,262             Err.Clear 
1,263             DoesExist = True 
1,264             GoTo proc_exit 
1,265           End If 
1,266           'if only testing for a table, then exit
1,267          If sTQ = "T" Then Exit Function 
1,268       End With   'db 
1,269   
1,270    TestForQuery: 
1,271       With db 
1,272          .QueryDefs.Refresh 
1,273          On Error Resume Next 
1,274          sName = .QueryDefs(sTblOrQryName).Name 
1,275          If Err.Number > 0 Then 
1,276             Err.Clear 
1,277          Else 
1,278             Err.Clear 
1,279             DoesExist = True 
1,280             GoTo proc_exit 
1,281          End If 
1,282       End With   'db 
1,283   
1,284    proc_exit: 
1,285       On Error Resume Next 
1,286       Set db = Nothing 
1,287   
1,288    End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

DoesExistDelete (60)

1,289   
1,290      '~~~~~~~~~~~~~~~~~~~~~~~~~~ DoesExistDelete
1,291    Function DoesExistDelete( _ 
1,292       TblOrQryName As String _ 
1,293       , Optional pTQ As String = "TQ" _ 
1,294       ) As Boolean 
1,295     ' Crystal (strive4peace)
1,296   
1,297     '11-16-08, 12-20
1,298   
1,299        'checks table and queries to see if the name exists
1,300        'example useage: delete linked table references
1,301   
1,302       On Error GoTo proc_err 
1,303       DoesExistDelete = False 
1,304   
1,305       Dim db As Database 
1,306   
1,307       Dim i As Integer 
1,308   
1,309       Set db = CurrentDb 
1,310   
1,311       If InStr(pTQ, "T") > 0 Then 
1,312   
1,313          For i = (db.TableDefs.Count - 1) To 0 Step -1 
1,314   
1,315            If db.TableDefs(i).Name = TblOrQryName Then 
1,316              db.TableDefs.Delete db.TableDefs(i).Name 
1,317              DoesExistDelete = True 
1,318              Exit Function 
1,319            End If 
1,320   
1,321          Next i 
1,322       End If 
1,323   
1,324       If InStr(pTQ, "Q") > 0 Then 
1,325   
1,326          For i = 0 To db.QueryDefs.Count - 1 
1,327   
1,328            If db.QueryDefs(i).Name = TblOrQryName Then 
1,329              db.QueryDefs.Delete db.QueryDefs(i).Name 
1,330              DoesExistDelete = True 
1,331              Exit Function 
1,332            End If 
1,333          Next i 
1,334      End If 
1,335   
1,336   
1,337    proc_exit: 
1,338       Set db = Nothing 
1,339       Exit Function 
1,340   
1,341    proc_err: 
1,342       MsgBox Err.Description, , _ 
1,343            "ERROR " & Err.Number _ 
1,344            & "   DoesExistDelete" 
1,345   
1,346       Resume proc_exit 
1,347       Resume 
1,348    End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

IsLoadedForm (28)

1,349   
1,350     '~~~~~~~~~~~~~~~~~~~~~~~~~~ IsLoadedForm
1,351    Function IsLoadedForm(pForsName As String) As Boolean 
1,352     ' Crystal (strive4peace)
1,353   
1,354        'This function returns  TRUE if the passed form is loaded  FALSE if it is not
1,355        'example useage: call before opening a form
1,356        ' If IsLoadedForm("ForsName") Then DoCmd.SelectObject acForm, "ForsName"
1,357       IsLoadedForm = False 
1,358        '  True if the specified form is open not in Design view
1,359       If CurrentProject.AllForms(pForsName).IsLoaded Then 
1,360          If Forms(pForsName).CurrentView <> 0 Then IsLoadedForm = True 
1,361       End If 
1,362       Exit Function 
1,363   
1,364        'for Access 97
1,365       IsLoadedForm = False 
1,366       Dim i As Integer 
1,367       Err.Number = 0 
1,368       On Error GoTo proc_exit 
1,369       For i = 0 To Forms.Count - 1 
1,370          If pForsName = Forms(i).Name Then 
1,371             IsLoadedForm = True 
1,372             Exit Function 
1,373          End If 
1,374       Next i 
1,375    proc_exit: 
1,376    End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

IsLoadedReport (27)

1,377   
1,378     '~~~~~~~~~~~~~~~~~~~~~~~~~~ IsLoadedReport
1,379    Function IsLoadedReport(pReportName As String) As Boolean 
1,380     ' Crystal (strive4peace)
1,381        'This function returns  TRUE if the passed Report is loaded  FALSE if it is not
1,382        'example useage: call before changing a report filter
1,383        ' If IsLoadedReport("Reportname") Then --> report does not have to be opened
1,384   
1,385       If CurrentProject.AllReports(pReportName).IsLoaded Then 
1,386          If Forms(pReportName).CurrentView <> 0 Then IsLoadedReport = True 
1,387       End If 
1,388   
1,389       Exit Function 
1,390   
1,391        'for Access 97...
1,392       IsLoadedReport = False 
1,393       Dim i As Integer 
1,394       Err.Number = 0 
1,395       On Error GoTo proc_exit 
1,396       For i = 0 To Reports.Count - 1 
1,397          If pReportName = Reports(i).Name Then 
1,398             IsLoadedReport = True 
1,399             Exit Function 
1,400          End If 
1,401       Next i 
1,402    proc_exit: 
1,403    End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

DoesControlExistOnForm (21)

1,404   
1,405     '~~~~~~~~~~~~~~~~~~~~~~~~~~ DoesControlExistOnForm
1,406    Function DoesControlExistOnForm(pF As Form _ 
1,407       , pControlname As String) As Boolean 
1,408     ' Crystal (strive4peace)
1,409   
1,410       On Error GoTo proc_err 
1,411       DoesControlExistOnForm = False 
1,412   
1,413       Dim sStr As String 
1,414   
1,415       sStr = pF(pControlname).Name 
1,416   
1,417       DoesControlExistOnForm = True 
1,418   
1,419    proc_exit: 
1,420       On Error Resume Next 
1,421       Exit Function 
1,422    proc_err: 
1,423       Resume proc_exit 
1,424    End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

IsValidURL (38)

1,425   
1,426     '~~~~~~~~~~~~~~~~~~~~~~~~~~ IsValidURL
1,427    Function IsValidURL( _ 
1,428       pURL As String _ 
1,429       ) As Boolean 
1,430     ' Crystal (strive4peace)
1,431   
1,432     '6-9-07
1,433        'default value is to allow URL's that do not pass validation
1,434   
1,435       IsValidURL = True 
1,436   
1,437       Select Case True 
1,438       Case Left(pURL, 7) = "http://", Left(pURL, 6) = "ftp://", InStr(pURL, "www.") > 0 
1,439       Case Else 
1,440          If MsgBox("URL is missing 'www.' or 'http://' or 'Ftp://'" _ 
1,441             & vbCrLf & vbCrLf & "OK to keep anyway and stop checking or CANCEL to Undo Record" _ 
1,442             , vbOKCancel _ 
1,443             , "Invalid URL: keep anyway and stop checking OR Cancel update") = vbCancel Then 
1,444   
1,445             IsValidURL = False 
1,446             Exit Function 
1,447   
1,448          End If 
1,449       End Select 
1,450   
1,451       If InStr(pURL, ".") = 0 Then 
1,452          If MsgBox("Web Website is not valid, must contain a period" _ 
1,453             & vbCrLf & vbCrLf & "OK to keep anyway and stop checking or CANCEL to Undo Record" _ 
1,454             , vbOKCancel, "Fix Web Website or Cancel") = vbCancel Then 
1,455   
1,456             IsValidURL = False 
1,457   
1,458             Exit Function 
1,459          End If 
1,460       End If 
1,461   
1,462    End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

SetGBlockDrop (11)

1,463   
1,464     '===================================================== CONTROLS
1,465     '~~~~~~~~~~~~~~~~~~~~~~~~~~ SetGBlockDrop
1,466    Function SetGBlockDrop( _ 
1,467       Optional pBoo As Boolean = True _ 
1,468       ) As Byte 
1,469   
1,470     '11-23-08
1,471   
1,472       gBlockDrop = Nz(pBoo, True) 
1,473    End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

DropMe (31)

1,474   
1,475     '~~~~~~~~~~~~~~~~~~~~~~~~~~ DropMe
1,476    Function DropMe(Optional bSetToNull As Boolean = False) As Byte 
1,477     ' Crystal (strive4peace)
1,478   
1,479       On Error GoTo proc_err 
1,480        'usually used on the MouseUp event of a Combo Box
1,481        'so you can click anywhere and drop the list
1,482        'instead of just on the arrow
1,483        '=DropMe()
1,484   
1,485        'gBlockDrop is set on ZoomMe
1,486        'this is done so the box won't drop when
1,487        'double-click has been used for Zoom box
1,488       If gBlockDrop Then 
1,489          gBlockDrop = False 
1,490          Exit Function 
1,491       End If 
1,492   
1,493       If bSetToNull Then 
1,494          Screen.ActiveControl = Null 
1,495       End If 
1,496   
1,497       Screen.ActiveControl.Dropdown 
1,498    proc_exit: 
1,499       Exit Function 
1,500    proc_err: 
1,501        'MsgBox Err.Number & " " & Err.Description _
1,502           , , "Cannot drop list right now"
1,503       Resume proc_exit 
1,504    End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

DropMeIfNull (13)

1,505   
1,506     '~~~~~~~~~~~~~~~~~~~~~~~~~~ DropMeIfNull
1,507    Function DropMeIfNull() As Byte 
1,508     ' Crystal (strive4peace)
1,509   
1,510        'usually used on the GotFocus event of a Combo Box
1,511        'so if there is nothing filled out yet, the list will drop
1,512        'Do NOT use on the first control in the tab order
1,513        '=DropMeIfNull()
1,514       On Error Resume Next 
1,515       If IsNull(Screen.ActiveControl) Then Screen.ActiveControl.Dropdown 
1,516       Exit Function 
1,517    End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

RequeryMe (21)

1,518   
1,519     '~~~~~~~~~~~~~~~~~~~~~~~~~~ RequeryMe
1,520    Function RequeryMe(Optional pC As Control) As Byte 
1,521     ' Crystal (strive4peace)
1,522   
1,523        'used to rebuild combo box and listbox lists
1,524        'put on the double-click event of a combobox
1,525        ' =RequeryMe()
1,526        ' =RequeryMe([listRels])
1,527        ' if control is not specief. ActiveControl will be used
1,528   
1,529       On Error GoTo proc_err 
1,530       If pC Is Nothing Then 
1,531          Screen.ActiveControl.Requery 
1,532       Else 
1,533          pC.Requery 
1,534       End If 
1,535       Exit Function 
1,536    proc_err: 
1,537       MsgBox Err.Number & " " & Err.Description, , "Cannot Requery control right now" 
1,538    End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

ZoomMe (21)

1,539   
1,540     '~~~~~~~~~~~~~~~~~~~~~~~~~~ ZoomMe
1,541    Function ZoomMe() As Byte 
1,542     ' Crystal (strive4peace)
1,543   
1,544        'pop up the ZOOM box for editing
1,545        'used in text and combo boxes where the text
1,546        'may be longer than the display
1,547        'put on the Double-Click event of the control
1,548        '=ZoomMe()
1,549       On Error Resume Next 
1,550       DoCmd.RunCommand acCmdZoomBox 
1,551   
1,552        'this is set so that if DropMe is used on a combo
1,553        'for mouse up, the list won't drop
1,554        'after the Zoom box
1,555       gBlockDrop = True 
1,556   
1,557        'this is the old way
1,558        'SendKeys "+{F2}", True
1,559    End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

ClearList (17)

1,560   
1,561     '~~~~~~~~~~~~~~~~~~~~~~~~~~ ClearList
1,562    Function ClearList( _ 
1,563       ctl As Control _ 
1,564       ) As Boolean 
1,565     ' Crystal (strive4peace)
1,566     '4-4-09
1,567     'clear listbox items selected
1,568     'CALLED BY code behind ANALYZER a_f_DisplayControl form
1,569       On Error Resume Next 
1,570       ClearList = False 
1,571       Dim varItem As Variant 
1,572       For Each varItem In ctl.ItemsSelected 
1,573           ctl.Selected(varItem) = False 
1,574           ClearList = True 
1,575       Next varItem 
1,576    End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

ShowHideControls (58)

1,577   
1,578     '~~~~~~~~~~~~~~~~~~~~~~~~~~ ShowHideControls
1,579    Function ShowHideControls(pObj As Object _ 
1,580      , pBoo As Boolean _ 
1,581      , pTag As String _ 
1,582      , Optional pControlNameFocus As String = "" _ 
1,583      ) As Byte 
1,584     ' Crystal (strive4peace)
1,585   
1,586        'PARAMETERS
1,587        ' pObj : form reference or section of form
1,588        ' if section, Parent property will be used to get form reference
1,589        '  if 'parent' is in the tag
1,590   
1,591       Dim ctl As Control _ 
1,592       , f As Form 
1,593   
1,594       If InStr(pObj.Tag, "parent") > 0 Then 
1,595          Set f = pObj.Parent 
1,596       Else 
1,597          Set f = pObj 
1,598       End If 
1,599   
1,600        'move focus if we are making invisible
1,601        If Not pBoo Then 
1,602          If pControlNameFocus <> "" Then f(pControlNameFocus).SetFocus 
1,603        End If 
1,604   
1,605       On Error GoTo proc_err 
1,606   
1,607       For Each ctl In pObj.Controls 
1,608   
1,609          If InStr(ctl.Tag, pTag) > 0 Then 
1,610            ctl.Visible = pBoo 
1,611          End If 
1,612   
1,613       Next ctl 
1,614   
1,615        'move focus after controls are visible
1,616       If pBoo Then 
1,617          If pControlNameFocus <> "" Then f(pControlNameFocus).SetFocus 
1,618       End If 
1,619   
1,620    proc_exit: 
1,621   
1,622       Set ctl = Nothing 
1,623       Set f = Nothing 
1,624       Exit Function 
1,625   
1,626    proc_err: 
1,627       MsgBox Err.Description, , _ 
1,628       "ERROR " & Err.Number _ 
1,629       & " ShowHideControls" 
1,630   
1,631       Resume proc_exit 
1,632       Resume 
1,633   
1,634    End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

ProperCase (45)

1,635   
1,636     '~~~~~~~~~~~~~~~~~~~~~~~~~~ ProperCase
1,637    Function ProperCase(Optional pC As Control _ 
1,638       ) As Boolean 
1,639     ' Crystal (strive4peace)
1,640     '8-12-08, 4-4-09
1,641   
1,642        'change active control to Proper case if cma_ProperCase = true
1,643   
1,644        'EXAMPLES
1,645   
1,646        ' on AfterUpdate property -->
1,647        ' =ProperCase()
1,648        ' =ProperCase([ControlName])
1,649        '
1,650        ' in code -->
1,651        ' ProperCase Me.ActiveControl
1,652   
1,653        'if there is an error ignore it (and it probably won't happen anyway
1,654        '-- unless, for instance, you try this with a number)
1,655        'since null values are tested 
1,656   
1,657        'for a more in-depth version that corrects for things like MacDonald, O'Hare, etc, look here:
1,658        '   Uppercase converter (incl. Auto-Correct) by Rob Richards (r_Cubed)
1,659        '   http://www.utteraccess.com/forums/showflat.php?Cat=&Board=48&Number=619856
1,660   
1,661       ProperCase = False 
1,662   
1,663       On Error Resume Next 
1,664   
1,665        'THIS ONLY EXECUTES IF A CUSTOM PROPERTY IS SET
1,666     '   If Not Get_Property("cma_ProperCase") Then Exit Function
1,667   
1,668        'if a control reference was not passed, use the active control on the screen
1,669       If pC Is Nothing Then Set pC = Screen.ActiveControl 
1,670   
1,671        'if the control is not filled out, don't do anything
1,672       If IsNull(pC) Then Exit Function 
1,673   
1,674        'convert the contents of the control to ProperCase
1,675       pC = CorrectProper(StrConv(pC, vbProperCase)) 
1,676   
1,677       ProperCase = True 
1,678   
1,679    End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

UpperCase (27)

1,680   
1,681     '~~~~~~~~~~~~~~~~~~~~~~~~~~ UpperCase
1,682    Function UpperCase(Optional pC As Control) As Byte 
1,683     ' Crystal (strive4peace)
1,684   
1,685        '10-27-07
1,686        'change active control to Upper Case
1,687        'EXAMPLE
1,688        ' on AfterUpdate property -->
1,689        ' =UpperCase([ControlName])
1,690   
1,691        'if there is an error ignore it (and it probably won't happen anyway
1,692        '-- unless, for instance, you try this with a number)
1,693        'since null values are tested 
1,694   
1,695       On Error Resume Next 
1,696   
1,697        'if a control reference was not passed, use the active control on the screen
1,698       If pC Is Nothing Then Set pC = Screen.ActiveControl 
1,699   
1,700        'if the control is not filled out, don't do anything
1,701       If IsNull(pC) Then Exit Function 
1,702   
1,703        'convert the contents of the control to UpperCase
1,704       pC = UCase(pC) 
1,705   
1,706    End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

CorrectProper (23)

1,707   
1,708     '~~~~~~~~~~~~~~~~~~~~~~~~~~ CorrectProper
1,709    Function CorrectProper(pString As String) As String 
1,710     ' Crystal (strive4peace)
1,711   
1,712     '5-15-07
1,713        'correct:
1,714        'Macx* --> MacX*
1,715        'Vanx* --> VanX*
1,716        'Mcx* --> McX*
1,717        'will only correct if at beginning of passed string, not in the middle
1,718   
1,719       Select Case True 
1,720       Case Len(pString) > 4 And InStr(".Mac.Van.", "." & Left(pString, 3) & ".") > 0 
1,721          pString = Left(pString, 3) & UCase(Mid(pString, 4, 1)) & Right(pString, Len(pString) - 4) 
1,722       Case Left(pString, 2) = "Mc" And Len(pString) > 3 
1,723          pString = Left(pString, 2) & UCase(Mid(pString, 3, 1)) & Right(pString, Len(pString) - 3) 
1,724   
1,725       End Select 
1,726   
1,727       CorrectProper = pString 
1,728   
1,729    End Function 
      Goto Top       Goto bas_crystal_code_general_0905_1204_1004_1304       Goto Index

BoldMe (209)

1,730   
1,731     '~~~~~~~~~~~~~~~~~~~~~~~~~~ BoldMe
1,732    Function BoldMe(Optional pF As Form _ 
1,733       , Optional pControlname As String = "" _ 
1,734       , Optional pnLastOption As Integer = 0 _ 
1,735       , Optional pValue As Variant _ 
1,736       , Optional pnFirstOption As Integer = 1 _ 
1,737       ) As Byte 
1,738     '9-9-08,12-4-09
1,739     '3-26-10 modify attached label if available. reversed naming convention
1,740     '100330 nz, 130418 frame
1,741     '150415 s4p if label cannot be found, err.number = 13. Exiting on error
1,742   
1,743        'CALLED BY ANALYZER
1,744        'a_f_ANALYZER_MENU
1,745   
1,746        ' Crystal
1,747        ' strive4peace2010@yahoo.com
1,748        ' http://www.accessMVP.com/strive4peace/BoldMe.htm
1,749   
1,750