Option Compare Database
Option Explicit

Sub createThisReport(cFormName As String)
'NL de verstekcode (cmdBtnView) zoekt een rapport dat 'rep'<cformname> heet
'laten we dat eerst maar maken.
'EN default code searches a report named 'rep'<formname>
'let's create that first

'NL NB Deze code is een aangepaste kopie van createThisForm - zoals je begrijpt
'EN Note: this module is adapted from createThisForm - as you may guess
Dim rs As Recordset
Dim R As Report
Dim cHoldName As String
Dim bSucc As Boolean
Dim db As Database
On Error GoTo err_CreateThisReport
   Set db = OpenDatabase(GetPathOf(CurrentDb.Name) & GetSysItem("projecttitle") & ".mdb")
   Set rs = CurrentDb.OpenRecordset("select * from USysForms where formname='" & cFormName & "'")
   Set R = CreateReport
   cHoldName = R.Name
   RunCommand acCmdPageHdrFtr 'NL staat bij rapport standaard aan
      'EN expecting to turn it off that way
   DoCmd.Close acReport, cHoldName, acSaveYes
   DoCmd.Rename "rep" & cFormName, acReport, cHoldName
   DoCmd.OpenReport "rep" & cFormName, acViewDesign
   Set R = Reports("rep" & cFormName)
   R.GridX = 5
   R.GridY = 5
   R.Caption = cFormName
   If IsNull(rs!recordsource) Then
      R.recordsource = rs!source
   Else
      R.recordsource = rs!recordsource
   End If
   'NL veldjes toevoegen?
   'EN add fields?
   bSucc = CreateReportControlsHere(R, rs!source, rs!layout, False, "nooit")
   'NL mooi. Opslaan
   'EN good. Save
   DoCmd.Close acReport, R.Name, acSaveYes
exit_CreateThisReport:
   Set R = Nothing
   db.Close
   Set db = Nothing
   rs.Close
   Set rs = Nothing
   Exit Sub
err_CreateThisReport:
   Select Case Err
   Case er2007ObjectIsOpen '(nota bene)
      If MsgBox("Dit Report bestaat al, en is open. Vervangen?", vbYesNo + vbQuestion + vbDefaultButton2) = vbYes Then
      'EN If MsgBox("This report exists, and is open. Replace anyway?", vbYesNo + vbQuestion + vbDefaultButton2) = vbYes Then
         DoCmd.Close acReport, "rep" & cFormName, acSaveNo
         DoCmd.DeleteObject acReport, "rep" & cFormName
         Resume
      Else
         Resume exit_CreateThisReport
      End If
   Case Else
      Select Case Standaardfout("CreateThisReport")
      Case vbAbort
         Resume exit_CreateThisReport
      Case vbRetry
         Resume
      Case vbIgnore
         Resume Next
      End Select
   End Select
End Sub

Function CreateReportControlsHere(R As Report, cTabel As String, cLayout As String, withButtons As Boolean, subformcontainer As Variant) As Boolean
'labels in header tenzij single AND notabs
'controls in detail tenzij tabs
'labeltop klein tenzij header{single AND notabs} AND buttons, dan onder de buttons

'condities           lbl   ctl   initTop (ctl)
'sing nobutt notab   D     D     klein
'sing   butt notab   D     D     klein
'sing nobutt   tab   H     H     klein
'sing   butt   tab   H     H     groot
'cont nobutt notab   H     D     klein klein
'cont   butt notab   H     D     groot klein
'cont nobutt   tab   H     H     klein
'cont   butt   tab   H     H     groot

Dim c As Control, l As Label
Dim nType As Long, nSize As Long
Dim nCType As Long
Dim rs As Recordset
Dim lblLeft As Single, lblTop As Single
Dim ctlHeight As Single 'Width ontbreekt. Labels met SizeToFit, controls uit de DD
Dim ctlLeft As Single, ctlTop As Single
Dim horSep As Single, verSep As Single 'op 0 zetten voor tabel/kolom
Dim ctlSection As Long, lblSection As Long
Dim curControlWid As Single
Dim withTabs As Boolean
On Error GoTo err_CreateControlsHere
   CreateReportControlsHere = False
   withTabs = Nz(subformcontainer, "niets") = fmSubformTabs
   'bepalen of het Report een header moet
   If cLayout = fmLayoutContinuous Or withTabs Or withButtons Then
      SetReportHeader R, True
      R.Section(acFooter).height = 0 'ik heb geen footer nodig
   End If
   'bepalen in welke sectie de controls komen
   'labels in header tenzij single AND notabs
   'controls in detail tenzij tabs
   If withTabs Then
      ctlSection = acHeader
      lblSection = acHeader
   Else
      ctlSection = acDetail
      Select Case cLayout
      Case fmLayoutSingle
         lblSection = acDetail
      Case fmLayoutContinuous
         lblSection = acHeader
      End Select
   End If
   'startposities bepalen:
   'labeltop klein tenzij (cont OR tabs) AND buttons
   'controltop klein tenzij tabs AND buttons
   'labelleft klein
   'controlleft single:groot, cont:klein
   If withButtons Then
      If withTabs Then
         lblTop = 1.2
         ctlTop = 1.2
      Else
         If cLayout = fmLayoutContinuous Then
            lblTop = 1.2
         Else
            lblTop = 0.2
         End If
         ctlTop = 0.2
      End If
   Else
      lblTop = 0
      ctlTop = 0
   End If
   lblLeft = 0.4
   If cLayout = fmLayoutContinuous Then
      ctlLeft = 0.4
      verSep = 0
      horSep = 1
   Else
      ctlLeft = 3
      horSep = 0
      verSep = 0.5
   End If
   ctlHeight = 0.423 'hard-coded, kan dus ook wel constant
   R.Section(acHeader).height = (lblTop + ctlHeight + 0.2) * tWips 'wordt wel afgevangen hoor
   'velden aanmaken
   Set rs = CurrentDb.OpenRecordset("select * from USys_Q_CreateInterfaceFields where tabel='" & cTabel & "'")
   Do Until rs.EOF
      getAccessDatatype rs!Datatype, nType, nSize
      Select Case nType
      Case dbBoolean
         nCType = acCheckBox
      Case Else
         nCType = acTextBox
      End Select
      If isForeign(rs!Veld, cTabel) Then
         nCType = acComboBox
      End If
      'datacontrol
      Set c = CreateReportControl(R.Name, nCType, ctlSection, , rs!Veld)
      c.Left = ctlLeft * tWips
      c.top = ctlTop * tWips
      c.width = rs!dispWidth * tWips
      c.height = ctlHeight * tWips
      c.Name = "ctl" & rs!Veld
      If nCType = acComboBox Then
         c.RowSource = SetupQuery(rs!Veld)
         c.ColumnCount = 2
         c.ColumnWidths = "0;"
      End If
      c.CanGrow = True
      'bijbehorend label
      Set l = CreateReportControl(R.Name, acLabel, lblSection, IIf(ctlSection = lblSection, c.Name, ""))
      l.Caption = rs!Veld
      l.SizeToFit
      l.Left = lblLeft * tWips
      l.top = lblTop * tWips
      l.height = ctlHeight * tWips
      'volgende plek uitrekenen
      If l.width > c.width Then
         curControlWid = l.width / tWips
         c.width = l.width 'maak dat control ook maar groter dan
      Else
         curControlWid = rs!dispWidth
      End If
      ctlTop = ctlTop + verSep
      lblTop = lblTop + verSep
      ctlLeft = ctlLeft + horSep * curControlWid
      lblLeft = lblLeft + horSep * curControlWid
      '
      rs.MoveNext
   Loop
   R.Section(ctlSection).height = (ctlTop + ctlHeight + 0.2) * tWips 'laatste control bepaalt sectiehoogte
   CreateReportControlsHere = True
exit_CreateControlsHere:
   On Error Resume Next
   rs.Close
   Set rs = Nothing
   Exit Function
err_CreateControlsHere:
   Select Case Err
   Case er2462InvalidSection
      Resume Next 'niet-bestaande header resizen? nou en
   Case Else
      Select Case Standaardfout("CreateControlsHere")
      Case vbAbort
         Resume exit_CreateControlsHere
      Case vbRetry
         Resume
      Case vbIgnore
         Resume Next
      End Select
   End Select
End Function

Sub SetReportHeader(F As Report, bAanzetten As Boolean)
Dim S As Section
On Error Resume Next
   Set S = F.Section(acHeader)
   If bAanzetten Then
      'bij fout toevoegen
      If Err > 0 Then
         RunCommand acCmdReportHdrFtr
      End If
   Else
      'bij geen fout verwijderen
      If Err = 0 Then
         RunCommand acCmdReportHdrFtr
      End If
   End If
End Sub