Ann, Michael & EvilCabal
Ok, Ok I was being lazy!!! Michael is right that thinnggyyyy was not saved, was not therefore registered as a form and was therefore an orphan and cannot be modal to anything.
So... following on from that here is the latest code.. it works but can be messy!!!
DialogBox.bas module
--------------------
Option Compare Database
Option Explicit
Public Type dlgControlRec
CtrlType As Integer
CtrlCaption As String
CtrlLabel As String
CtrlAction As String
End Type
Public Type dlgControls
Ctrl(10) As dlgControlRec
End Type
Public Type dlgRetValRec
ButtonPress As Integer
CtrlValue As String
End Type
Public Type dlgRetVals
ReturnCtrl(10) As dlgRetValRec
End Type
Public DlgRetVal As dlgRetVals
Dim frm As Form
Dim ctl As Control
Dim mdl As Module
Dim lngReturn As Long
Function dBox(strCaption As String, dlgctrls As dlgControls) As String
Dim oldname As String
Dim i As Integer
On Error GoTo Error_dBox
'Delete old form - removing all previous controls etc
DoCmd.DeleteObject acForm, "¿DialogBox¿"
'Create new DialogBox
Set frm = CreateForm
oldname = frm.NAME
DoCmd.Close acForm, frm.NAME, acSaveYes
DoCmd.Rename "¿DialogBox¿", acForm, oldname
'Open Form
DoCmd.OpenForm "¿DialogBox¿", acDesign
' Set properties to form.
Set frm = Forms!¿DialogBox¿
frm.Caption = strCaption
frm.DefaultView = 0 'Single Form
frm.ScrollBars = 0 'Neither
frm.Visible = True
frm.Modal = True
frm.NavigationButtons = False
frm.RecordSelectors = False
i = 1
While dlgctrls.Ctrl(i).CtrlType <> 0
DoCreateControls dlgctrls, i
i = i + 1
Wend
RealignControls
DoCmd.Close acForm, frm.NAME, acSaveYes
DoCmd.OpenForm "¿DialogBox¿", acNormal, , , , acDialog
Exit_dBox:
Exit Function
Error_dBox:
If Err.Number = 3011 Then
'First Time of run? Form did not exist to be deleted
'Continue normally to create
Resume Next
Else
MsgBox Err & " :" & Err.DESCRIPTION
DoCmd.Close acForm, frm.NAME, acSaveNo
Resume Exit_dBox
End If
End Function
Private Sub DoCreateControls(dlgctrls As dlgControls, intControl As Integer)
Set ctl = CreateControl(frm.NAME, dlgctrls.Ctrl(intControl).CtrlType, , , , 0, 0)
If dlgctrls.Ctrl(intControl).CtrlLabel <> "" Then
Set ctl = CreateControl(frm.NAME, acLabel, , , , 500, 500)
ctl.Caption = dlgctrls.Ctrl(intControl).CtrlLabel
ctl.Width = Len(dlgctrls.Ctrl(intControl).CtrlLabel) * (ctl.FontSize * 15)
ctl.Height = 225
End If
If dlgctrls.Ctrl(intControl).CtrlType = acCommandButton Then
ctl.Caption = dlgctrls.Ctrl(intControl).CtrlCaption
' Return reference to form module.
Set mdl = frm.Module
' Add event procedure.
lngReturn = mdl.CreateEventProc("Click", ctl.NAME)
' Insert text into body of procedure.
mdl.InsertLines lngReturn + 1, vbTab & dlgctrls.Ctrl(intControl).CtrlAction
End If
End Sub
Private Sub RealignControls()
'This function aligns Buttons right and Down
'Textboxs and comboboxes left and down
For Each ctl In frm.Controls
' Check to see if control is CommandButton.
If ctl.ControlType = acCommandButton Then
' Set control properties.
With ctl
.Left = frm.Width + frm.GridX - (.Width * 2) 'ie right hand edge - twice width of button
.Enabled = True
.Top = ((RemoveText(ctl.NAME)) * (ctl.Height * 2)) 'Button Nos start at 1
End With
Else
' Check to see if control is Label.
If ctl.ControlType = acLabel Then
With ctl
.Left = frm.GridX + (.Width * 0.5) 'ie left hand edge - twice width
.Top = ((RemoveText(ctl.NAME)) * (ctl.Height * 2)) 'Text Nos start at 0
End With
Else
With ctl
.Left = frm.GridX + (.Width * 1.5) 'ie left hand edge - twice width
.Enabled = True
.Top = ((RemoveText(ctl.NAME) + 1) * (ctl.Height * 2)) 'Text Nos start at 0
End With
End If
End If
Next ctl
End Sub
Public Function RemoveText(strInput) As String
Dim intCount As Integer
RemoveText = ""
intCount = 1
While intCount < Len(strInput) + 1
If Mid(strInput, intCount, 1) >= "0" And _
Mid(strInput, intCount, 1) <= "9" Then
RemoveText = Mid(strInput, intCount, 1)
End If
intCount = intCount + 1
Wend
End Function
As this module stands you may have up to ten controls, and you need to specify what type of control, its caption, label and the OnClick action. All this can obviously be enhanced so that you could specify the event etc.
Once the controls have been defined they are placed on the form labels on the left, text/combo in the middle and buttons on the right, again all this could be enhanced so that you define where each control appears, its font, size etc.
To use (This is the messy bit!!):
Private Sub Test_DialogBox_Click()
Dim ctrls As dlgControls
ctrls.Ctrl(1).CtrlType = acTextBox
ctrls.Ctrl(1).CtrlLabel = "Text Box Label"
ctrls.Ctrl(2).CtrlType = acCommandButton
ctrls.Ctrl(2).CtrlCaption = "Exit"
'Build Code to execute
ctrls.Ctrl(2).CtrlAction = "Dim frm As Form" & vbCrLf & _
"Dim ctl As Control" & vbCrLf & vbCrLf & _
"Set frm = Form" & vbCrLf & _
"Set ctl = Screen.ActiveControl" & vbCrLf & vbCrLf & _
"DialogBox.DlgRetVal.ReturnCtrl(RemoveText(ctl.NAME) + 1).ButtonPress = vbOK" & vbCrLf & vbCrLf & _
"For Each ctl In frm.Controls" & vbCrLf & _
"'Check to see if control is text box." & vbCrLf & _
"If ctl.ControlType = acTextBox Or _" & vbCrLf & _
"ctl.ControlType = acComboBox Then" & vbCrLf & _
"DialogBox.DlgRetVal.ReturnCtrl(RemoveText(ctl.NAME) + 1).CtrlValue = ctl.Value" & vbCrLf & _
"End If" & vbCrLf & _
"Next ctl" & vbCrLf & vbCrLf & _
"DoCmd.Close acForm, me.NAME, acSaveyes"
ctrls.Ctrl(3).CtrlType = acCommandButton
ctrls.Ctrl(3).CtrlCaption = "Click"
ctrls.Ctrl(3).CtrlAction = "msgbox ""Way Cool!"""
dBox "Dialog Demo", ctrls
MsgBox DialogBox.DlgRetVal.ReturnCtrl(1).CtrlValue & " " & DialogBox.DlgRetVal.ReturnCtrl(2).ButtonPress
End Sub
Obviously this is fairly quick and dirty and I suspect a bit more error checking could be installed but hey ho!!
Enjoy!!
Cheers
Andy
