Option Compare Database
Option Explicit
Public Sub CallCreateReport()
Dim sTemplateName As String
sTemplateName = "rTemplate2"
CreateCrossTabReport sTemplateName
End Sub
Public Sub CreateCrossTabReport(ByVal sTemplateName As String)
'Coded by Johan Kreszner, MIO-Software Netherlands
'Sets labels and controlsources for dynamic fields
'Only for templates with Pageheader/Footer and detail section
'Extended control settings
Const ExtLabel As String = "Extend_Lbl" 'This corresponds with the dummy control name
Const ExtValue As String = "Extend_Val" 'idem
Dim dbs As DAO.Database
Dim qdf As DAO.QueryDef
Dim fld As DAO.Field
Dim sDynaFldNames() As String
Dim iDynaFldCnt As Integer
Dim prp As Property
Dim rpt As Report
Dim oRpt As AccessObject
Dim lLblWidth As Long
Dim lCtrlWidth As Long
Const lSpacing As Long = 8 'Space between columns
Dim sQName As String
Dim c As Control
'Section properties
'Header
Dim lHeaderHeight As Long
Dim lHeaderBackColor As Long
'Detail section
Dim lDetailHeight As Long
Dim lDetailBackColor As Long
'Footer
Dim lFooterHeight As Long
Dim lFooterBackColor As Long
'Control stuff
Dim vControls() As Variant 'Array to hold all controls
Dim vCtrlProperty() As Variant 'Array to hold all properties of the control
Dim iControlCounter As Integer
Dim iPropertyCounter As Integer
Dim lSection As Long
Dim lCType As Long
Dim iPrpStartLbl As Integer
Dim iPrpEndLbl As Integer
Dim iPrpStartCtrl As Integer
Dim iPrpEndCtrl As Integer
'Array for excluding fields
Dim sExcludeField() As String
Dim sExcludeFields As String
Dim i As Integer
Set dbs = CurrentDb
DoCmd.OpenReport sTemplateName, acViewDesign, , , acWindowNormal
Set rpt = Reports(sTemplateName)
'Fetch Section settings
lHeaderHeight = rpt.Section(acPageHeader).Height
lHeaderBackColor = rpt.Section(acPageHeader).BackColor
lDetailHeight = rpt.Section(acDetail).Height
lDetailBackColor = rpt.Section(acDetail).BackColor
lFooterHeight = rpt.Section(acPageFooter).Height
lFooterBackColor = rpt.Section(acPageFooter).BackColor
'Fetch recordsource
sQName = rpt.RecordSource
'load controls with properties into array
iPropertyCounter = 0
With rpt
ReDim vControls(1, .Controls.Count - 1)
For iControlCounter = 0 To UBound(vControls, 2)
vControls(0, iControlCounter) = iPropertyCounter 'Start index for property
For Each prp In .Controls(iControlCounter).Properties
If Not prp.Name = "Text" Then
ReDim Preserve vCtrlProperty(1, iPropertyCounter)
vCtrlProperty(0, iPropertyCounter) = prp.Name
vCtrlProperty(1, iPropertyCounter) = prp.Value
iPropertyCounter = iPropertyCounter + 1
End If
Next prp
vControls(1, iControlCounter) = iPropertyCounter - 1 'last index for property
Next iControlCounter
End With
'Close template
DoCmd.Close acReport, rpt.Name
'Create new report
Set rpt = CreateReport()
DoCmd.Restore
'Set the recordsource
rpt.RecordSource = sQName
'Format sections
rpt.Section(acPageHeader).Height = lHeaderHeight
rpt.Section(acPageHeader).BackColor = lHeaderBackColor
rpt.Section(acDetail).Height = lDetailHeight
rpt.Section(acDetail).BackColor = lDetailBackColor
rpt.Section(acPageFooter).Height = lFooterHeight
rpt.Section(acPageFooter).BackColor = lFooterBackColor
'Create field array from recordsource
Set qdf = dbs.QueryDefs(sQName)
'Create string with fields to exclude for extention
i = 0
For iPropertyCounter = 0 To UBound(vCtrlProperty, 2)
Select Case vCtrlProperty(0, iPropertyCounter) 'Test for propname
Case "ControlSource"
ReDim Preserve sExcludeField(i)
sExcludeField(i) = vCtrlProperty(1, iPropertyCounter)
i = i + 1
End Select
Next iPropertyCounter
sExcludeFields = Join(sExcludeField, ", ")
'Get the fieldsnames for extended controls <> controls with recordsource
iDynaFldCnt = 0
For Each fld In qdf.Fields
Select Case InStr(1, sExcludeFields, fld.Name, vbTextCompare)
Case Is <> 0
'skip
Case Else
ReDim Preserve sDynaFldNames(iDynaFldCnt)
sDynaFldNames(iDynaFldCnt) = fld.Name
iDynaFldCnt = iDynaFldCnt + 1
End Select
Next fld
'Create controls
With rpt
For iControlCounter = 0 To UBound(vControls, 2)
For iPropertyCounter = vControls(0, iControlCounter) To vControls(1, iControlCounter)
Select Case vCtrlProperty(0, iPropertyCounter)
Case "Section"
lSection = vCtrlProperty(1, iPropertyCounter)
Case "ControlType"
lCType = vCtrlProperty(1, iPropertyCounter)
End Select
Next iPropertyCounter
Set c = CreateReportControl(rpt.Name, lCType, lSection, , , 1, 1, 1, 1)
With c
For iPropertyCounter = vControls(0, iControlCounter) To vControls(1, iControlCounter)
Select Case vCtrlProperty(0, iPropertyCounter)
Case "EventProcPrefix", "ControlType", "Section", "TextFormat"
'skip
Case Else
.Properties(vCtrlProperty(0, iPropertyCounter)) = vCtrlProperty(1, iPropertyCounter)
End Select
Next iPropertyCounter
End With
Next iControlCounter
End With
'Now all controls are copied from template,
'Expand the controls for the crosstab query headers
'Set prp indexes
For iControlCounter = 0 To UBound(vControls, 2)
For iPropertyCounter = vControls(0, iControlCounter) To vControls(1, iControlCounter)
Select Case vCtrlProperty(0, iPropertyCounter)
Case "Name"
If vCtrlProperty(1, iPropertyCounter) = ExtLabel Then
iPrpStartLbl = vControls(0, iControlCounter)
iPrpEndLbl = vControls(1, iControlCounter)
End If
If vCtrlProperty(1, iPropertyCounter) = ExtValue Then
iPrpStartCtrl = vControls(0, iControlCounter)
iPrpEndCtrl = vControls(1, iControlCounter)
End If
End Select
Next iPropertyCounter
Next iControlCounter
lLblWidth = rpt.Controls(ExtLabel).Width
lCtrlWidth = rpt.Controls(ExtValue).Width
With rpt
For iDynaFldCnt = 0 To UBound(sDynaFldNames)
'Label properties
Set c = CreateReportControl(rpt.Name, acLabel, acPageHeader, , , 1, 1, 1, 1)
With c
For iPropertyCounter = iPrpStartLbl To iPrpEndLbl
Select Case vCtrlProperty(0, iPropertyCounter)
Case "Left"
.Properties(vCtrlProperty(0, iPropertyCounter)) = vCtrlProperty(1, iPropertyCounter) + lSpacing
vCtrlProperty(1, iPropertyCounter) = vCtrlProperty(1, iPropertyCounter) + lLblWidth
Case "EventProcPrefix", "ControlType", "Section"
'skip
Case "Name"
.Properties(vCtrlProperty(0, iPropertyCounter)) = "lbl" & sDynaFldNames(iDynaFldCnt)
Case Else
.Properties(vCtrlProperty(0, iPropertyCounter)) = vCtrlProperty(1, iPropertyCounter)
End Select
Next iPropertyCounter
.Caption = sDynaFldNames(iDynaFldCnt)
End With
'Value control properties
Set c = CreateReportControl(rpt.Name, acTextBox, acDetail, , , 1, 1, 1, 1)
With c
For iPropertyCounter = iPrpStartCtrl To iPrpEndCtrl
Select Case vCtrlProperty(0, iPropertyCounter)
Case "Left"
.Properties(vCtrlProperty(0, iPropertyCounter)) = vCtrlProperty(1, iPropertyCounter) + lSpacing
vCtrlProperty(1, iPropertyCounter) = vCtrlProperty(1, iPropertyCounter) + lCtrlWidth
Case "EventProcPrefix", "ControlType", "Section"
'skip
Case "Name"
.Properties(vCtrlProperty(0, iPropertyCounter)) = "txt" & sDynaFldNames(iDynaFldCnt)
Case Else
.Properties(vCtrlProperty(0, iPropertyCounter)) = vCtrlProperty(1, iPropertyCounter)
End Select
Next iPropertyCounter
.ControlSource = sDynaFldNames(iDynaFldCnt)
End With
Next iDynaFldCnt
End With
'Delete the dummy controls
DeleteReportControl rpt.Name, ExtLabel
DeleteReportControl rpt.Name, ExtValue
End Sub
