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:
|
Public Sub BuildForm_LookupTableMaint()
On Error GoTo err_trap
Dim frm As Form
Dim strFormName As String
Dim ctrlTab As Control
Dim ctrlSubform As Control
Dim ctrlLabel As Control
Dim ctrlTextbox As Control
Dim strTabName As String
Dim rsLookupTables As DAO.Recordset
Dim intPage As Integer
Dim tdf As TableDef
Dim fld As Field
Dim frmSubform As Form
Dim strSubformName As String
Dim strSubformNameFinal As String
Dim db As Database
Dim dblLeft As Double
Dim dblTop As Double
Dim dblWidth As Double
Dim dblHeight As Double
Dim rsWidth As DAO.Recordset
Dim strFieldName As String
Dim strSQL As String
Dim strSubFormControlName As String
Set db = CurrentDb
'close form if it already exists and is open
If IsFormOpen("frmSysMaint_LookupTables") Then
DoCmd.Close acForm, "frmSysMaint_LookupTables"
End If
'delete the form if it already exists
If Nz(DLookup("Name", "MSysObjects", "Name='frmSysMaint_LookupTables' And Type=-32768"), "") <> "" Then
DoCmd.SetWarnings False
DoCmd.DeleteObject acForm, "frmSysMaint_LookupTables"
DoCmd.SetWarnings True
End If
'create the main form frmSysMaint_LookupTables
Set frm = CreateForm
strFormName = frm.Name
DoCmd.Close acForm, strFormName, acSaveYes
DoCmd.Rename "frmSysMaint_LookupTables", acForm, strFormName
'set form properties
DoCmd.OpenForm "frmSysMaint_LookupTables", acDesign ', , , , acHidden
Set frm = Forms("frmSysMaint_LookupTables")
frm.Properties("AutoCenter") = True
frm.Properties("PopUp") = True
frm.Caption = "Lookup Table Maintenance"
frm.Properties("RecordSelectors") = False
frm.Properties("NavigationButtons") = False
'create tab control
Set ctrlTab = CreateControl(frm.Name, acTabCtl, acDetail, , , 0, 0, 8.9063 * 1440, 6.0833 * 1440)
ctrlTab.Name = "tabLookupTables"
ctrlTab.FontName = "Arial"
ctrlTab.FontSize = 10
'for each lookup table, create a subform whose record source is the lookup table
'and create the controls to map to the table fields
Set rsLookupTables = db.OpenRecordset("Select trefLookupTables.* FROM trefLookupTables ORDER BY TableName", dbReadOnly)
Do Until rsLookupTables.EOF
strSubformNameFinal = "fsub" & rsLookupTables!TableName
'insert tabcontrol page
ctrlTab.Pages.Add
intPage = ctrlTab.Pages.Count - 1
GoSub CreateSubform
GoSub CreateSubformControls
GoSub AddSubformControlToTab
rsLookupTables.MoveNext
Loop
DoCmd.Save acForm, "frmSysMaint_LookupTables"
DoCmd.Close acForm, "frmSysMaint_LookupTables"
DoCmd.OpenForm "frmSysMaint_LookupTables", acDesign ', , , , acHidden
err_exit:
Exit Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
CreateSubform:
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'first create the form that will be the SourceObject of the subform control in the tab
Set frmSubform = CreateForm
strSubformName = frmSubform.Name
DoCmd.Close acForm, strSubformName, acSaveYes
'check if subform is open or exists
'close form if it already exists and is open
If IsFormOpen(strSubformNameFinal) Then
DoCmd.Close acForm, strSubformNameFinal
End If
'delete the form if it already exists
If Nz(DLookup("Name", "MSysObjects", "Name='" & strSubformNameFinal & "' And Type=-32768"), "") <> "" Then
DoCmd.SetWarnings False
DoCmd.DeleteObject acForm, strSubformNameFinal
DoCmd.SetWarnings True
End If
DoCmd.Rename strSubformNameFinal, acForm, strSubformName
Return
'CreateSubform''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
CreateSubformControls:
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'create the subform controls using its RecordSource
DoCmd.OpenForm strSubformNameFinal, acDesign, , , , acHidden
Set frmSubform = Forms(strSubformNameFinal)
frmSubform.RecordSource = rsLookupTables!LocalTableName
frmSubform.DefaultView = 2
DoCmd.Save acForm, strSubformNameFinal
Set tdf = db.TableDefs(rsLookupTables!LocalTableName)
For Each fld In tdf.Fields
strFieldName = fld.Name
strSQL = "SELECT Max(Len([" & strFieldName & "])) AS Width FROM [" & rsLookupTables!LocalTableName & "]"
Set rsWidth = db.OpenRecordset(strSQL, dbReadOnly)
If fld.Name = "Warehouse City" Then Stop
If rsWidth!Width = 1 Then 'double the width
dblWidth = (rsWidth!Width * 160) * 2
Else
dblWidth = rsWidth!Width * 160
End If
With ctrlSubform
'CreateControl(formname, controltype[, section[, parent[, columnname[, left[, top[, width[, height]]]]]]])
Set ctrlTextbox = CreateControl(frmSubform.Name, acTextBox, , , fld.Name, dblLeft, dblTop, dblWidth, 1440 / 5)
ctrlTextbox.Name = strFieldName
ctrlTextbox.FontName = "Tahoma"
ctrlTextbox.FontSize = 10
dblLeft = dblLeft + dblWidth
End With
Next fld
dblLeft = 0
DoCmd.Close acForm, strSubformNameFinal, acSaveYes
Return
'CreateSubformControls''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
AddSubformControlToTab:
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'create the subform control whose SourceObject will be the form "fsub" & rsLookupTables!TableName
ctrlTab.Pages(intPage).Name = "pg_" & rsLookupTables!TableName
ctrlTab.Pages(intPage).Caption = rsLookupTables!Caption
With ctrlTab.Pages(intPage)
Set ctrlSubform = CreateControl(frm.Name, acSubform, , , , 0.0938 * 1440, 0.2917 * 1440, 4 * 1440, 4 * 1440)
strSubFormControlName = ctrlSubform.Name
ctrlSubform.SourceObject = strSubformNameFinal
Forms("frmSysMaint_LookupTables").Controls(strSubFormControlName).Name = strSubformNameFinal
End With
Return
'AddSubformControlToTab'''''''''''''''''''''''''''''''''
err_trap:
Select Case Err
Case 2467 'tab control page does not exist add one
ctrlTab.Pages.Add
Resume
Case Else
MsgBox "Error in BuildForm_LookupTableMaint" & vbCrLf & Trim(str(Err)) & ": " & Error(Err), vbInformation
Resume err_exit
Resume
End Select
End Sub
|
