its rather sloppy, but here is the main sub that does the work
Private Sub BuildDisplayForm(strPath As String, iOutlineNum As Integer)
'adds controls to form for outline_properity field according to outline_type
On Error GoTo error_BuildDisplayForm
Dim qdf As QueryDef, qdfControls As QueryDef
Dim rs As Recordset, rsFiltered As Recordset, rsControls As Recordset,
rsCurCtrl As Recordset
Dim frm As Form
Dim ctl As Control, ctlLabel As Control, ctlParent As Control
Dim intDataX As Integer, intDataY As Integer
Dim intLabelX As Integer, intLabelY As Integer
Dim strOptTypeName As String, strLabel As String, strValueType As String,
strType As String, strText As String
Dim strFilter As String, strSuffix As String, strParentName As String,
strCaption As String
Dim i As Integer, j As Integer, L As Integer
Dim iLeft As Integer, iTop As Integer, iWidth As Integer, iHeight As Integer
Dim iHP As Integer, iTP As Integer, iLP As Integer, iWP As Integer
Dim iLMargin As Integer, iSep As Integer, iBottom As Integer, iAdj As Integer
Dim iOutlineOrder As Long
Dim strExpr As String
Dim strCtlName As String
Dim strStatus As String
Dim acTypeValue As Long
Dim lngReturn As Long
Dim mdl As Module
Dim strLine As String
Dim strSubFormName As String
strLine = "Call NudgeCurControl(KeyCode)" & vbCrLf & "KeyCode = 0"
iLMargin = 0.25 * 1440
iSep = 0.1 * 1440
i = 0
'this function returns the name of the form to populate
strDisplayFormName = CreateDisplayForm
i = 0
DoCmd.OpenForm strDisplayFormName, acDesign
Set frm = Forms(strDisplayFormName)
Set mdl = frm.Module
frm.Visible = False
frm.Caption = "Path: " & strPath & ",Outline Number: " & CStr(iOutlineNum)
j = frm.Controls.Count - 1
For i = j To 0 Step -1
Select Case frm.Controls(i).ControlType
Case acCommandButton
If (frm.Controls(i).Name <> "cmdExit") And
(frm.Controls(i).Name <> "cmdSave") Then
DeleteControl frm.Name, frm.Controls(i).Name
End If
Case acLine, acRectangle
'keep these
Case Else
DeleteControl frm.Name, frm.Controls(i).Name
End Select
Next
'get list of controls on screen for given outline number
Set qdfControls = CurrentDb.QueryDefs("qry_ScreenTypes_forgiven_OutlineNum")
qdfControls.Parameters("pOutlineNum") = iOutlineNum
Set rsControls = qdfControls.OpenRecordset
If rsControls.EOF And rsControls.BOF Then
'shouldnot happen
Else
Set qdf = CurrentDb.QueryDefs("qryTypeDef")
'loop through controls and put them on display
rsControls.MoveFirst
Do Until rsControls.EOF
strType = rsControls!OutLine_Type
strText = rsControls!OutLine_Properity
iOutlineOrder = rsControls!OutLine_Order
i = 0
qdf.Parameters("TypeName") = strType
Set rs = qdf.OpenRecordset
If rs.EOF And rs.BOF Then
'not a screen type, shouldn't get here
Else
'controls depend upon type
'string types must not have an underscore character
Select Case strType
Case "OptionGrp"
Set rsCurCtrl = GetTypeRS(strType, strText)
'create option group acOptionGroup
strParentName = strType & "_" & CStr(iOutlineOrder) & "_"
strFilter = "Element = 'Left'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
iLP = rsFiltered!CurrentValue
strFilter = "Element = 'Top'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
iTP = rsFiltered!CurrentValue
strFilter = "Element = 'Width'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
iWP = rsFiltered!CurrentValue
Set ctl = CreateControl(frm.Name, acOptionGroup,
acDetail, , "", iLP, iTP, iWP)
iHP = ctl.Height
ctl.Name = strParentName
ctl.DefaultValue = 1
ctl.Tag = "OPTIONGRP"
strExpr = "[Forms]![" & strDisplayFormName & "]![" &
strParentName & "]"
ctl.OnMouseDown = "= SetCurCtrl(" & strExpr & ")"
'optiongroup has one child label
strFilter = "Element = 'Caption_Left'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
iLeft = rsFiltered!CurrentValue
strFilter = "Element = 'Caption_Top'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
iTop = rsFiltered!CurrentValue
strFilter = "Element = 'Caption_Width'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
iWidth = rsFiltered!CurrentValue
strFilter = "Element = 'Caption'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
strCaption = rsFiltered!CurrentValue
Set ctlLabel = CreateControl(frm.Name, acLabel, ,
ctl.Name, strCaption, iLeft, iTop)
ctlLabel.Tag = "PARENTCAPTION"
ctlLabel.BackStyle = 1
iWidth = ctlLabel.Width
If iWidth > iWP Then
iWP = iWidth + iSep
ctl.Width = iWP
End If
strStatus = "LEFT=" & CStr(iLP) & ",TOP=" & CStr(iTP) &
",WIDTH=" & CStr(iWP)
strStatus = strStatus & ";CAPTION_LEFT=" & CStr(iLeft) &
",CAPTION_TOP=" & CStr(iTP) & ",CAPTION_WIDTH=" & CStr(iWidth)
ctl.StatusBarText = strStatus
Set ctlParent = ctl
'option groups have 10 levels, like opt1..., opt2..., ...
For i = 1 To 10
strFilter = "Element LIKE 'Opt" & CStr(i) & "*'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
rsFiltered.MoveFirst
Do Until rsFiltered.EOF
strSuffix = Mid(rsFiltered!Element, 5)
Select Case strSuffix
Case "Left"
iLeft = Val(Nz(rsFiltered!CurrentValue,
0))
If iLeft < iLP + iLMargin Then
'left side of option must be greater than left side of group
iLeft = iLP + iLMargin
rsFiltered.Edit
rsFiltered!CurrentValue = iLeft
rsFiltered.Update
End If
Case "Top"
iTop = Val(Nz(rsFiltered!CurrentValue, 0))
If iHeight <> 0 Then
If iTop < iBottom Then 'top of
next group cannot overlap bottom of previous group
iTop = iBottom + iSep
rsFiltered.Edit
rsFiltered!CurrentValue = iTop
rsFiltered.Update
End If
End If
Case "Width"
iWidth = Val(Nz(rsFiltered!CurrentValue,
0))
Case "Caption"
strCaption = Nz(rsFiltered!CurrentValue,
"")
Case Else
End Select
rsFiltered.MoveNext
Loop
If iLeft = 0 Or iTop = 0 Or iWidth = 0 Or strCaption
= "" Then
Exit For
Else
Set ctl = CreateControl(frm.Name,
acOptionButton, acDetail, ctlParent.Name, "", iLeft, iTop, iWidth)
ctl.Name = strType & "_" & CStr(iOutlineOrder)
& "_" & CStr(i)
ctl.OnMouseDown = "= SetCurCtrl(" & strExpr & ")"
lngReturn = mdl.CreateEventProc("KeyDown",
ctl.Name)
mdl.InsertLines lngReturn + 1, strLine
intLabelX = iLeft + iWidth
intLabelY = iTop
Set ctlLabel = CreateControl(frm.Name, acLabel,
, ctl.Name, strCaption, intLabelX, intLabelY)
iWidth = ctlLabel.Width
iHeight = ctl.Height
If (iTop - iTP) + iHeight > iHP Then
iHP = iHP + 2 * iHeight
frm.Controls(strParentName).Height = iHP
End If
iBottom = iTop + iHeight
strStatus = "LEFT=" & CStr(iLeft) & ",TOP=" &
CStr(iTop) & ",WIDTH=" & CStr(iWidth)
ctl.StatusBarText = strStatus
End If
Next
rsCurCtrl.Close
Case "TextBox", "ComboBox"
Select Case strType
Case "TextBox"
acTypeValue = acTextBox
Case "ComboBox"
acTypeValue = acComboBox
Case Else
End Select
Set rsCurCtrl = GetTypeRS(strType, strText)
'create control
strParentName = strType & "_" & CStr(iOutlineOrder)
strFilter = "Element = 'Left'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
iLP = rsFiltered!CurrentValue
strFilter = "Element = 'Top'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
iTP = rsFiltered!CurrentValue
strFilter = "Element = 'Width'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
iWP = rsFiltered!CurrentValue
Set ctl = CreateControl(frm.Name, acTypeValue, acDetail,
, "", iLP, iTP, iWP)
iHP = ctl.Height
ctl.Name = strParentName
ctl.Tag = UCase(strType)
strExpr = "[Forms]![" & strDisplayFormName & "]![" &
strParentName & "]"
ctl.OnMouseDown = "= SetCurCtrl(" & strExpr & ")"
lngReturn = mdl.CreateEventProc("KeyDown", ctl.Name)
mdl.InsertLines lngReturn + 1, strLine
'control has one child label
strFilter = "Element = 'Caption_Left'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
iLeft = rsFiltered!CurrentValue
strFilter = "Element = 'Caption_Top'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
iTop = rsFiltered!CurrentValue
strFilter = "Element = 'Caption_Width'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
iWidth = rsFiltered!CurrentValue
strFilter = "Element = 'Caption'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
strCaption = rsFiltered!CurrentValue
Set ctlLabel = CreateControl(frm.Name, acLabel, ,
ctl.Name, strCaption, iLeft, iTop)
ctlLabel.Tag = "PARENTCAPTION"
iWidth = ctlLabel.Width
strStatus = "LEFT=" & CStr(iLP) & ",TOP=" & CStr(iTP) &
",WIDTH=" & CStr(iWP)
strStatus = strStatus & ";CAPTION_LEFT=" & CStr(iLeft) &
",CAPTION_TOP=" & CStr(iTP) & ",CAPTION_WIDTH=" & CStr(iWidth)
ctl.StatusBarText = strStatus
Case "OptButton"
acTypeValue = acOptionButton
Set rsCurCtrl = GetTypeRS(strType, strText)
'create control
'option button only has left and top
strParentName = strType & "_" & CStr(iOutlineOrder)
strFilter = "Element = 'Left'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
iLP = rsFiltered!CurrentValue
strFilter = "Element = 'Top'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
iTP = rsFiltered!CurrentValue
Set ctl = CreateControl(frm.Name, acTypeValue, acDetail,
, "", iLP, iTP)
ctl.Name = strParentName
ctl.Tag = UCase(strType)
iWP = ctl.Width
strExpr = "[Forms]![" & strDisplayFormName & "]![" &
strParentName & "]"
ctl.OnMouseDown = "= SetCurCtrl(" & strExpr & ")"
lngReturn = mdl.CreateEventProc("KeyDown", ctl.Name)
mdl.InsertLines lngReturn + 1, strLine
'control has one child label, with only caption and
width property
'place it to the right of button, same top
iLeft = iLP + iWP + iSep
iTop = iTP
strFilter = "Element = 'Caption_Width'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
iWidth = rsFiltered!CurrentValue
strFilter = "Element = 'Caption'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
strCaption = rsFiltered!CurrentValue
Set ctlLabel = CreateControl(frm.Name, acLabel, ,
ctl.Name, strCaption, iLeft, iTop)
ctlLabel.Tag = "PARENTCAPTION"
iWidth = ctlLabel.Width
strStatus = "LEFT=" & CStr(iLP) & ",TOP=" & CStr(iTP)
strStatus = strStatus & ";CAPTION_WIDTH=" & CStr(iWidth)
ctl.StatusBarText = strStatus
Case "SubForm"
'position of subform is fixed
iLP = 120
iTP = 2520
iWP = 8400
iHP = 1740
Set ctl = CreateControl(frm.Name, acSubform, acDetail, ,
"", iLP, iTP, iWP, iHP)
ctl.SourceObject = "sfrmSubDisplay"
strSubFormName = ctl.Name
'no positioning of controls, but get labels and col widths
Set rsCurCtrl = GetTypeRS(strType, strText)
'12 text boxes, txt1... to txt12...
'label is txt1ColumnName
'col width is txt1ColumnWidth
For i = 1 To 12
strFilter = "Element LIKE 'txt" & CStr(i) & "*'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
rsFiltered.MoveFirst
Do Until rsFiltered.EOF
strSuffix = Mid(rsFiltered!Element, Len(CStr(i))
+ 4)
Select Case strSuffix
Case "ColumnName"
strCaption = Nz(rsFiltered!CurrentValue,
"")
Case "ColumnWidth"
iWidth = Val(Nz(rsFiltered!CurrentValue,
0))
Case Else
End Select
rsFiltered.MoveNext
Loop
'set labels and width per above values
strCtlName = "txt" & CStr(i)
Forms(frm.Name).Form(ctl.Name).Controls(strCtlName).Width = iWidth
If iWidth = 0 Then
Forms(frm.Name).Form(ctl.Name).Controls(strCtlName).ColumnHidden = True
End If
strCtlName = "lbltxt" & CStr(i)
Forms(frm.Name).Form(ctl.Name).Controls(strCtlName).Caption = strCaption
Next
For i = 1 To 4
strFilter = "Element LIKE 'cbo" & CStr(i) & "*'"
rsCurCtrl.Filter = strFilter
Set rsFiltered = rsCurCtrl.OpenRecordset
rsFiltered.MoveFirst
Do Until rsFiltered.EOF
strSuffix = Mid(rsFiltered!Element, Len(CStr(i))
+ 4)
Select Case strSuffix
Case "ColumnName"
strCaption = Nz(rsFiltered!CurrentValue,
"")
Case "ColumnWidth"
iWidth = Val(Nz(rsFiltered!CurrentValue,
0))
Case Else
End Select
rsFiltered.MoveNext
Loop
'set labels and width per above values
strCtlName = "cbo" & CStr(i)
Forms(frm.Name).Form(ctl.Name).Controls(strCtlName).Width = iWidth
If iWidth = 0 Then
Forms(frm.Name).Form(ctl.Name).Controls(strCtlName).ColumnHidden = True
End If
strCtlName = "lblcbo" & CStr(i)
Forms(frm.Name).Form(ctl.Name).Controls(strCtlName).Caption = strCaption
Next
rsCurCtrl.Close
Case Else
End Select
End If
rsControls.MoveNext
Loop
End If
DoCmd.Close acForm, frm.Name, acSaveYes
exit_BuildDisplayForm:
rs.Close
qdf.Close
Set rs = Nothing
Set rsCurCtrl = Nothing
Set qdf = Nothing
Set rsFiltered = Nothing
Set frm = Nothing
Set mdl = Nothing
Exit Sub
error_BuildDisplayForm:
MsgBox "BuildDisplayForm, ioutlineorder=" & CStr(iOutlineOrder) & ";Error "
& Err & " :" & Err.Description
Resume exit_BuildDisplayForm
End Sub