API tools faq
paste
KySoto

Modular Save Code

KySoto
Aug 28th, 2018
225
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
VisualBasic 57.35 KB | None | 0 0
raw download clone embed print report
  1. Option Compare Database
  2. 'ModularSaveCodeVersion = 35
  3. Option Explicit
  4. 'Do Not Move the above line
  5. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  6. ' Version 1 - 26/Apr/2016 - initial                                            '
  7. ' Version 2 - 02/may/2016 - added the version system to the module and d to tag'
  8. ' Version 3 - 16/May/2016 - updated the saveall function to handle situations  '
  9. '                           where we need to update a record instead of make a '
  10. '                           new one. Does not break compatability              '
  11. ' Version 4 - 17/May/2016 - added the "o" tag for radio buttons                '
  12. ' Version 5 - 19/May/2016 - added some commenting, changed the fieldname check '
  13. ' Version 6 - 19/May/2016 - fixed huge save bug                                '
  14. ' Version 7 - 07/Jun/2016 - fixed another huge save bug from argFieldName      '
  15. '                           checking for null when it can't ever be null       '
  16. ' Version 8 - 13/Jun/2016 - changed all integers to longs.                     '
  17. ' Version 9 - 23/Jun/2016 - change the argument name argType to argFieldType   '
  18. ' Version10 - 27/Jun/2016 - added a check to skip autonumber fields if i       '
  19. '                           accedentally include them in the list of fields to '
  20. '                           save.                                              '
  21. ' Version11 - 31/Aug/2016 - Fixed error handling for the validation and save   '
  22. '                           functions. added the ability to use the label      '
  23. '                           captions from apropriately named label controls    '
  24. '                           instead of field names                             '
  25. ' Version12 - 31/Aug/2016 - missed some bugs introduced by the error handling  '
  26. '                           (looking at you exit sub in a function)            '
  27. ' Version13 - 07/Sep/2016 - Updated currentdb ref to dblocal function          '
  28. ' Version14 - 22/Sep/2016 - added a validation check for list boxes to see if  '
  29. '                           their item count is > 0                            '
  30. ' Version15 - 26/Sep/2016 - updated the item count check to see if it IS 0     '
  31. '                           not gt 0 -_-                                       '
  32. ' Version16 - 20/Oct/2016 - Added the f flag for information that is null if   '
  33. '                           the control is disabled. it can also be validated  '
  34. '                           to a data type using the n flag for example.       '
  35. '                           added enumeration for field types                  '
  36. ' Version17 - 08/Dec/2016 - added a function to strip off the prefix of the    '
  37. '                           control, or just pass it along if it didnt need to '
  38. '                           split the n flag to be n == float/double and       '
  39. '                           i == integer/long. changed the label printing on   '
  40. '                           the validate function to a 3 value piece of data   '
  41. '                           thats backwards compatable with booleans. it adds  '
  42. '                           support to use the default <fieldname>_Label.      '
  43. ' Version18 - 09/Dec/2016 - added the capability to check the validity of the  '
  44. '                           data even if it is not required.                   '
  45. ' Version19 - 05/Jan/2017 - added support for debug mode                       '
  46. ' Version20 - 24/Jan/2017 - added support for column heads on list boxes in    '
  47. '                           the validate function                              '
  48. ' Version21 - 24/Jan/2017 - fixed support for debug mode                       '
  49. ' Version22 - 24/Jan/2017 - fixed validate improperly flagging list boxes and  '
  50. '                           option/radio buttons when they were supposed to be '
  51. '                           set to ignore with flag x                          '
  52. ' Version23 - 06/Feb/2017 - Added function LoadQryIntoForm to autoload data    '
  53. '                           into a form quick and easy. added a modifier for   '
  54. '                           the f flag "g" so that if it has a non empty value '
  55. '                           it will save it since presumably it will have been '
  56. '                           validated before the control was disabled.         '
  57. ' Version24 - 27/Mar/2017 - Added function WipeForm to auto wipe forms using   '
  58. '                           tags default c                                     '
  59. ' Version25 - 25/May/2017 - updated function wipeform to skip tag e and not    '
  60. '                           allow it to be used as the custom tag.             '
  61. ' Version26 - 19/Jul/2017 - Fixed a bug in the LoadQryIntoForm function on the '
  62. '                           Where string where it reopened the qry instead of  '
  63. '                           the recordset with the filter applied.             '
  64. ' Version27 - 08/Aug/2017 - Updated save code to be able to use query defs     '
  65. ' Version28 - 17/Aug/2017 - Updated save code for the use case where you have  '
  66. '                           a radio button group that is not manditory but     '
  67. '                           needs label data. also to note on v27, you can not '
  68. '                           use a query that has aliased fields. Also added a  '
  69. '                           check to see if the recordset is updateable.       '
  70. ' Version29 - 31/Aug/2017 - Updated Validate so that it allows you to validate '
  71. '                           only fields with a specific custom tag, blank is   '
  72. '                           default behavior.                                  '
  73. ' Version30 - 17/Jan/2018 - Updated Validate so that it trims before           '
  74. '                           validating                                         '
  75. ' Version31 - 22/Jan/2018 - Updated SaveAll so that you can use a custom  tag  '
  76. '                           so you can use multiple saves per form             '
  77. ' Version32 - 22/Jan/2018 - Updated SaveAll so that you can use a paramaterized'
  78. '                           query (for faster updating)                        '
  79. ' Version33 - 27/Apr/2018 - Updated documentation for saveall and validate     '
  80. ' Version34 - 15/Aug/2018 - removed the message box stating the recordset is   '
  81. '                           empty from LoadQryIntoForm                         '
  82. ' Version35 - 17/Aug/2018 - using StandardErrorBox now                         '
  83. '                                                                              '
  84. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  85. '                                                                              '
  86. 'Instructions:                                                                 '
  87. '                                                                              '
  88. '1a) for textboxes, check boxes, list boxes with only one selection,           '
  89. '   and combo boxes set the name of the control like Type prefix & field name  '
  90. '   ex: "txt" & "Date_time" = "txtDate_time"                                   '
  91. '1b) for radio button groups set the group to the field name then the labels   '
  92. '   should be prefix fieldname radiobutton value                               '
  93. '   ex: "lbl" & "AssetTag" & 1 = "lblAssetTag1" then the caption would be the  '
  94. '   asset tag like "10-001"                                                    '
  95. '2) set the tag field under the "other" tab NOTE: you can have multiple letters'
  96. '  s - basic tag to indicate you want to save the value of the control         '
  97. '  x - non-manditory fields that you still wish to save overrides f            '
  98. '  r - specifically for radio buttons to parse the labels caption data         '
  99. '  o - radio buttons where you want the value of the radio button instead of   '
  100. '      text, also 0 is not a valid number to set the radio buttons to          '
  101. '  n - for float/double                                '
  102. '  d - indicates that the value must be a date                                 '
  103. '  e - Read Only do not attempt to write to. This is more for loading data then'
  104. '      saving data.                                                            '
  105. '  l - checks a listbox to see if it has any item data(Validation Only)        '
  106. '  f - not manditory if control is disabled (ignore value if disabled)         '
  107. '  g - modifier to f to check if it has a value and if it does save it         '
  108. '  c - For AutoClearing                                                        '
  109. '  i - For Integer                                                        '
  110. '                                                                              '
  111. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  112. ' Requirements:                                                                '
  113. ' -Basic include version 15 for the dbLocal function                           '
  114. '                                                                              '
  115. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  116. Public Enum mscFieldType
  117.     mscString = 0
  118.     mscNumber = 1
  119.     mscDate = 2
  120. End Enum
  121.  
  122. Public Enum mscLabelDesc
  123.     msclblstyle = -1
  124.     mscNone = 0
  125.     msc_labelStyle = 1
  126. End Enum
  127.  
  128. Public Enum mscSourceType
  129.     mscTableDef = 0
  130.     mscQueryDef = 1
  131.     mscParaQueryDef = 2
  132. End Enum
  133.  
  134. Public Sub SaveAll(argSaveTable As String, argForm As String, Optional argFieldName As Variant = "", Optional argValue As Variant = Null, Optional argFieldType As mscFieldType = mscString, Optional argQryOrTbl As mscSourceType = mscTableDef, Optional argCustomSaveTag As String = "s")
  135.     'Instructions for use
  136.    'If argQryOrTbl is mscTableDef then
  137.    '   if the argFieldName argument is blank, it adds a new record
  138.    '   else filter to the first record that has argFieldName as the value argValue.
  139.    '        you also have to set argFieldType to the correct data type so the filter can use the appropriate filter.
  140.    '        ie. string uses single quoters, numbers use nothing and dates use pound signs
  141.    'If argQryOrTbl is mscQueryDef then
  142.    '   this works essentially the same way as with mscTableDef
  143.    'If argQryOrTbl is mscParaQueryDef
  144.    '   then this can ONLY update the record returned by the value/array of values in the argValue parameter.
  145.    '   argFieldName,argFieldType are both unneeded.
  146.    '
  147.    'For all, if you need to save two different sets of data from the same form, you can change the argCustomSaveTag from "s"
  148.    '   to whatever is needed.(this is a very specific need, that generally isnt needed.)
  149.    '
  150.    'you have to name the controls the same as the fields but with the control type prefix.
  151.    '   this strips the control type prefix off using a predefined list of control prefixes
  152.    '   (or you can have no prefix at all, but that makes things needlessly complicated)
  153.    '
  154.    If Not BasicInclude.DebugMode Then On Error GoTo Error_Handler Else On Error GoTo 0
  155.     Dim rs As DAO.Recordset
  156.     Dim qry As QueryDef
  157.     Dim ctrl As Control
  158.     Dim u As Long
  159.     Dim i As Long
  160.     If Len(argCustomSaveTag) <> 1 Then
  161.         Err.Raise vbObjectError + 4, "SaveAll", "The Custom save tag argument is invalid."
  162.     End If
  163.     dbLocal.TableDefs.Refresh
  164.     If argQryOrTbl = mscTableDef Then
  165.         Set rs = dbLocal.TableDefs(argSaveTable).OpenRecordset(dbOpenDynaset, dbSeeChanges)
  166.     ElseIf argQryOrTbl = mscQueryDef Then
  167.         Set rs = dbLocal.QueryDefs(argSaveTable).OpenRecordset(dbOpenDynaset, dbSeeChanges)
  168.     ElseIf argQryOrTbl = mscParaQueryDef Then
  169.         Set qry = dbLocal.QueryDefs(argSaveTable)
  170.         If VarType(argValue) >= vbArray Then
  171.             u = UBound2(argValue)
  172.             If u = (qry.Parameters.count - 1) Then
  173.                 For i = 0 To u Step 1
  174.                     qry.Parameters(i).Value = argValue(i)
  175.                 Next i
  176.             Else
  177.                 Err.Raise vbObjectError + 6, "SaveAll", "Number of Parameters in query(" & qry.Parameters.count & ") do not match the number of parameters passed in(" & u + 1 & ")"
  178.             End If
  179.         Else
  180.             If Not (IsNull(argValue)) And qry.Parameters.count = 1 Then
  181.                 qry.Parameters(0) = argValue
  182.             ElseIf qry.Parameters.count = 0 And Not (IsNull(argValue)) Then
  183.                 Err.Raise vbObjectError + 5, "SaveAll", "Number of Parameters in query(" & qry.Parameters.count & ") do not match the number of parameters passed in(1)"
  184.             ElseIf qry.Parameters.count = 0 And (IsNull(argValue)) Then
  185.             End If
  186.         End If
  187.         Set rs = qry.OpenRecordset(dbOpenDynaset, dbSeeChanges)
  188.         If rs.RecordCount > 0 Then
  189.             If rs.Updatable Then
  190.                 rs.MoveFirst
  191.                 rs.Edit
  192.                 For Each ctrl In Forms(argForm).Controls
  193.                     If ctrl.Tag Like "*" & argCustomSaveTag & "*" Then
  194.                         'Debug.Print ctrl.Name
  195.                        If Not ((rs.Fields(StripPrefix(ctrl.Name)).Attributes And dbAutoIncrField) = 16) Then
  196.                             'should detect if a field is autonumber and skip it.
  197.                            's for save
  198.                            'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  199.                            If ctrl.Tag Like "*x*" Then
  200.                                 'x for exclude from check
  201.                                If ctrl.Value & "" = "" Then
  202.                                     rs.Fields(StripPrefix(ctrl.Name)).Value = Null
  203.                                 Else
  204.                                     rs.Fields(StripPrefix(ctrl.Name)).Value = ctrl.Value
  205.                                 End If
  206.                            
  207.                             ElseIf ctrl.Tag Like "*f*" Then
  208.                                 If ctrl.Enabled Then
  209.                                     rs.Fields(StripPrefix(ctrl.Name)).Value = ctrl.Value
  210.                                 Else
  211.                                     If ctrl.Tag Like "*g*" Then
  212.                                         If ctrl.Value & "" = "" Then
  213.                                             rs.Fields(StripPrefix(ctrl.Name)).Value = Null
  214.                                         Else
  215.                                             rs.Fields(StripPrefix(ctrl.Name)).Value = ctrl.Value
  216.                                         End If
  217.                                     Else
  218.                                         rs.Fields(StripPrefix(ctrl.Name)).Value = Null
  219.                                     End If
  220.                                 End If
  221.                             ElseIf ctrl.Tag Like "*r*" Then
  222.                                 'r to extract the value intended from the label of the radio button assuming you named the label the same name
  223.                                'with a different prefix and the value of the radio button as a postifx
  224.                                rs.Fields(StripPrefix(ctrl.Name)).Value = Forms(argForm).Controls("lbl" & StripPrefix(ctrl.Name) & ctrl.Value).Caption
  225.                             Else
  226.                                 rs.Fields(StripPrefix(ctrl.Name)).Value = ctrl.Value
  227.                             End If
  228.                         Else
  229.                             Debug.Print "skipped " & ctrl.Name & " for being an Autonumber field"
  230.                         End If
  231.                     End If
  232.                 Next
  233.                 rs.Update
  234.             Else
  235.                 Err.Raise vbObjectError + 2, "SaveAll", "The Recordset you are trying to update can not be updated."
  236.             End If
  237.         Else
  238.             Err.Raise vbObjectError + 1, "SaveAll", "The Record you are trying to update does not exist"
  239.         End If
  240.         GoTo Error_Exit
  241.     End If
  242.     If argFieldName = "" Then
  243.         'Since you can not pass in a null under the string data type, the argument argFieldName will never be null, but can be an empty string
  244.        If rs.Updatable Then
  245.             rs.AddNew
  246.             For Each ctrl In Forms(argForm).Controls
  247.                 If ctrl.Tag Like "*" & argCustomSaveTag & "*" Then
  248.                     's for save
  249.                    'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  250.                    If ctrl.Tag Like "*x*" Then
  251.                         'x for exclude from check
  252.                        If ctrl.Value & "" = "" Then
  253.                             rs.Fields(StripPrefix(ctrl.Name)).Value = Null
  254.                         Else
  255.                             If ctrl.Tag Like "*r*" And ctrl.Value <> 0 Then
  256.                                 'use case where you have a radio button group that you need label caption data from
  257.                                'that is not manditory.
  258.                                rs.Fields(StripPrefix(ctrl.Name)).Value = Forms(argForm).Controls("lbl" & StripPrefix(ctrl.Name) & ctrl.Value).Caption
  259.                             Else
  260.                                 rs.Fields(StripPrefix(ctrl.Name)).Value = ctrl.Value
  261.                             End If
  262.                         End If
  263.                     ElseIf ctrl.Tag Like "*f*" Then
  264.                         If ctrl.Enabled Then
  265.                             rs.Fields(StripPrefix(ctrl.Name)).Value = ctrl.Value
  266.                         Else
  267.                             If ctrl.Tag Like "*g*" Then
  268.                                 If ctrl.Value & "" = "" Then
  269.                                     rs.Fields(StripPrefix(ctrl.Name)).Value = Null
  270.                                 Else
  271.                                     rs.Fields(StripPrefix(ctrl.Name)).Value = ctrl.Value
  272.                                 End If
  273.                             Else
  274.                                 rs.Fields(StripPrefix(ctrl.Name)).Value = Null
  275.                             End If
  276.                         End If
  277.                     ElseIf ctrl.Tag Like "*r*" Then
  278.                         'r to extract the value intended from the label of the radio button assuming you named the label the same name
  279.                        'with a different prefix and the value of the radio button as a postifx
  280.                        'if you want to store the value of radio button instead of the label, just make sure you set a default and leave the r tag off.
  281.                        rs.Fields(StripPrefix(ctrl.Name)).Value = Forms(argForm).Controls("lbl" & StripPrefix(ctrl.Name) & ctrl.Value).Caption
  282.                     Else
  283.                         rs.Fields(StripPrefix(ctrl.Name)).Value = ctrl.Value
  284.                     End If
  285.                 End If
  286.             Next
  287.             rs.Update
  288.         Else
  289.             Err.Raise vbObjectError + 3, "SaveAll", "The Recordset you are trying to add a record to can not be updated."
  290.         End If
  291.     Else
  292.         If Not IsNull(argValue) Then
  293.             If argFieldType = mscString Then
  294.                 rs.filter = argFieldName & " = '" & argValue & "'"
  295.             ElseIf argFieldType = mscNumber Then
  296.                 rs.filter = argFieldName & " = " & argValue
  297.             ElseIf argFieldType = mscDate Then
  298.                 rs.filter = argFieldName & " = #" & argValue & "#"
  299.             Else
  300.                 rs.filter = "1=2"
  301.             End If
  302.         Else
  303.             rs.filter = "1=2"
  304.         End If
  305.         Set rs = rs.OpenRecordset(dbOpenDynaset, dbSeeChanges)
  306.         If rs.RecordCount > 0 Then
  307.             If rs.Updatable Then
  308.                 rs.MoveFirst
  309.                 rs.Edit
  310.                 For Each ctrl In Forms(argForm).Controls
  311.                     If ctrl.Tag Like "*" & argCustomSaveTag & "*" Then
  312.                         'Debug.Print ctrl.Name
  313.                        If Not ((rs.Fields(StripPrefix(ctrl.Name)).Attributes And dbAutoIncrField) = 16) Then
  314.                             'should detect if a field is autonumber and skip it.
  315.                            's for save
  316.                            'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  317.                            If ctrl.Tag Like "*x*" Then
  318.                                 'x for exclude from check
  319.                                If ctrl.Value & "" = "" Then
  320.                                     rs.Fields(StripPrefix(ctrl.Name)).Value = Null
  321.                                 Else
  322.                                     rs.Fields(StripPrefix(ctrl.Name)).Value = ctrl.Value
  323.                                 End If
  324.                            
  325.                             ElseIf ctrl.Tag Like "*f*" Then
  326.                                 If ctrl.Enabled Then
  327.                                     rs.Fields(StripPrefix(ctrl.Name)).Value = ctrl.Value
  328.                                 Else
  329.                                     If ctrl.Tag Like "*g*" Then
  330.                                         If ctrl.Value & "" = "" Then
  331.                                             rs.Fields(StripPrefix(ctrl.Name)).Value = Null
  332.                                         Else
  333.                                             rs.Fields(StripPrefix(ctrl.Name)).Value = ctrl.Value
  334.                                         End If
  335.                                     Else
  336.                                         rs.Fields(StripPrefix(ctrl.Name)).Value = Null
  337.                                     End If
  338.                                 End If
  339.                             ElseIf ctrl.Tag Like "*r*" Then
  340.                                 'r to extract the value intended from the label of the radio button assuming you named the label the same name
  341.                                'with a different prefix and the value of the radio button as a postifx
  342.                                rs.Fields(StripPrefix(ctrl.Name)).Value = Forms(argForm).Controls("lbl" & StripPrefix(ctrl.Name) & ctrl.Value).Caption
  343.                             Else
  344.                                 rs.Fields(StripPrefix(ctrl.Name)).Value = ctrl.Value
  345.                             End If
  346.                         Else
  347.                             Debug.Print "skipped " & ctrl.Name & " for being an Autonumber field"
  348.                         End If
  349.                     End If
  350.                 Next
  351.                 rs.Update
  352.             Else
  353.                 Err.Raise vbObjectError + 2, "SaveAll", "The Recordset you are trying to update can not be updated."
  354.             End If
  355.         Else
  356.             Err.Raise vbObjectError + 1, "SaveAll", "The Record you are trying to update does not exist"
  357.         End If
  358.     End If
  359.  
  360. Error_Exit:
  361.     Set rs = Nothing
  362.     Exit Sub
  363. Error_Handler:
  364.     StandardErrorBox "Save", Err, Errors
  365.     'MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
  366.            "Error Number: " & Err.Number & vbCrLf & _
  367.            "Error Source: Save" & vbCrLf & _
  368.            "Error Description: " & Err.Description _
  369.            , vbOKOnly + vbCritical, "An Error has Occured!"
  370.    Resume Error_Exit
  371.    
  372. End Sub
  373.  
  374. Public Function Validate(argForm As String, Optional argLabelDesc As mscLabelDesc = mscNone, Optional argCustomTag As String = "") As String
  375.     'if this ouputs an empty string, everything properly validated.
  376.    'if argCustomTag is set then it will only validate controls that have that custom tag.
  377.    'if you wish to use the argLabelDesc option msclblstyle the toolbox has a function
  378.    '   that can rename all bound (to a specific control) labels to the parent controls name.
  379.    '   this function is called: renameLabel
  380.    If Not BasicInclude.DebugMode Then On Error GoTo Error_Handler Else On Error GoTo 0
  381.     Dim ctrl As Control
  382.     Dim out As String: out = vbCrLf
  383.     Dim sourceForm As Form: Set sourceForm = Forms(argForm)
  384.     If Len(argCustomTag) > 1 Then
  385.         Err.Raise vbObjectError + 1, "Validate", "Custom tag can only be one character long"
  386.     End If
  387.     If argCustomTag = "" Then
  388.         For Each ctrl In sourceForm.Controls
  389.             If ctrl.Tag & "" <> "" Then
  390.                 'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  391.                If ctrl.Tag Like "*f*" And ctrl.Enabled Then
  392.                     If ctrl.Tag Like "*n*" Then
  393.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  394.                        If ctrl.Tag Like "*x*" And Trim(ctrl.Value & "") = "" Then
  395.                         ElseIf Not IsNumeric(ctrl.Value) Then
  396.                             If argLabelDesc = msclblstyle Then
  397.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  398.                             ElseIf argLabelDesc = msc_labelStyle Then
  399.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  400.                             Else
  401.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  402.                             End If
  403.                         End If
  404.                     ElseIf ctrl.Tag Like "*i*" Then
  405.                         If ctrl.Tag Like "*x*" And Trim(ctrl.Value & "") = "" Then
  406.                         ElseIf Not IsNumeric(ctrl.Value) Or CStr(ctrl.Value & "") Like "*.*" Then
  407.                             If argLabelDesc = msclblstyle Then
  408.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  409.                             ElseIf argLabelDesc = msc_labelStyle Then
  410.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  411.                             Else
  412.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  413.                             End If
  414.                         End If
  415.                     ElseIf ctrl.Tag Like "*d*" Then
  416.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  417.                        If ctrl.Tag Like "*x*" And Trim(ctrl.Value & "") = "" Then
  418.                         ElseIf Not IsDate(ctrl.Value) Then
  419.                             If argLabelDesc = msclblstyle Then
  420.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  421.                             ElseIf argLabelDesc = msc_labelStyle Then
  422.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  423.                             Else
  424.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  425.                             End If
  426.                         End If
  427.                     ElseIf ctrl.Tag Like "*l*" Then
  428.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  429.                        If ctrl.Tag Like "*x*" Then
  430.                         ElseIf ctrl.ListCount = 0 Then
  431.                             If argLabelDesc = msclblstyle Then
  432.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  433.                             ElseIf argLabelDesc = msc_labelStyle Then
  434.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  435.                             Else
  436.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  437.                             End If
  438.                         ElseIf ctrl.ColumnHeads And ctrl.ListCount = 1 Then
  439.                             If argLabelDesc = msclblstyle Then
  440.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  441.                             ElseIf argLabelDesc = msc_labelStyle Then
  442.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  443.                             Else
  444.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  445.                             End If
  446.                         End If
  447.                     ElseIf ctrl.Tag Like "*r*" Or ctrl.Tag Like "*o*" Then
  448.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  449.                        If ctrl.Tag Like "*x*" Then
  450.                         ElseIf ctrl.Value = 0 Then
  451.                             ' if you want your radio button group to be not selected when you use this and catch the error, then set the default to 0 and start the valid value set at 1
  452.                            'considering changing this to check for -1 so a valid value set can be from 0 up.
  453.                            If argLabelDesc = msclblstyle Then
  454.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  455.                             ElseIf argLabelDesc = msc_labelStyle Then
  456.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  457.                             Else
  458.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  459.                             End If
  460.                         End If
  461.                     ElseIf ctrl.Tag Like "*s*" Then
  462.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  463.                        If ctrl.Tag Like "*x*" And Trim(ctrl.Value & "") = "" Then
  464.                         ElseIf Trim(ctrl.Value & "") = "" Then
  465.                             If argLabelDesc = msclblstyle Then
  466.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  467.                             ElseIf argLabelDesc = msc_labelStyle Then
  468.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  469.                             Else
  470.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  471.                             End If
  472.                         End If
  473.                     End If
  474.                 ElseIf Not ctrl.Tag Like "*f*" Then
  475.                     If ctrl.Tag Like "*n*" Then
  476.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  477.                        If ctrl.Tag Like "*x*" And Trim(ctrl.Value & "") = "" Then
  478.                         ElseIf Not IsNumeric(ctrl.Value) Then
  479.                             If argLabelDesc = msclblstyle Then
  480.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  481.                             ElseIf argLabelDesc = msc_labelStyle Then
  482.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  483.                             Else
  484.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  485.                             End If
  486.                         End If
  487.                     ElseIf ctrl.Tag Like "*i*" Then
  488.                         If ctrl.Tag Like "*x*" And Trim(ctrl.Value & "") = "" Then
  489.                         ElseIf Not IsNumeric(ctrl.Value) Or CStr(ctrl.Value & "") & "" Like "*.*" Then
  490.                             If argLabelDesc = msclblstyle Then
  491.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  492.                             ElseIf argLabelDesc = msc_labelStyle Then
  493.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  494.                             Else
  495.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  496.                             End If
  497.                         End If
  498.                     ElseIf ctrl.Tag Like "*d*" Then
  499.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  500.                        If ctrl.Tag Like "*x*" And Trim(ctrl.Value & "") = "" Then
  501.                         ElseIf Not IsDate(ctrl.Value) Then
  502.                             If argLabelDesc = msclblstyle Then
  503.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  504.                             ElseIf argLabelDesc = msc_labelStyle Then
  505.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  506.                             Else
  507.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  508.                             End If
  509.                         End If
  510.                     ElseIf ctrl.Tag Like "*l*" Then
  511.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  512.                        If ctrl.Tag Like "*x*" Then
  513.                         ElseIf ctrl.ListCount = 0 Then
  514.                             If argLabelDesc = msclblstyle Then
  515.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  516.                             ElseIf argLabelDesc = msc_labelStyle Then
  517.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  518.                             Else
  519.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  520.                             End If
  521.                         ElseIf ctrl.ColumnHeads And ctrl.ListCount = 1 Then
  522.                             If argLabelDesc = msclblstyle Then
  523.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  524.                             ElseIf argLabelDesc = msc_labelStyle Then
  525.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  526.                             Else
  527.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  528.                             End If
  529.                         End If
  530.                     ElseIf ctrl.Tag Like "*r*" Or ctrl.Tag Like "*o*" Then
  531.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  532.                        If ctrl.Tag Like "*x*" Then
  533.                         ElseIf ctrl.Value = 0 Then
  534.                             ' if you want your radio button group to be not selected when you use this and catch the error, then set the default to 0 and start the valid value set at 1
  535.                            'considering changing this to check for -1 so a valid value set can be from 0 up.
  536.                            If argLabelDesc = msclblstyle Then
  537.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  538.                             ElseIf argLabelDesc = msc_labelStyle Then
  539.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  540.                             Else
  541.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  542.                             End If
  543.                         End If
  544.                     ElseIf ctrl.Tag Like "*s*" Then
  545.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  546.                        If ctrl.Tag Like "*x*" And Trim(ctrl.Value & "") = "" Then
  547.                         ElseIf Trim(ctrl.Value & "") = "" Then
  548.                             If argLabelDesc = msclblstyle Then
  549.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  550.                             ElseIf argLabelDesc = msc_labelStyle Then
  551.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  552.                             Else
  553.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  554.                             End If
  555.                         End If
  556.                     End If
  557.                 End If
  558.             End If
  559.         Next
  560.     Else
  561.         For Each ctrl In sourceForm.Controls
  562.             If ctrl.Tag & "" Like "*" & argCustomTag & "*" Then
  563.                 'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  564.                If ctrl.Tag Like "*f*" And ctrl.Enabled Then
  565.                     If ctrl.Tag Like "*n*" Then
  566.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  567.                        If ctrl.Tag Like "*x*" And Trim(ctrl.Value & "") = "" Then
  568.                         ElseIf Not IsNumeric(ctrl.Value) Then
  569.                             If argLabelDesc = msclblstyle Then
  570.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  571.                             ElseIf argLabelDesc = msc_labelStyle Then
  572.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  573.                             Else
  574.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  575.                             End If
  576.                         End If
  577.                     ElseIf ctrl.Tag Like "*i*" Then
  578.                         If ctrl.Tag Like "*x*" And Trim(ctrl.Value & "") = "" Then
  579.                         ElseIf Not IsNumeric(ctrl.Value) Or CStr(ctrl.Value & "") Like "*.*" Then
  580.                             If argLabelDesc = msclblstyle Then
  581.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  582.                             ElseIf argLabelDesc = msc_labelStyle Then
  583.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  584.                             Else
  585.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  586.                             End If
  587.                         End If
  588.                     ElseIf ctrl.Tag Like "*d*" Then
  589.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  590.                        If ctrl.Tag Like "*x*" And Trim(ctrl.Value & "") = "" Then
  591.                         ElseIf Not IsDate(ctrl.Value) Then
  592.                             If argLabelDesc = msclblstyle Then
  593.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  594.                             ElseIf argLabelDesc = msc_labelStyle Then
  595.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  596.                             Else
  597.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  598.                             End If
  599.                         End If
  600.                     ElseIf ctrl.Tag Like "*l*" Then
  601.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  602.                        If ctrl.Tag Like "*x*" Then
  603.                         ElseIf ctrl.ListCount = 0 Then
  604.                             If argLabelDesc = msclblstyle Then
  605.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  606.                             ElseIf argLabelDesc = msc_labelStyle Then
  607.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  608.                             Else
  609.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  610.                             End If
  611.                         ElseIf ctrl.ColumnHeads And ctrl.ListCount = 1 Then
  612.                             If argLabelDesc = msclblstyle Then
  613.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  614.                             ElseIf argLabelDesc = msc_labelStyle Then
  615.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  616.                             Else
  617.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  618.                             End If
  619.                         End If
  620.                     ElseIf ctrl.Tag Like "*r*" Or ctrl.Tag Like "*o*" Then
  621.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  622.                        If ctrl.Tag Like "*x*" Then
  623.                         ElseIf ctrl.Value = 0 Then
  624.                             ' if you want your radio button group to be not selected when you use this and catch the error, then set the default to 0 and start the valid value set at 1
  625.                            'considering changing this to check for -1 so a valid value set can be from 0 up.
  626.                            If argLabelDesc = msclblstyle Then
  627.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  628.                             ElseIf argLabelDesc = msc_labelStyle Then
  629.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  630.                             Else
  631.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  632.                             End If
  633.                         End If
  634.                     ElseIf ctrl.Tag Like "*" & argCustomTag & "*" Then
  635.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  636.                        If ctrl.Tag Like "*x*" And Trim(ctrl.Value & "") = "" Then
  637.                         ElseIf Trim(ctrl.Value & "") = "" Then
  638.                             If argLabelDesc = msclblstyle Then
  639.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  640.                             ElseIf argLabelDesc = msc_labelStyle Then
  641.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  642.                             Else
  643.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  644.                             End If
  645.                         End If
  646.                     End If
  647.                 ElseIf Not ctrl.Tag Like "*f*" Then
  648.                     If ctrl.Tag Like "*n*" Then
  649.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  650.                        If ctrl.Tag Like "*x*" And Trim(ctrl.Value & "") = "" Then
  651.                         ElseIf Not IsNumeric(ctrl.Value) Then
  652.                             If argLabelDesc = msclblstyle Then
  653.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  654.                             ElseIf argLabelDesc = msc_labelStyle Then
  655.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  656.                             Else
  657.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  658.                             End If
  659.                         End If
  660.                     ElseIf ctrl.Tag Like "*i*" Then
  661.                         If ctrl.Tag Like "*x*" And Trim(ctrl.Value & "") = "" Then
  662.                         ElseIf Not IsNumeric(ctrl.Value) Or CStr(ctrl.Value & "") & "" Like "*.*" Then
  663.                             If argLabelDesc = msclblstyle Then
  664.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  665.                             ElseIf argLabelDesc = msc_labelStyle Then
  666.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  667.                             Else
  668.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  669.                             End If
  670.                         End If
  671.                     ElseIf ctrl.Tag Like "*d*" Then
  672.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  673.                        If ctrl.Tag Like "*x*" And Trim(ctrl.Value & "") = "" Then
  674.                         ElseIf Not IsDate(ctrl.Value) Then
  675.                             If argLabelDesc = msclblstyle Then
  676.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  677.                             ElseIf argLabelDesc = msc_labelStyle Then
  678.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  679.                             Else
  680.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  681.                             End If
  682.                         End If
  683.                     ElseIf ctrl.Tag Like "*l*" Then
  684.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  685.                        If ctrl.Tag Like "*x*" Then
  686.                         ElseIf ctrl.ListCount = 0 Then
  687.                             If argLabelDesc = msclblstyle Then
  688.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  689.                             ElseIf argLabelDesc = msc_labelStyle Then
  690.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  691.                             Else
  692.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  693.                             End If
  694.                         ElseIf ctrl.ColumnHeads And ctrl.ListCount = 1 Then
  695.                             If argLabelDesc = msclblstyle Then
  696.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  697.                             ElseIf argLabelDesc = msc_labelStyle Then
  698.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  699.                             Else
  700.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  701.                             End If
  702.                         End If
  703.                     ElseIf ctrl.Tag Like "*r*" Or ctrl.Tag Like "*o*" Then
  704.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  705.                        If ctrl.Tag Like "*x*" Then
  706.                         ElseIf ctrl.Value = 0 Then
  707.                             ' if you want your radio button group to be not selected when you use this and catch the error, then set the default to 0 and start the valid value set at 1
  708.                            'considering changing this to check for -1 so a valid value set can be from 0 up.
  709.                            If argLabelDesc = msclblstyle Then
  710.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  711.                             ElseIf argLabelDesc = msc_labelStyle Then
  712.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  713.                             Else
  714.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  715.                             End If
  716.                         End If
  717.                     ElseIf ctrl.Tag Like "*" & argCustomTag & "*" Then
  718.                         'Debug.Print "Name: " & ctrl.Name & " Fieldame: " & StripPrefix(ctrl.Name) & " Value: " & ctrl.Value
  719.                        If ctrl.Tag Like "*x*" And Trim(ctrl.Value & "") = "" Then
  720.                         ElseIf Trim(ctrl.Value & "") = "" Then
  721.                             If argLabelDesc = msclblstyle Then
  722.                                 out = out & sourceForm.Controls("lbl" & StripPrefix(ctrl.Name)).Caption & vbCrLf
  723.                             ElseIf argLabelDesc = msc_labelStyle Then
  724.                                 out = out & sourceForm.Controls(StripPrefix(ctrl.Name) & "_Label").Caption & vbCrLf
  725.                             Else
  726.                                 out = out & StripPrefix(ctrl.Name) & vbCrLf
  727.                             End If
  728.                         End If
  729.                     End If
  730.                 End If
  731.             End If
  732.         Next
  733.     End If
  734.     out = Left(out, Len(out) - 2)
  735. Error_Exit:
  736.     Validate = out
  737.     Exit Function
  738. Error_Handler:
  739.     'MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
  740.     "Error Number: " & err.Number & vbCrLf & _
  741.     "Error Source: Save" & vbCrLf & _
  742.     "Error Description: " & err.Description _
  743.     , vbOKOnly + vbCritical, "An Error has Occured!"
  744.    
  745.     out = "The following error has occured" & vbCrLf & vbCrLf & _
  746.           "Error Number: " & Err.Number & vbCrLf & _
  747.           "Error Source: Validate" & vbCrLf & _
  748.           "Error Description: " & Err.Description
  749.     Resume Error_Exit
  750.    
  751. End Function
  752.  
  753. Public Function StripPrefix(argIn As String) As String
  754.     Dim PrefixList() As String: PrefixList = Split("txt,cmb,cbo,chk,lst,rad,opt", ",")
  755.     Dim v As Variant
  756.     For Each v In PrefixList
  757.         If argIn Like v & "*" Then
  758.             StripPrefix = Right(argIn, Len(argIn) - Len(v))
  759.             Exit Function
  760.         End If
  761.     Next
  762.     StripPrefix = argIn
  763. End Function
  764.  
  765. Public Function LoadQryIntoForm(argQry As String, argForm As String, Optional argParameters As Variant = Null, Optional argExcludeEmptyTags As Boolean = True, Optional argIsFilterString As Boolean = True) As Long
  766.     If Not BasicInclude.DebugMode Then On Error GoTo Error_Handler Else On Error GoTo 0
  767.     Dim qry As QueryDef
  768.     Dim rs As DAO.Recordset
  769.     Dim frm As Form
  770.     Dim f As Field
  771.     Dim u As Long
  772.     Dim c As Control
  773.     Dim i As Long
  774.     LoadQryIntoForm = 0
  775.     Set qry = dbLocal.QueryDefs(argQry)
  776.     If argIsFilterString Then
  777.         Set rs = qry.OpenRecordset(dbOpenDynaset, dbSeeChanges)
  778.         rs.filter = argParameters
  779.         Set rs = rs.OpenRecordset(dbOpenSnapshot)
  780.     Else
  781.         If VarType(argParameters) >= vbArray Then
  782.             u = UBound(argParameters)
  783.             If u = (qry.Parameters.count - 1) Then
  784.                 For i = 0 To u Step 1
  785.                     qry.Parameters(i).Value = argParameters(i)
  786.                 Next i
  787.             Else
  788.                 Err.Raise vbObjectError, "LoadQryIntoForm", "Number of Parameters in query(" & qry.Parameters.count & ") do not match the number of parameters passed in(" & u + 1 & ")"
  789.             End If
  790.         Else
  791.             If Not (IsNull(argParameters)) And qry.Parameters.count = 1 Then
  792.                 qry.Parameters(0) = argParameters
  793.             ElseIf qry.Parameters.count = 0 And Not (IsNull(argParameters)) Then
  794.                 Err.Raise vbObjectError + 1, "LoadQryIntoForm", "Number of Parameters in query(" & qry.Parameters.count & ") do not match the number of parameters passed in(1)"
  795.             ElseIf qry.Parameters.count = 0 And (IsNull(argParameters)) Then
  796.             End If
  797.         End If
  798.         Set rs = qry.OpenRecordset(dbOpenDynaset, dbSeeChanges)
  799.     End If
  800.  
  801.     Set frm = Forms(argForm)
  802.     'If argFilter <> "" Then
  803.    'rs.filter = argFilter
  804.    'Set rs = rs.OpenRecordset(dbOpenDynaset, dbSeeChanges)
  805.    'End If
  806.    If rs.RecordCount Then
  807.         rs.MoveFirst
  808.         If argExcludeEmptyTags Then
  809.             For Each f In rs.Fields
  810.                 For Each c In frm.Controls
  811.                     If f.Name = StripPrefix(c.Name) And Not (c.Tag Like "*[el]*") And c.Tag & "" <> "" Then
  812.                         c.Value = f.Value
  813.                     End If
  814.                 Next
  815.             Next
  816.         Else
  817.             For Each f In rs.Fields
  818.                 For Each c In frm.Controls
  819.                     If f.Name = StripPrefix(c.Name) And Not (c.Tag Like "*[el]*") Then
  820.                         c.Value = f.Value
  821.                     End If
  822.                 Next
  823.             Next
  824.         End If
  825.     Else
  826.         'MsgBox "Error, The recordset is empty"
  827.        LoadQryIntoForm = 1
  828.     End If
  829. Error_Exit:
  830.     Set rs = Nothing
  831.     Set qry = Nothing
  832.     Set frm = Nothing
  833.     Exit Function
  834. Error_Handler:
  835.     StandardErrorBox "LoadQryIntoForm", Err
  836.     'MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
  837.            "Error Number: " & Err.Number & vbCrLf & _
  838.            "Error Source: LoadQryIntoForm" & vbCrLf & _
  839.            "Error Description: " & Err.Description _
  840.            , vbOKOnly + vbCritical, "An Error has Occured!"
  841.    LoadQryIntoForm = -1
  842.     Resume Error_Exit
  843. End Function
  844.  
  845. Public Sub WipeForm(argForm As String, Optional argCustomTag As String = "c")
  846.     Dim f As Form
  847.     Dim c As Control
  848.     If Not BasicInclude.DebugMode Then On Error GoTo Error_Handler Else On Error GoTo 0
  849.     If Len(Trim(argCustomTag)) = 1 And argCustomTag <> "e" Then
  850.         Set f = Forms(argForm)
  851.         For Each c In f.Controls
  852.             If c.Tag Like "*" & argCustomTag & "*" And Not (c.Tag Like "*e*") Then
  853.                 Select Case c.ControlType
  854.                 Case acCheckBox
  855.                     c.Value = False
  856.                 Case acOptionGroup
  857.                     c.Value = 0
  858.                 Case Else
  859.                     c.Value = ""
  860.                 End Select
  861.             End If
  862.         Next
  863.     End If
  864. Error_Exit:
  865.     Set f = Nothing
  866.     Exit Sub
  867. Error_Handler:
  868. StandardErrorBox "WipeForm", Err
  869.     'MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
  870.            "Error Number: " & Err.Number & vbCrLf & _
  871.            "Error Source: WipeForm" & vbCrLf & _
  872.            "Error Description: " & Err.Description _
  873.            , vbOKOnly + vbCritical, "An Error has Occured!"
  874.    Resume Error_Exit
  875. End Sub
  876.  
  877. Public Sub AppendToTag(argForm As String, argTag As String, Optional argConditionTag As String = "")
  878.     Dim f As Form
  879.     Dim c As Control
  880.     If Not BasicInclude.DebugMode Then On Error GoTo Error_Handler Else On Error GoTo 0
  881.     Set f = Forms(argForm)
  882.     If argConditionTag <> "" Then
  883.         For Each c In f.Controls
  884.             If c.Tag Like "*" & argConditionTag & "*" Then
  885.                 If Not c.Tag Like "*" & argTag & "*" Then
  886.                     c.Tag = c.Tag & argTag
  887.                 End If
  888.             End If
  889.         Next
  890.     Else
  891.         For Each c In f.Controls
  892.             If c.ControlType = acTextBox Or c.ControlType = acTextBox Or c.ControlType = acCheckBox Or c.ControlType = acComboBox Or c.ControlType = acListBox Or c.ControlType = acOptionGroup Then
  893.                 If Not c.Tag Like "*" & argTag & "*" Then
  894.                     c.Tag = c.Tag & argTag
  895.                 End If
  896.             End If
  897.         Next
  898.     End If
  899. Error_Exit:
  900.     Set f = Nothing
  901.     Exit Sub
  902. Error_Handler:
  903.     StandardErrorBox "AppendToTag", Err
  904.     'MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
  905.            "Error Number: " & Err.Number & vbCrLf & _
  906.            "Error Source: AppendToTag" & vbCrLf & _
  907.            "Error Description: " & Err.Description _
  908.            , vbOKOnly + vbCritical, "An Error has Occured!"
  909.    Resume Error_Exit
  910. End Sub
  911.  
  912.  
  913. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  914. Supporting functions not in this module
  915. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  916. Public Sub StandardErrorBox(ByVal argSource As String, ByRef e As ErrObject, Optional ByRef daoE As DAO.Errors = Nothing, Optional ByVal argExtra As String = "")
  917.     Dim msg As String
  918.     Dim u As Long
  919.     Dim er As DAO.Error
  920.     msg = "The following error(s) has/have occured" & vbCrLf & vbCrLf & "Error Number: " & e.Number & vbCrLf & _
  921.           "Error Source: " & e.Source & vbCrLf & _
  922.           "Error Description: " & e.Description
  923.    
  924.     If Not daoE Is Nothing Then
  925.         If e.Source Like "*[oO][dD][bB][cC]*" Then
  926.             msg = msg & vbCrLf & vbCrLf & "DAO errors" & vbCrLf
  927.             For Each er In daoE
  928.                 msg = msg & vbCrLf & "Error Number: " & er.Number & vbCrLf & _
  929.                       "Error Source: " & er.Source & vbCrLf & _
  930.                       "Error Description: " & er.Description
  931.             Next
  932.         End If
  933.     End If
  934.    
  935.     If argExtra <> "" Then
  936.         msg = msg & vbCrLf & vbCrLf & "Additional Information: " & argExtra
  937.     End If
  938.     msg = msg & vbCrLf & vbCrLf & "Function: " & argSource
  939.     MsgBox msg, vbOKOnly + vbCritical, "An Error has Occured!"
  940. End Sub
  941.  
  942. Public Function dbLocal(Optional bolCleanup As Boolean = False) As DAO.Database
  943.     ' This function started life based on a suggestion from
  944.    '   Michael Kaplan in comp.databases.ms-access back in the early 2000s
  945.    ' 2003/02/08 DWF added comments to explain it to myself!
  946.    ' 2005/03/18 DWF changed to use Static variable instead
  947.    ' uses GoTos instead of If/Then because:
  948.    '  error of dbCurrent not being Nothing but dbCurrent being closed (3420)
  949.    '  would then be jumping back into the middle of an If/Then statement
  950.    On Error GoTo errHandler
  951.     Static dbCurrent As DAO.Database
  952.     Dim strTest As String
  953.  
  954.     If bolCleanup Then GoTo closeDB
  955.  
  956. retryDB:
  957.     If dbCurrent Is Nothing Then
  958.         Set dbCurrent = CurrentDb()
  959.     End If
  960.     ' now that we know the db variable is not Nothing, test if it's Open
  961.    strTest = dbCurrent.Name
  962.     dbCurrent.QueryDefs.Refresh
  963. exitRoutine:
  964.     Set dbLocal = dbCurrent
  965.     Exit Function
  966.  
  967. closeDB:
  968.     If Not (dbCurrent Is Nothing) Then
  969.         'dbCurrent.close ' this never has any effect
  970.        Set dbCurrent = Nothing
  971.     End If
  972.     GoTo exitRoutine
  973.  
  974. errHandler:
  975.     Select Case Err.Number
  976.     Case 3420                                    ' Object invalid or no longer set.
  977.        Set dbCurrent = Nothing
  978.         If Not bolCleanup Then
  979.             Resume retryDB
  980.         Else
  981.             Resume closeDB
  982.         End If
  983.     Case Else
  984.         StandardErrorBox "dbLocal", Err
  985.         'MsgBox Err.Number & ": " & Err.Description, vbExclamation, "Error in dbLocal()"
  986.        Resume exitRoutine
  987.     End Select
  988. End Function
Advertisement
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!