Option Compare Database
Option Explicit

Private Const tWips = 567

Const vbDarkGrey = &H808080 'this will be the backcolor for field #1: locked
Const deForm = "fMaakSub" 'name of the editor form
Const deTabel = "tMaak" 'name of the temp table (not multi user-proof)
Const deActionQuery = "qMaak"
'SELECT * INTO tMaak
'FROM qMaak_bron;
Const deKruisQuery = "qMaak_bron"
'PARAMETERS pObjType Text;
'TRANSFORM First(ObjectVeldWaarde.veldWaarde) AS EersteVanveldWaarde
'SELECT Object.objectNaam
'FROM Object INNER JOIN ObjectVeldWaarde ON Object.objKey = ObjectVeldWaarde.objKey
'WHERE (((ObjectVeldWaarde.objType) = [pObjType]))
'GROUP BY Object.objectNaam
'PIVOT ObjectVeldWaarde.veldNaam;

Sub Prepare(cTable As String, cColField As String, cRowHeadField As String, cValueField As String)
'#Ext: aanpassen voor query zoals boven gedocumenteerd (gebaseerd op join ipv enkele tabel)
Dim cSQL As String
Dim qd As QueryDef
   cSQL = ""
   cSQL = cSQL & vbNewLine & "TRANSFORM First(" & cTable & "." & cValueField & ") AS EersteVanveldWaarde"
   cSQL = cSQL & vbNewLine & "SELECT " & cTable & "." & cRowHeadField
   cSQL = cSQL & vbNewLine & "FROM " & cTable
   cSQL = cSQL & vbNewLine & "GROUP BY " & cTable & "." & cRowHeadField
   cSQL = cSQL & vbNewLine & "PIVOT " & cTable & "." & cColField & ";"
   Set qd = CurrentDb.CreateQueryDef(deKruisQuery, cSQL)
   cSQL = "SELECT * INTO " & deTabel & " FROM " & deKruisQuery
   Set qd = CurrentDb.CreateQueryDef(deActionQuery, cSQL)
   trustedCompile cTable, cColField, cValueField
End Sub

Sub Compile()
Dim cSQL As String
Dim cTable As String
Dim cWaardeVeld As String
Dim cKolomVeld As String
Dim nStart As Long, nLen As Long
   cSQL = CurrentDb.QueryDefs(deKruisQuery).SQL
   'find source table in FROM component
   nStart = InStr(cSQL, "FROM") + 5
   nLen = 1
   Do Until InStr("abcdefghijklmnopqrstuvwxyz0123456789", MID(cSQL, nStart + nLen, 1)) = 0
      nLen = nLen + 1
   Loop
   cTable = MID(cSQL, nStart, nLen)
   'find source field in this expression:
   'TRANSFORM First(ObjectVeldWaarde.veldWaarde) AS
   nStart = InStr(cSQL, "(" & cTable) + Len(cTable) + 2 'haakje en punt ook overslaan
   nLen = InStr(nStart, cSQL, ")") - nStart
   cWaardeVeld = MID(cSQL, nStart, nLen)
   'find column name in this expression:
   'PIVOT ObjectVeldWaarde.veldNaam;
   nStart = InStr(cSQL, "PIVOT") + Len(cTable) + Len("pivot ") + 1 'just before the dot
   nLen = Len(cSQL) - nStart - 2 'minus two, ignore comma as well
   cKolomVeld = MID(cSQL, nStart, nLen)
   trustedCompile cTable, cKolomVeld, cWaardeVeld
End Sub

Sub trustedCompile(cTable As String, cKolomVeld As String, cWaardeVeld As String)
Dim db As Database
Dim td As TableDef
Dim fd As Field
Dim txt As TextBox
Dim btn As CommandButton
Dim M As Module
Dim nLeft As Single
   Set db = CurrentDb
   If SysCmd(acSysCmdGetObjectState, acForm, deForm) = acObjStateOpen Then DoCmd.Close acForm, deForm
   DoCmd.DeleteObject acTable, deTabel
   db.Execute deActionQuery
   'create the form
   DoCmd.OpenForm deForm, acDesign
   DoCmd.OpenModule "form_" & deForm
   Set M = Modules("form_" & deForm)
   With Forms!fMaaksub
      'delete previous
      Do Until .Section(acDetail).Controls.Count = 0
         DeleteControl deForm, .Controls(0).name
      Loop
      M.DeleteLines 1, M.CountOfLines
      'store source table name
      Set txt = CreateControl(deForm, acTextBox, acHeader)
      txt.name = "originalTable"
      txt.Left = 0 * tWips
      txt.width = tWips
      txt.BackColor = vbDarkGrey
      txt.Visible = False
      txt.ControlSource = "=""" & cTable & """"
      'store data field of source table
      Set txt = CreateControl(deForm, acTextBox, acHeader)
      txt.name = "datafield"
      txt.Left = 1 * tWips
      txt.width = tWips
      txt.BackColor = vbDarkGrey
      txt.Visible = False
      txt.ControlSource = "=""" & cWaardeVeld & """"
      'store column field
      Set txt = CreateControl(deForm, acTextBox, acHeader)
      txt.name = "columnfield"
      txt.Left = 2 * tWips
      txt.width = tWips
      txt.BackColor = vbDarkGrey
      txt.Visible = False
      txt.ControlSource = "=""" & cKolomVeld & """"
      'retrieve fields
      Set td = db.TableDefs(deTabel)
      nLeft = 0
      For Each fd In td.Fields
         'datacontrol
         Set txt = CreateControl(deForm, acTextBox, acDetail)
         txt.name = "ctl" & fd.name
         txt.Left = nLeft
         txt.width = 2 * tWips
         txt.height = 0.423 * tWips
         txt.top = 0
         txt.ControlSource = fd.name
         setHandler txt, M, "afterupdate"
         If nLeft = 0 Then
            txt.Enabled = False 'first control means row name, not editable
         Else
            'sorter button
            Set btn = CreateControl(deForm, acCommandButton, acHeader)
            btn.name = "btn" & fd.name
            btn.Left = txt.Left
            btn.width = txt.width
            btn.top = 0.2 * tWips
            btn.height = 0.6 * tWips
            btn.Caption = fd.name
            setHandler btn, M, "click"
         End If
         'shift next one
         nLeft = nLeft + 2 * tWips
      Next
      Set td = Nothing
   End With
   DoCmd.Close acForm, deForm, acSaveYes
   Set db = Nothing
End Sub

Sub setHandler(ctl As Control, M As Module, cEvt As String)
Dim nLine As Long
   Select Case cEvt
   Case "afterupdate"
      nLine = M.CreateEventProc("AfterUpdate", ctl.name)
      M.InsertLines nLine + 1, "   writeDatabase " & ctl.name
   Case "click"
      nLine = M.CreateEventProc("Click", ctl.name)
      M.InsertLines nLine + 1, "   sortTable " & ctl.name
   End Select
End Sub

Public Sub writeDatabase(ctl As Control)
'NL wordt aangeroepen vanuit AfterUpdate in een veld van het editor-form
'EN is called from AfterUpdate in an editor form field

'NL neem aan: ctl.name is de naam van een kolom, zit in een form met als control 0 de rijnaam
'EN assume: ctl.name is the name of a column, sits in a form having the row name in control 0
Dim cSQL As String
Dim F As Form
   Set F = ctl.Parent
   cSQL = "UPDATE " & F.originalTable & " SET " & F.datafield & "="
   cSQL = cSQL & getQuotedValue(ctl.ControlSource, ctl.Value) & " WHERE "
   cSQL = cSQL & F.Section(acDetail).Controls(0).ControlSource & "='"
   cSQL = cSQL & F.Section(acDetail).Controls(0) & "' and " & F.columnfield & "='" & ctl.ControlSource & "'"
   CurrentDb.Execute cSQL
End Sub

Public Sub sortTable(ctl As Control)
'NL wordt aangeroepen vanuit Click van een sorteerknop op het editor-form
'EN is called from the sorter button's Click on the editor form
   With ctl.Parent
      .OrderBy = MID(ctl.name, 4)
      .OrderByOn = True
   End With
End Sub

Function getQuotedValue(cVeld As String, cWaarde As String) As String
'homework. Depending on the data type, wrap the value in nothing (numerical), quotes (text) or hashes (dates)
   getQuotedValue = "'" & cWaarde & "'"
End Function