Ok I have not got much time so I am just dumping the code with a few words of explanation. My field names are listed in an external ini accessable using function profilegetitem (do a search on forum)
[report1]
Output=Preview;Print
Caption=Summary List
orientation=landscape
text0=lname
text1=iname
text2=cause
text3=ddate
text4=value
sortOrder=ddate
I also have a table which lists all the field names against their labels and types
Now for the code. I will attempt to remove anything irrelevant!
Private Sub cmdReport1_Click()
Dim rpt As Report
Dim txtReport As String
Dim txtOrientation As String
appPath = Left(CurrentDb.Name, Len(CurrentDb.Name) - Len(Dir(CurrentDb.Name)))
txtReport = Me.ComboReports
txtOrientation = ProfileGetItem(txtReport, "orientation", "", appPath & "config\control.ini")
Dim iNow As Integer
Dim letterNow As String
Dim tempNow As String
For iNow = 1 To Len(CStr(Now)) + 1
Do Until iNow = Len(CStr(Now)) + 1
letterNow = Mid(CStr(Now), iNow, 1)
If ((letterNow = ":") Or (letterNow = "/") Or (letterNow = " ")) Then
Else
tempNow = tempNow + letterNow
End If
iNow = iNow + 1
Loop
Next iNow
tempNow = appPath & "config\cdms" & tempNow & Chr(46) & "csv"
If ObjectExists("report", txtReport) Then
If CurrentProject.AllReports(txtReport).IsLoaded Then
DoCmd.Close acReport, txtReport, acSaveNo
Else
End If
DoCmd.DeleteObject acReport, txtReport
Else
End If
'Open report in design view to write properties to objects
Application.Echo False
Set rpt = CreateReport
'this saves it with a name -txtreport is variable
DoCmd.Save , txtReport
DoCmd.OpenReport txtReport, acDesign
'The next few lines don't work in office 2000 only 2003
' With Reports(txtReport).Printer
' If txtOrientation = "portrait" Then
'.Orientation = acPRORPortrait
'ElseIf txtOrientation = "landscape" Then
'.Orientation = acPRORLandscape
'End If
'End With
Const DM_LEGAL = 5
Const DM_PORTRAIT = 1
Const DM_LANDSCAPE = 2
Dim RetVal As Variant
DoCmd.SetWarnings False
If txtOrientation = "portrait" Then
RetVal = CheckCustomPage(txtReport, 28.75 * 21.25, DM_PORTRAIT)
Reports(txtReport).Width = 12240
Else
RetVal = CheckCustomPage(txtReport, 28.75 * 21.25, DM_LANDSCAPE)
Reports(txtReport).Width = 15200
End If
DoCmd.SetWarnings True
Dim ReportWidth As Integer
ReportWidth = Reports(txtReport).Width
'set recordsource
Reports(txtReport).RecordSource = "temp"
Dim i As Integer
Dim TextBox As Control
Dim txtLabel As String
Dim ControlCount As Integer
txtLabel = "dummy"
'assuming you have no more than 20 fields
i = 0
Do While i < 21
txtLabel = ProfileGetItem(txtReport, "text" & i, "", appPath & "config\control.ini")
If txtLabel <> "" Then
ControlCount = ControlCount + 1
Set TextBox = CreateReportControl(txtReport, acTextBox, acDetail, , txtLabel, i * 900, 0, 900, 200)
'deals with dates stored as serial number
If (DLookup("field3", "control", "[field1]='" & txtLabel & "'") = "date") Then
TextBox.ControlSource = "=format(" & txtLabel & ",""dd/mm/yyyy hh:mm:ss"")"
End If
TextBox.Name = "txtbox" & ControlCount
If (DLookup("field3", "control", "[field1]='" & txtLabel & "'") = "date") Or (DLookup("field3", "control", "[field1]='" & txtLabel & "'") = "double") Then
TextBox.TextAlign = 1
Else
End If
'creates the labels in the pageheader
Set TextBox = CreateReportControl(txtReport, acLabel, acPageHeader, , DLookup("field2", "control", "[field1]='" & txtLabel & "'"), i * 900, 700, 400, 200)
TextBox.Name = "label" & ControlCount
i = i + 1
Loop
Set TextBox = CreateReportControl(txtReport, acLabel, acPageHeader, , , 2000, 200, 4000, 700)
TextBox.Name = "LabelCaption"
TextBox.Caption = ProfileGetItem("general", "Progname", "", appPath & "config\control.ini") & " " & Me.ComboReports.Column(1)
Set TextBox = CreateReportControl(txtReport, acTextBox, acPageFooter, , , 2000, 200, 4000, 700)
TextBox.Name = "LabelFooter"
TextBox.ControlSource = "=date()"
ReportWidth = Reports(txtReport).Width
Reports(txtReport).Detail.Height = 200
i = 1
Do Until i = ControlCount + 1
Dim Ctl As String
Ctl = "txtbox" & i
Reports(txtReport)(Ctl).Width = ((ReportWidth) / (ControlCount)) - 200
Reports(txtReport)(Ctl).Left = (((ReportWidth) / (ControlCount)) - 200) * (i - 1)
Ctl = "label" & i
Reports(txtReport)(Ctl).FontWeight = 600
Reports(txtReport)(Ctl).FontUnderline = True
Reports(txtReport)(Ctl).Width = ((ReportWidth) / (ControlCount)) - 200
Reports(txtReport)(Ctl).Left = (((ReportWidth) / (ControlCount)) - 200) * (i - 1)
i = i + 1
Debug.Print Reports(txtReport)(Ctl).Left
Debug.Print Reports(txtReport)(Ctl).Width
Loop
Dim varGroupLevel As Variant
Dim txtSort As String
txtSort = ProfileGetItem(txtReport, "sortorder", "", appPath & "config\control.ini")
Dim Letter As String
Dim LongSource As String
Dim tempString As String
For i = 1 To Len(txtSort) + 1
Do Until i = Len(txtSort) + 1
Letter = Mid(txtSort, i, 1)
If Letter = ";" Then
varGroupLevel = CreateGroupLevel(txtReport, tempString, False, False)
tempString = ""
Else
tempString = tempString + Letter
End If
i = i + 1
Loop
Next i
'note the false values at the end of next line - allows sorting without a groupheader etc
varGroupLevel = CreateGroupLevel(txtReport, tempString, False, False)
' This sets height of header/footer sections.
'Reports(txtReport).Section(acGroupLevel1Header).Height = 0
'This makes header/footer sections invisible
'Reports(txtReport).Section(acGroupLevel1Header).Visible = False
Set TextBox = CreateReportControl(txtReport, acImage, acPageHeader, , , , , 600, 600)
TextBox.Picture = appPath & ProfileGetItem("general", "splash", "none", appPath & "config\control.ini")
TextBox.PictureType = 1
TextBox.SizeMode = 1
'Reports(txtReport).Section(acGroupLevel1Footer).Height = 0
Reports(txtReport).Caption = ProfileGetItem(txtReport, "caption", "", appPath & "\config\control.ini")
'Close design view without prompting to save changes
DoCmd.Close acReport, txtReport, acSaveYes
Application.Echo True
DoCmd.SetWarnings False
'Open finished report in preview view
If Me.ComboOutput = "preview" Then
DoCmd.OpenReport txtReport, acPreview
DoCmd.RunCommand acCmdZoom100
DoCmd.Maximize
ElseIf Me.ComboOutput = "Print" Then
DoCmd.OpenReport txtReport, acViewNormal
End If
Exit_Close_Click:
Exit Sub
Err_cmd_Click:
MsgBox Err.Description
Resume Exit_Close_Click
DoCmd.SetWarnings True
End Sub