1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
|
Function AddAllToList(C As Control, ID As Long, Row As Long, Col As Long, Code As Integer) As Variant
'***************************************************************
' FUNCTION: AddAllToList()
'
' PURPOSE:
' Adds "(all)" as the first row of a combo box or list box.
'
' USAGE:
' 1. Create a combo box or list box that displays the data you
' want.
'
' 2. Change the RowSourceType property from "Table/Query" to
' "AddAllToList."
'
' 3. Set the value of the combo box or list box's Tag property to
' the column number in which you want "(all)" to appear.
'
' NOTE: Following the column number in the Tag property, you can
' enter a semicolon (;) and then any text you want to appear
' other than the default "all."
'
' For example
'
' Tag: 2;
'
' displays "" in the second column of the list.
'
'***************************************************************
Static DB As Database, RS As Recordset
Static DISPLAYID As Long
Static DISPLAYCOL As Integer
Static DISPLAYTEXT As String
Dim Semicolon As Integer
'On Error GoTo Err_AddAllToList
Select Case Code
Case LB_INITIALIZE
' See if the function is already in use.
If DISPLAYID <> 0 Then
MsgBox "AddAllToList is already in use by another Control! """
AddAllToList = False
Exit Function
End If
' Parse the display column and display text from the Tag
' property.
DISPLAYCOL = 1
DISPLAYTEXT = "(All)"
If Not IsNull(C.Tag) Then
Semicolon = InStr(C.Tag, ";")
If Semicolon = 0 Then
DISPLAYCOL = Val(C.Tag)
Else
DISPLAYCOL = Val(Left(C.Tag, Semicolon - 1))
DISPLAYTEXT = Mid(C.Tag, Semicolon + 1)
End If
End If
' Open the recordset defined in the RowSource property.
Set DB = DBEngine.Workspaces(0).Databases(0)
Set RS = DB.OpenRecordset(C.RowSource, DB_OPEN_SNAPSHOT)
' Record and return the ID for this function.
DISPLAYID = Timer
AddAllToList = DISPLAYID
Case LB_OPEN
AddAllToList = DISPLAYID
Case LB_GETROWCOUNT
' Return the number of rows in the recordset.
RS.MoveLast
AddAllToList = RS.RecordCount + 1
Case LB_GETCOLUMNCOUNT
' Return the number of fields (columns) in the recordset.
AddAllToList = RS.Fields.Count
Case LB_GETCOLUMNWIDTH
AddAllToList = -1
Case LB_GETVALUE
' Are you requesting the first row?
If Row = 0 Then
' Should the column display "(All)"?
If Col = DISPLAYCOL - 1 Then
' If so, return "(All)."
AddAllToList = DISPLAYTEXT
Else
' Otherwise, return NULL.
AddAllToList = Null
End If
Else
' Grab the record and field for the specified row/column.
RS.MoveFirst
RS.Move Row - 1
AddAllToList = RS(Col)
End If
Case LB_END
DISPLAYID = 0
RS.Close
End Select
Bye_AddAllToList:
Exit Function
Err_AddAllToList:
Beep: MsgBox Error$, 16, "AddAllToList"
AddAllToList = False
Resume Bye_AddAllToList
End Function
Function ChangeQDef(Q As String, strSQL As String)
On Error GoTo Err_ChangeQDef
'Changes the SQL of the query Q to strSQL
Dim qd As QueryDef
Set qd = CurrentDb.QueryDefs(Q)
qd.SQL = strSQL
Exit_ChangeQDef:
Exit Function
Err_ChangeQDef:
MsgBox Err.Description
Resume Exit_ChangeQDef
End Function
Function IsObjectOpen(strName As String, Optional intObjectType As Integer = acForm) As Boolean
'intObjectType can be:
' acTable (0)
' acQuery (1)
' acForm (2)
' acReport (3)
' acMacro (4)
' acModule (5)
'Returns True if strName is open, False otherwise
On Error Resume Next
IsObjectOpen = (SysCmd(SYSCMD_GETOBJECTSTATE, intObjectType, strName) <> 0)
If Err <> 0 Then
IsObjectOpen = False
End If
End Function
Function GetRedYellowGreen(dDate As Date) As Integer
On Error GoTo Err_GetRedYellowGreen
GetRedYellowGreen = IIf(Nz([dDate], #1/1/2100#) > Date + 14, 0, IIf([dDate] > Date, 1, 2))
Exit_GetRedYellowGreen:
Exit Function
Err_GetRedYellowGreen:
MsgBox "Module: Utilities, GetRedYellowGreen " & Err.Description
Resume Exit_GetRedYellowGreen
End Function
Function GetNextECMNumber() As String
Dim strSQL As String
Dim rst As New ADODB.Recordset
strSQL = "SELECT Max([ECMNumber]) AS MaxOfECMNumber " & _
"FROM tbl_ECMs"
rst.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockPessimistic
rst.MoveFirst
GetNextECMNumber = "HFF-ECM-" & Format(Right(rst!MaxOfECMNumber, 4) + 1, "0000")
rst.Close
Set rst = Nothing
End Function
Function GetNumberofRows(strSQL As String) As Double
Dim rst As New ADODB.Recordset
rst.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockPessimistic
rst.MoveFirst
If rst.EOF Then
GetNumberofRows = 0
Else
GetNumberofRows = rst.RecordCount
End If
rst.Close
Set rst = Nothing
End Function
Function FilterGeneric(strFilter As String) As String
On Error GoTo Err_FilterGeneric
Dim frm As Form, ctl As Control
Dim varItem As Variant
Dim FilterString As String
Set frm = Forms!frm_ECMs
Set ctl = Forms!frm_ECMs(DLookup("[FilterFormControl]", "[tbl_Filters]", "[FilterName]= '" & strFilter & "'"))
FilterString = ""
'enumerate selected items and concatenate to strSQL
For Each varItem In ctl.ItemsSelected
If ctl.ItemData(varItem) = 0 Then
FilterGeneric = ""
Exit Function
Else
FilterString = FilterString & " " & DLookup("[FilterSQLWHEREClause]", "[tbl_Filters]", "[FilterName]= '" & strFilter & "'") & "= " & ctl.ItemData(varItem) & " OR "
End If
Next varItem
If Nz(FilterString, "") = "" Then
FilterGeneric = ""
Exit Function
End If
'Trim the end of strSQL
FilterString = Left$(FilterString, InStrRev(FilterString, "OR") - 2)
FilterGeneric = FilterString
Exit_FilterGeneric:
Exit Function
Err_FilterGeneric:
MsgBox Err.Description
Resume Exit_FilterGeneric
End Function
|
