Creating a dynamic crosstab report

Option Compare Database
Option Explicit
Public Sub CallReportOpen()
Const sReportName As String = "[B][COLOR=red]NameOFTemplateReportHere[/COLOR][/B]"
CreateDynaControls sReportName
End Sub
Public Sub CreateDynaControls(ByVal sReportName As String)
'Code by Johan Kreszner, MIO-Software Netherlands
'Sets labels and controlsources for dynamic fields
 
Dim sNewReportName As String
Dim dbs As DAO.Database
Dim qdf As DAO.QueryDef
Dim fld As DAO.Field
 
Dim sDynaFldNames() As String
Dim iDynaFldCnt As Integer
Dim vLblPrp() As Variant
Dim iLblPrpCnt As Integer
Dim vCtlPrp() As Variant
Dim iCtlPrpCnt As Integer
Dim prp As Property
Dim rpt As Report
Dim oRpt As AccessObject
Dim lLblWidth As Long
Dim lCtrlWidth As Long
Dim lSpacing As Long
Dim sQName As String
Dim c As Control
Dim cNewLabel As Control
Dim cNewTxtBox As Control
Set dbs = CurrentDb
sNewReportName = "Temp_" & sReportName
'Check if tempreport exists and delete if so
For Each oRpt In CurrentProject.AllReports
        If oRpt.Name = sNewReportName Then
            DoCmd.DeleteObject acReport, sNewReportName
            Exit For
        End If
Next oRpt
'Create new instance of template report
DoCmd.CopyObject , sNewReportName, acReport, sReportName
'Open new instance in designview
DoCmd.OpenReport sNewReportName, acViewDesign, , , acHidden
Set rpt = Reports(sNewReportName)
lSpacing = 8 'Space between columns
With rpt
    Set c = .Controls("lblAmtY") 'name of the label
        'load properties label
        iLblPrpCnt = 0
        For Each prp In c.Properties
             ReDim Preserve vLblPrp(1, iLblPrpCnt)
               vLblPrp(0, iLblPrpCnt) = prp.Name
               vLblPrp(1, iLblPrpCnt) = prp.Value
               iLblPrpCnt = iLblPrpCnt + 1
               If prp.Name = "Width" Then lLblWidth = prp.Value
        Next prp
        'Delete dummy control
        DeleteReportControl rpt.Name, c.Name
    Set c = .Controls("valAmtY") 'name of the textbox control
        'load properties textbox
        iCtlPrpCnt = 0
        For Each prp In c.Properties
          If Not prp.Name = "Text" Then 'Skip text as this is not available in designmode
            ReDim Preserve vCtlPrp(1, iCtlPrpCnt)
            vCtlPrp(0, iCtlPrpCnt) = prp.Name
            vCtlPrp(1, iCtlPrpCnt) = prp.Value
            iCtlPrpCnt = iCtlPrpCnt + 1
            If prp.Name = "Width" Then lCtrlWidth = prp.Value
         End If
        Next prp
        'Delete dummy control
       DeleteReportControl rpt.Name, c.Name
End With
sQName = rpt.RecordSource
Set qdf = dbs.QueryDefs(sQName)
iDynaFldCnt = 0
For Each fld In qdf.Fields
        If InStr(1, fld.Name, sTrail, vbTextCompare) <> 0 Then 'Note: sTrail is a constant, " - Amt in (US$)"
        ReDim Preserve sDynaFldNames(iDynaFldCnt)
        sDynaFldNames(iDynaFldCnt) = fld.Name
        iDynaFldCnt = iDynaFldCnt + 1
        End If
Next fld
'create new controls
For iDynaFldCnt = 0 To UBound(sDynaFldNames)
    'Label has to be in the header of the report
    Set cNewLabel = CreateReportControl(rpt.Name, acLabel, acPageHeader, , , 1, 1, 1, 1)
    With cNewLabel
           For iLblPrpCnt = 0 To UBound(vLblPrp, 2)
 
           Select Case vLblPrp(0, iLblPrpCnt)
 
               Case "Left"
                    Debug.Print vLblPrp(0, iLblPrpCnt) & vbTab & vbTab & vLblPrp(1, iLblPrpCnt)
                    .Properties(vLblPrp(0, iLblPrpCnt)) = vLblPrp(1, iLblPrpCnt) + lSpacing
                    vLblPrp(1, iLblPrpCnt) = vLblPrp(1, iLblPrpCnt) + lLblWidth
               Case "EventProcPrefix", "ControlType", "Section"
                    'skip
               Case "Name"
                     .Properties(vLblPrp(0, iLblPrpCnt)) = vLblPrp(1, iLblPrpCnt) & iDynaFldCnt
               Case Else
                 .Properties(vLblPrp(0, iLblPrpCnt)) = vLblPrp(1, iLblPrpCnt)
               End Select
 
           Next iLblPrpCnt
          .Caption = sDynaFldNames(iDynaFldCnt)
    End With
 
    Set cNewTxtBox = CreateReportControl(rpt.Name, acTextBox, acDetail, , , 1, 1, 1, 1)
 
        With cNewTxtBox
            For iCtlPrpCnt = 0 To UBound(vCtlPrp, 2)
 
             Select Case vCtlPrp(0, iCtlPrpCnt)
               Case "Left"
                    Debug.Print vCtlPrp(0, iCtlPrpCnt) & vbTab & vbTab & vCtlPrp(1, iCtlPrpCnt)
                    .Properties(vCtlPrp(0, iCtlPrpCnt)) = vCtlPrp(1, iCtlPrpCnt) + lSpacing
                    vCtlPrp(1, iCtlPrpCnt) = vCtlPrp(1, iCtlPrpCnt) + lLblWidth
               Case "EventProcPrefix", "ControlType", "Section"
                    'skip
               Case "Name"
                     .Properties(vCtlPrp(0, iCtlPrpCnt)) = vCtlPrp(1, iCtlPrpCnt) & iDynaFldCnt
               Case Else
                 .Properties(vCtlPrp(0, iCtlPrpCnt)) = vCtlPrp(1, iCtlPrpCnt)
               End Select
 
 
            Next iCtlPrpCnt
             .ControlSource = sDynaFldNames(iDynaFldCnt)
        End With
Next iDynaFldCnt
DoCmd.OpenReport rpt.Name, acViewPreview
End Sub

Option Compare Database
Option Explicit
Public Sub CallReportOpen()
Const sReportName As String = "[B][COLOR=red]YourReportNameHere[/COLOR][/B]"
CreateDynaControls sReportName
End Sub
Public Sub CreateDynaControls(ByVal sReportName As String)
'Code by Johan Kreszner, MIO-Software Netherlands
'Sets labels and controlsources for dynamic fields

Dim sNewReportName As String
Dim dbs As DAO.Database
Dim qdf As DAO.QueryDef
Dim fld As DAO.Field

Dim sDynaFldNames() As String
Dim iDynaFldCnt As Integer
Dim vLblPrp() As Variant
Dim iLblPrpCnt As Integer
Dim vCtlPrp() As Variant
Dim iCtlPrpCnt As Integer
Dim prp As Property
Dim rpt As Report
Dim oRpt As AccessObject
Dim lLblWidth As Long
Dim lCtrlWidth As Long
Dim lSpacing As Long
Dim sQName As String
Dim c As Control
Dim cNewLabel As Control
Dim cNewTxtBox As Control
Set dbs = CurrentDb
sNewReportName = "Temp_" & sReportName
'Check if tempreport exists and delete if so
For Each oRpt In CurrentProject.AllReports
        If oRpt.Name = sNewReportName Then
            DoCmd.DeleteObject acReport, sNewReportName
            Exit For
        End If
Next oRpt
'Create new instance of template report
DoCmd.CopyObject , sNewReportName, acReport, sReportName
DoCmd.Restore
'Open new instance in designview
DoCmd.OpenReport sNewReportName, acViewDesign, , , acHidden
Set rpt = Reports(sNewReportName)
lSpacing = 8 'Space between columns
With rpt
    Set c = .Controls("lblAmtY") 'name of the label
        'load properties label
        iLblPrpCnt = 0
        For Each prp In c.Properties
             ReDim Preserve vLblPrp(1, iLblPrpCnt)
               vLblPrp(0, iLblPrpCnt) = prp.Name
               vLblPrp(1, iLblPrpCnt) = prp.Value
               iLblPrpCnt = iLblPrpCnt + 1
               If prp.Name = "Width" Then lLblWidth = prp.Value
        Next prp
        'Delete dummy control
        DeleteReportControl rpt.Name, c.Name
    Set c = .Controls("valAmtY") 'name of the textbox control
        'load properties textbox
        iCtlPrpCnt = 0
        For Each prp In c.Properties
          If Not prp.Name = "Text" Then 'Skip text as this is not available in designmode
            ReDim Preserve vCtlPrp(1, iCtlPrpCnt)
            vCtlPrp(0, iCtlPrpCnt) = prp.Name
            vCtlPrp(1, iCtlPrpCnt) = prp.Value
            iCtlPrpCnt = iCtlPrpCnt + 1
            If prp.Name = "Width" Then lCtrlWidth = prp.Value
         End If
        Next prp
        'Delete dummy control
       DeleteReportControl rpt.Name, c.Name
End With
sQName = rpt.RecordSource
Set qdf = dbs.QueryDefs(sQName)
iDynaFldCnt = 0
For Each fld In qdf.Fields
        If InStr(1, fld.Name, sTrail, vbTextCompare) <> 0 Then 'Note: sTrail is a constant, " - Amt in (US$)"
        ReDim Preserve sDynaFldNames(iDynaFldCnt)
        sDynaFldNames(iDynaFldCnt) = fld.Name
        iDynaFldCnt = iDynaFldCnt + 1
        End If
Next fld
'create new controls
For iDynaFldCnt = 0 To UBound(sDynaFldNames)
    'Label has to be in the header of the report
    Set cNewLabel = CreateReportControl(rpt.Name, acLabel, acPageHeader, , , 1, 1, 1, 1)
    With cNewLabel
           For iLblPrpCnt = 0 To UBound(vLblPrp, 2)
           
           Select Case vLblPrp(0, iLblPrpCnt)
           
               Case "Left"
                    .Properties(vLblPrp(0, iLblPrpCnt)) = vLblPrp(1, iLblPrpCnt) + lSpacing
                    vLblPrp(1, iLblPrpCnt) = vLblPrp(1, iLblPrpCnt) + lLblWidth
               Case "EventProcPrefix", "ControlType", "Section"
                    'skip
               Case "Name"
                     .Properties(vLblPrp(0, iLblPrpCnt)) = vLblPrp(1, iLblPrpCnt) & iDynaFldCnt
               Case Else
                 .Properties(vLblPrp(0, iLblPrpCnt)) = vLblPrp(1, iLblPrpCnt)
               End Select
               
           Next iLblPrpCnt
          .Caption = sDynaFldNames(iDynaFldCnt)
    End With
    
    Set cNewTxtBox = CreateReportControl(rpt.Name, acTextBox, acDetail, , , 1, 1, 1, 1)
    
        With cNewTxtBox
            For iCtlPrpCnt = 0 To UBound(vCtlPrp, 2)
            
             Select Case vCtlPrp(0, iCtlPrpCnt)
                Case "Left"
                     .Properties(vCtlPrp(0, iCtlPrpCnt)) = vCtlPrp(1, iCtlPrpCnt) + lSpacing
                     vCtlPrp(1, iCtlPrpCnt) = vCtlPrp(1, iCtlPrpCnt) + lLblWidth
                Case "EventProcPrefix", "ControlType", "Section"
                     'skip
                Case "Name"
                      .Properties(vCtlPrp(0, iCtlPrpCnt)) = vCtlPrp(1, iCtlPrpCnt) & iDynaFldCnt
                Case Else
                  .Properties(vCtlPrp(0, iCtlPrpCnt)) = vCtlPrp(1, iCtlPrpCnt)
                End Select
               
           Next iCtlPrpCnt
             .ControlSource = sDynaFldNames(iDynaFldCnt)
        End With
Next iDynaFldCnt
DoCmd.Save acReport, rpt.Name
DoCmd.Close acReport, rpt.Name
End Sub

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