This procedure (sub) will add all the fields (text boxes) found in the underlying source table to the report programmatically using VBA. This also adds the proper buttons to the report output.
Sub AddControlsToTheReportOfThisTable(tblName As String, P_L As String)
Dim rpt As Report, ctl As Control, ctlLabel As Control, ctlLabelHeader As Control, ctrlName As String, ctrlSource As String
Dim rptName As String, mdl As Module, fldCounter As Integer, colCounter As Integer
Dim shortButtonL As Integer, LongButtonL As Integer, startPoscontrols As Integer, buttonH As Integer, buttonT As Integer
Dim numFields As Integer, paperWidthInInch As Integer, hH As Integer, fH As Integer, drHeight As Integer, fldsPerRow As Integer
startPoscontrols = 100 'twips
shortButtonL = 400
LongButtonL = 2000
buttonH = 420
buttonT = 50
paperWidthInInch = 10
hH = 400
fH = 360
drHeight = 400
fldsPerRow = 7
'Name Value Description
'acViewDesign 1 Design view
'acViewLayout 6 Layout view
'acViewNormal 0 (Default) Normal view
'acViewPivotChart 4 PivotChart view
'acViewPivotTable 3 PivotTable view
'acViewPreview 2 Print Preview
'acViewReport 5 Report view
'None 0 (Default) The current section (the section for which you're setting the property) is printed on the current page.
'Before Section 1 The current section is printed at the top of a new page.
'After Section 2 The section immediately following the current section is printed at the top of a new page.
'Before & After 3 The current section is printed at the top of a new page, and the next section is printed at the top of a new page.
'Name Value Description
'acDetail 0 (Default) Detail section
'acFooter 2 Form or report footer
'acGroupLevel1Footer 6 Group-level 1 footer (reports only)
'acGroupLevel1Header 5 Group-level 1 header (reports only)
'acGroupLevel2Footer 8 Group-level 2 footer (reports only)
'acGroupLevel2Header 7 Group-level 2 header (reports only)
'acHeader 1 Form or report header
'acPageFooter 4 Page footer
'acPageHeader 3 Page header
'Dim tblName$
Dim rs As DAO.Recordset
Dim list$, n%
Dim msg$
Dim procHeader As String, SQLHeader As String, SQLData As String
Dim iType%
Set rs = CurrentDb.OpenRecordset(tblName)
' Check how many fields are in the table
With rs
numFields = .Fields.Count
End With
rptName = "rpt" & tblName & P_L
DoCmd.OpenReport ReportName:=rptName, View:=acDesign
Set rpt = Reports(rptName)
colCounter = 1
leftPos = rpt.WindowLeft + 1440 / 2
toppos = rpt.WindowTop + 100
Set mdl = rpt.Module
With rpt
.Section(1).Height = hH
.Section(2).Height = fH
'Place the labels in the header section
If ControlExistsInReport("lblReportHeader", rptName) = False Then
Set ctlLabel = CreateReportControl(rptName, acLabel, Section:=acHeader, Width:=rpt.Width / 2, _
Height:=(hH * 0.9), Left:=rpt.Width / 3, Top:=0)
ctlLabel.Name = "lblReportHeader"
ctlLabel.Caption = StrConv(Replace(tblName, "tbl", ""), vbProperCase) & " Report"
ctlLabel.ControlTipText = "Double Click to See Print Preview of the Report"
ctlLabel.FontSize = 18
Call mdl.InsertLines(3, "Dim vCounter as Integer, gRecordsToPrintPerPage as Integer")
lngReturn = mdl.CreateEventProc("DblClick", ctlLabel.Name)
mdl.InsertLines lngReturn + 1, vbTab & "gRecordsToPrintPerPage = CInt(InputBox(""How many records to print per page?"", ""Enter Records"", 2))"
mdl.InsertLines lngReturn + 2, vbTab & "DoCmd.OpenReport Me.name, acViewPreview"
End If
.Section(1).BackColor = RGB(140, 60, 80)
.Section(2).BackColor = RGB(140, 60, 80)
'MsgBox .Section(2).Height
.Section(2).Height = 500
End With
Set rs = CurrentDb.OpenRecordset([tblName])
With rs
' MsgBox "There are " & .Fields.Count & " columns in " & tblName
numFields = .Fields.Count
For n% = 0 To .Fields.Count - 1
fldCounter = fldCounter + 1
list$ = list$ & .Fields(n%).Name & Chr(44) & dmwFieldType(.Fields(n%).Type) & vbNewLine
iType% = .Fields(n%).Type
'For Each prpLoop In .Fields(n%).Properties
' MsgBox .Fields(n%).Size
Select Case iType%
Case 1
fldType$ = "Boolean"
Case 2
fldType$ = "Byte"
Case 3
fldType$ = "Integer"
Case 4
fldType$ = "Long"
Case 5
fldType$ = "Currency"
Case 6
fldType$ = "Single"
Case 7
fldType$ = "Double"
Case 8
fldType$ = "Date" '"Date/Time"
Case 9
fldType$ = "Binary"
Case 10
fldType$ = "String" '"Short Text"
Case 11
fldType$ = "Long Binary"
Case 12
fldType$ = "String" '"Long Text"
Case 15
fldType$ = "GUID"
Case 16
fldType$ = "Double" '"Large Number"
Case 101
fldType$ = "Attachment"
Case Else
fldType$ = "NOT RECOGNISED"
End Select
ctrlName = fldType$ & .Fields(n%).Name
ctrlSource = .Fields(n%).Name
If ControlExistsInReport(ctrlName, rptName) = False Then
If .Fields.Count <= 20 Then
'Place the data entry fields in the detail section
w = ((rpt.Width) - 1 * 1440) / (fldsPerRow) '(numFields)
Set ctl = CreateReportControl(ReportName:=rptName, ControlType:=acTextBox, ColumnName:=ctrlSource, _
Left:=leftPos, Top:=toppos, Width:=w, Height:=drHeight)
ctl.Name = ctrlName
'Place the labels in the header section
Set ctlLabel = CreateReportControl(rptName, acLabel, Section:=acPageHeader, Width:=w, _
Height:=drHeight, Left:=leftPos, Top:=toppos)
ctlLabel.Name = ctrlSource
ctlLabel.Caption = ctrlSource
leftPos = leftPos + w 'rpt.Width / (numFields + 1) '+ 30
If (fldCounter Mod 7) = 0 Then
leftPos = rpt.WindowLeft + 1440 / 2
toppos = toppos + drHeight
End If
Else ' More then 7 columns in the table, so create a single record Report
'Place the labels first in the detail section
lblWidth = rpt.Width / numFields
w = ((rpt.Width) - 1 * 1440) / (fldsPerRow)
Set ctlLabel = CreateReportControl(rptName, acLabel, Section:=acDetail, Width:=w, _
Height:=420, Left:=leftPos, Top:=toppos)
ctlLabel.Name = ctrlSource
ctlLabel.Caption = fldCounter & ". " & ctrlSource
'Place the data entry field next to the label in the detail section
Set ctl = CreateReportControl(ReportName:=rptName, ControlType:=acTextBox, ColumnName:=ctrlSource, _
Left:=leftPos + w, Top:=toppos, Width:=w, Height:=420)
ctl.Name = ctrlName
toppos = toppos + 420
'leftPos = leftPos + w 'rpt.Width / (numFields + 1) '+ 30
If fldCounter Mod 25 = 0 Then
colCounter = colCounter + 1
leftPos = leftPos + (w * 2) + 100
toppos = rpt.WindowTop + 100
End If
End If
Else
MsgBox "Control " & ctrlName & " already exists in Report " & rptName
End If
Next n%
End With
rpt.Caption = "Auto Created Report - " & StrConv(tblName, vbProperCase)
If fldCounter <= 7 Then
rpt.DefaultView = 1 ' Continuous Report
Else
rpt.DefaultView = 0 ' Single Report
End If
'Add Procedures to the Report Module
'MsgBox mdl.CountOfLines
Dim startline As Integer
Dim strProc As String, strProcBody As String
strProc = "Detail_Format"
If ProcedureExistsInModule(strProc, "Report_" & rptName) Then ' First Parameter - Procedure name, second parameter - module name
startline = mdl.ProcStartLine(strProc, vbext_pk_Proc)
totalLinesInModule = mdl.CountOfLines
totalLinesInProc = mdl.ProcCountLines(strProc, vbext_pk_Proc)
MsgBox strProc & " Proc already exists. Starts at line " & startline & ", contains " & totalLinesInProc & " lines"
Else
lngReturn = mdl.CreateEventProc("Format", "Detail") ' "format" is the event, Detail is the name of the control
' Insert text into body of procedure.
'mdl.InsertLines lngReturn + 1, vbTab & "MsgBox ""Way so cool!"""
strProcBody = "If vCounter = gRecordsToPrintPerPage Then" & vbCrLf & vbTab & "Me.Section(acDetail).ForceNewPage = 1"
strProcBody = strProcBody & vbCrLf & vbTab & "vCounter = 0 " & vbCrLf & "Else " & vbCrLf & vbTab & "Me.Section(acDetail).ForceNewPage = 0"
strProcBody = strProcBody & vbCrLf & "End if " & vbCrLf & vbTab & "vCounter = vCounter + 1"
mdl.InsertLines lngReturn + 2, strProcBody
'rpt.Section(acReportHeader).Visible = True
End If
' MsgBox mdl.CountOfLines
strProc = "Report_Open"
If ProcedureExistsInModule(strProc, "Report_" & rptName) Then
' MsgBox "Report_Open Proc already exists"
startline = mdl.ProcStartLine(strProc, vbext_pk_Proc)
totalLinesInModule = mdl.CountOfLines
totalLinesInProc = mdl.ProcCountLines(strProc, vbext_pk_Proc)
MsgBox strProc & " Proc already exists. Starts at line " & startline & ", contains " & totalLinesInProc & " lines"
Else
lngReturn = mdl.CreateEventProc("Open", "Report")
' Insert text into body of procedure.
'mdl.InsertLines lngReturn + 1, vbTab & "MsgBox ""Way so cool!"""
mdl.InsertLines lngReturn + 1, vbTab & " vCounter=1 "
'rpt.Section(acReportHeader).Visible = True
End If
'MsgBox mdl.CountOfLines
DoCmd.Save acReport, rptName
DoCmd.Close acReport, rptName, acSaveYes
DoCmd.Restore
'DoCmd.OpenReport rptName, acViewPreview
DoCmd.OpenReport rptName, acViewDesign
DoCmd.Close acReport, rptName, acSaveYes
End Sub
This is a complimentary article written by the MAARS team for the MAARS user community. Code in this article drives the operation of MAARS (MS Access Application wRiting Software). MAARS is an intelligent automation program that speeds up MS Access Application Development by 10x, 20x or 100x times. To learn more about MAARS, click here.
Disclaimer:
Some information included in this article may have been sourced from other publicly available websites and blogs. In such cases, credit goes to those authors for the original ideas and thoughts, but we do take credit for putting valuable information together and improve the efficiency of other office developers.