[VBA]
Option Explicit
Public Const TW = 567
Public Sub NewForm()
'creates a new standard form based on a blank template
'asking user if they want standard buttons such as help & back
'and if they want any other additional buttons of two standard
'sizes - big 6cmx1cm and small 3cmX0.667cm
Dim frm As Form, ctl As Control, mdl As Module
Dim NoControls%
Dim I%
Dim X%, Y%
Dim lngReturn As Long
Dim R$
Y = 0
X = 0
Set frm = CreateForm(, "Blank Form")
frm.Caption = InputBox("What caption do you want for the the form?", "Form Caption")
Set ctl = CreateControl(frm.Name, acLine, , , , 0, 11 * TW, 20 * TW)
ctl.SpecialEffect = 3
If MsgBox("Do you want a back button?", vbYesNo + vbQuestion, "Back button?") = vbYes Then
R$ = InputBox("Enter name of form to go back to", "Back form")
Set ctl = CreateControl(frm.Name, acCommandButton, _
, , , 1 * TW, 11.2 * TW, 3 * TW, 0.667 * TW)
ctl.Caption = "&Back"
ctl.Name = "btnBack"
Set mdl = frm.Module
lngReturn = mdl.CreateEventProc("Click", ctl.Name)
mdl.InsertLines lngReturn + 1, vbTab & "Swapforms " & Chr(34) & R$ & Chr(34) & ", Me.FormName"
End If
If MsgBox("Do you want a help button?", vbYesNo + vbQuestion, "Help button?") = vbYes Then
Set ctl = CreateControl(frm.Name, acCommandButton, _
, , , 16 * TW, 11.2 * TW, 3 * TW, 0.667 * TW)
ctl.Caption = "&Help"
ctl.Name = "btnHelp"
Set mdl = frm.Module
lngReturn = mdl.CreateEventProc("Click", ctl.Name)
mdl.InsertLines lngReturn + 1, vbTab & "Msgbox " & Chr(34) & "There is no help file currently available" & Chr(34) & ", vbInformation, ""Help"""
End If
NoControls = InputBox("How many large buttons do you want on the new form?", "Large buttons")
For I = 1 To NoControls
Set ctl = CreateControl(frm.Name, acCommandButton, _
, , , X, Y, 6 * TW, 1 * TW)
ctl.Name = "btnLNew" + Trim(Str(I))
X = X + TW * 6.5
If X > (TW * 14) Then X = 0: Y = Y + TW * 1.5
Next I
X = 0
Y = Y + TW * 1.5
NoControls = InputBox("How many small buttons do you want on the new form?", "Small buttons")
For I = 1 To NoControls
Set ctl = CreateControl(frm.Name, acCommandButton, _
, , , X, Y, 3 * TW, 0.667 * TW)
ctl.Name = "btnSNew" + Trim(Str(I))
X = X + TW * 3.5
If X > (TW * 17) Then X = 0: Y = Y + TW * 1.5
Next I
MsgBox "Back & Help buttons have been created with standard code associated with them!", vbInformation, "Finished"
DoCmd.Maximize
End Sub
Sub ChangeBtnCaption()
' this will open all forms in the current database then
' replace each command button caption that matches user
' input OldCap with NewCap
Dim dbs As Database
Dim ctr As Container
Dim doc As Document
Dim frm As Form
Dim ctrl As Control
Dim NoChanges%
Dim OldCap$, NewCap$, InputMsg$
Dim Proceed As Boolean
Dim Changes$
InputMsg = "Please enter the command button" & vbCr
InputMsg = InputMsg & "caption you wish to replace"
OldCap = InputBox(InputMsg & ":" & vbCr & vbCr & "(include any access key assignments i.e. &)", "Enter old caption")
If OldCap = "" Then GoTo Exit_ChangeBtnCaption
NewCap = InputBox(InputMsg & " " & OldCap & " with:", "Enter new caption")
If NewCap = "" Then
MsgBox "You can't replace it with nothing", vbInformation, "Change button caption - error"
GoTo Exit_ChangeBtnCaption
End If
Set dbs = CurrentDb
Set ctr = dbs.Containers!Forms
For Each doc In ctr.Documents
DoCmd.OpenForm doc.Name, acDesign
Set frm = Forms(doc.Name)
For Each ctrl In frm.Controls
If ctrl.ControlType = acCommandButton Then
If UCase(ctrl.Caption) = UCase(OldCap) Then
ctrl.Caption = NewCap
NoChanges = NoChanges + 1
Changes = Changes & vbTab & ctrl.Name & " in " & doc.Name & vbCr
End If
End If
Next
DoCmd.Close acForm, frm.Name, acSaveYes
Next
If NoChanges Then
MsgBox NoChanges & " captions where changed in this database - " & vbCr & vbCr & Changes, vbInformation, "Change button caption"
Else
MsgBox "No buttons with caption" & vbCr & vbCr & vbTab & OldCap & " were found.", vbInformation, "Change button caption"
End If
Set dbs = Nothing
Exit_ChangeBtnCaption:
End Sub
Function IsLoaded(ByVal frmName As String) As Boolean
'returns true if a form is open in datasheet or form view
Dim frm As Form
For Each frm In Forms
IsLoaded = (frm.Name = frmName) And ((frm.CurrentView) <> 0)
If IsLoaded Then Exit Function
Next
End Function
Function IsControl(ByVal frmName As String, ByVal ctrlName) As Boolean
' returns true if ctrlName is the name of a control on the form frmName
Dim frm As Form
Dim ctrl As Control
If Not (IsLoaded(frmName)) Then Exit Function
Set frm = Forms(frmName)
For Each ctrl In frm.Controls
IsControl = IsControl Or (ctrl.Name = ctrlName)
If IsControl Then Exit Function
Next
End Function
Function IsSubForm(ByVal frmName As String, ByVal subfrmName As String) As Boolean
Dim frm As Form
Dim ctrl As Control
If Not (IsLoaded(frmName)) Then Exit Function
Set frm = Forms(frmName)
If IsControl(frmName, subfrmName) Then
Set ctrl = frm.Controls(subfrmName)
IsSubForm = (ctrl.ControlType = acSubform)
Else
IsSubForm = False
End If
End Function
Function RecordCluster() As Boolean
' creates a cluster of buttons on a form
' that are used for record actions
' i.e add/delete/edit
Dim frm As Form, ctl As Control
Dim frmName As String, Found As Boolean
frmName = InputBox("Enter form name to add buttons to:", "Form name")
For Each frm In Forms
Found = Found Or (frm.Name = frmName)
Next
If Not Found Then
MsgBox "Form" & frmName & "is not open.", vbInformation, "Record cluster"
Exit Function
End If
Set frm = Forms(frmName)
Set ctl = CreateControl(frm.Name, acRectangle, acFooter, , , 12 * TW, 0.099 * TW, 4.8 * TW, 0.801 * TW)
ctl.SpecialEffect = 1
Set ctl = CreateControl(frm.Name, acCommandButton, acFooter, , , 12.075 * TW, 0.16 * TW, 1.5 * TW, 0.667 * TW)
ctl.Name = "btnAdd"
ctl.Caption = "&Add"
Set ctl = CreateControl(frm.Name, acCommandButton, acFooter, , , 13.65 * TW, 0.16 * TW, 1.5 * TW, 0.667 * TW)
ctl.Name = "btnEdit"
ctl.Caption = "&Edit"
Set ctl = CreateControl(frm.Name, acCommandButton, acFooter, , , 15.25 * TW, 0.16 * TW, 1.5 * TW, 0.667 * TW)
ctl.Name = "btnDel"
ctl.Caption = "&Delete"
End Function
Function chkRecordSource(rsc As String) As String
' will return with the names of all the forms that
' use rsc as a RecordSource or if none do, an empty string
Dim ctr As Container
Dim db As Database
Dim frm As Form
Dim doc As Document
Set db = CurrentDb
Set ctr = db.Containers("Forms")
For Each doc In ctr.Documents
DoCmd.OpenForm doc.Name, acDesign
Set frm = Forms(doc.Name)
If frm.RecordSource = rsc Then chkRecordSource = chkRecordSource & Chr(13) & frm.FormName
DoCmd.Close acForm, frm.FormName
Next
End Function
[/VBA]
Reply With Quote
