Option Explicit

' Flat JSON records and quoted ERP TSV. No reference must be enabled.
Public Function LB_Dict() As Object
    Set LB_Dict = CreateObject("Scripting.Dictionary")
    LB_Dict.CompareMode = vbBinaryCompare
End Function

Public Function LB_Copy(ByVal source As Object) As Object
    Dim result As Object, key As Variant
    Set result = LB_Dict()
    For Each key In source.Keys
        result.Add CStr(key), CStr(source(key))
    Next key
    Set LB_Copy = result
End Function

Public Function LB_Get(ByVal obj As Object, ByVal key As String) As String
    If obj.Exists(key) Then LB_Get = CStr(obj(key))
End Function

Public Function LB_SortedKeys(ByVal obj As Object) As Variant
    Dim values() As String, key As Variant, i As Long
    If obj.Count = 0 Then LB_SortedKeys = Array(): Exit Function
    ReDim values(0 To obj.Count - 1)
    For Each key In obj.Keys
        values(i) = CStr(key): i = i + 1
    Next key
    SortStrings values, 0, UBound(values)
    LB_SortedKeys = values
End Function

Private Sub SortStrings(ByRef values() As String, ByVal first As Long, ByVal last As Long)
    Dim low As Long, high As Long, pivot As String, swap As String
    low = first: high = last: pivot = values((first + last) \ 2)
    Do While low <= high
        Do While StrComp(values(low), pivot, vbBinaryCompare) < 0
            low = low + 1
        Loop
        Do While StrComp(values(high), pivot, vbBinaryCompare) > 0
            high = high - 1
        Loop
        If low <= high Then
            swap = values(low): values(low) = values(high): values(high) = swap
            low = low + 1: high = high - 1
        End If
    Loop
    If first < high Then SortStrings values, first, high
    If low < last Then SortStrings values, low, last
End Sub

Public Function LB_Escape(ByVal value As String) As String
    Dim i As Long, n As Long, ch As String, result As String
    For i = 1 To Len(value)
        ch = Mid$(value, i, 1): n = AscW(ch)
        Select Case ch
            Case Chr$(34): result = result & Chr$(92) & Chr$(34)
            Case Chr$(92): result = result & Chr$(92) & Chr$(92)
            Case Else
                If n >= 0 And n < 32 Then
                    result = result & "\u" & Right$("0000" & Hex$(n), 4)
                Else
                    result = result & ch
                End If
        End Select
    Next i
    LB_Escape = result
End Function

Public Function LB_Json(ByVal obj As Object) As String
    Dim key As Variant, result As String
    For Each key In obj.Keys
        If Len(result) > 0 Then result = result & ","
        result = result & Chr$(34) & LB_Escape(CStr(key)) & Chr$(34) & ":" & Chr$(34) & LB_Escape(CStr(obj(key))) & Chr$(34)
    Next key
    LB_Json = "{" & result & "}"
End Function

Private Sub SkipSpace(ByVal s As String, ByRef p As Long)
    Do While p <= Len(s)
        If InStr(1, " " & vbTab & vbCr & vbLf, Mid$(s, p, 1), vbBinaryCompare) = 0 Then Exit Do
        p = p + 1
    Loop
End Sub

Private Function ReadString(ByVal s As String, ByRef p As Long) As String
    Dim ch As String, result As String, hexValue As String, n As Long
    If Mid$(s, p, 1) <> Chr$(34) Then Err.Raise 5, , "JSON: Zeichenfolge erwartet."
    p = p + 1
    Do While p <= Len(s)
        ch = Mid$(s, p, 1): p = p + 1
        If ch = Chr$(34) Then ReadString = result: Exit Function
        If ch = Chr$(92) Then
            ch = Mid$(s, p, 1): p = p + 1
            Select Case ch
                Case Chr$(34), Chr$(92), "/": result = result & ch
                Case "b": result = result & Chr$(8)
                Case "f": result = result & Chr$(12)
                Case "n": result = result & vbLf
                Case "r": result = result & vbCr
                Case "t": result = result & vbTab
                Case "u"
                    hexValue = Mid$(s, p, 4)
                    If Len(hexValue) <> 4 Or hexValue Like "*[!0-9a-fA-F]*" Then Err.Raise 5, , "JSON: Unicode-Escape ungueltig."
                    n = CLng("&H" & hexValue): If n > 32767 Then n = n - 65536
                    result = result & ChrW$(n): p = p + 4
                Case Else: Err.Raise 5, , "JSON: Escape ungueltig."
            End Select
        Else
            If AscW(ch) >= 0 And AscW(ch) < 32 Then Err.Raise 5, , "JSON: Steuerzeichen ungueltig."
            result = result & ch
        End If
    Loop
    Err.Raise 5, , "JSON: Zeichenfolge nicht abgeschlossen."
End Function

Public Function LB_ParseJson(ByVal s As String) As Object
    Dim obj As Object, p As Long, key As String, value As String, start As Long, re As Object
    Set obj = LB_Dict(): p = 1: SkipSpace s, p
    If Mid$(s, p, 1) <> "{" Then Err.Raise 5, , "JSON: Objekt erwartet."
    p = p + 1: SkipSpace s, p
    If Mid$(s, p, 1) = "}" Then p = p + 1: GoTo Complete
    Do
        SkipSpace s, p: key = ReadString(s, p): SkipSpace s, p
        If Mid$(s, p, 1) <> ":" Then Err.Raise 5, , "JSON: Doppelpunkt fehlt."
        p = p + 1: SkipSpace s, p
        If Mid$(s, p, 1) = Chr$(34) Then
            value = ReadString(s, p)
        Else
            start = p
            Do While p <= Len(s)
                If InStr(1, ",}" & vbCr & vbLf & vbTab & " ", Mid$(s, p, 1), vbBinaryCompare) > 0 Then Exit Do
                p = p + 1
            Loop
            value = Mid$(s, start, p - start)
            Set re = CreateObject("VBScript.RegExp")
            re.Pattern = "^-?(0|[1-9][0-9]*)(\.[0-9]+)?([eE][+-]?[0-9]+)?$"
            If Not re.Test(value) Then Err.Raise 5, , "JSON: Nur Zeichenfolgen und Zahlen erlaubt."
        End If
        If obj.Exists(key) Then Err.Raise 5, , "JSON: Doppelter Schluessel."
        obj.Add key, value: SkipSpace s, p
        If Mid$(s, p, 1) = "}" Then p = p + 1: Exit Do
        If Mid$(s, p, 1) <> "," Then Err.Raise 5, , "JSON: Komma fehlt."
        p = p + 1
    Loop
Complete:
    SkipSpace s, p
    If p <= Len(s) Then Err.Raise 5, , "JSON: Unerwartete Zeichen nach Objekt."
    Set LB_ParseJson = obj
End Function

Public Function LB_Tsv(ByVal text As String) As Collection
    Dim rows As New Collection, fields As New Collection, value As String
    Dim i As Long, ch As String, quoted As Boolean, closed As Boolean
    text = Replace(Replace(text, vbCrLf, vbLf), vbCr, vbLf)
    For i = 1 To Len(text) + 1
        If i > Len(text) Then ch = vbLf Else ch = Mid$(text, i, 1)
        If quoted Then
            If i > Len(text) Then Err.Raise 5, , "ERP: Anfuehrungszeichen nicht abgeschlossen."
            If ch = Chr$(34) Then
                If Mid$(text, i + 1, 1) = Chr$(34) Then
                    value = value & Chr$(34): i = i + 1
                Else
                    quoted = False: closed = True
                End If
            Else
                value = value & ch
            End If
        ElseIf ch = vbTab Or ch = vbLf Then
            fields.Add Trim$(value): value = "": closed = False
            If ch = vbLf Then
                If fields.Count > 1 Or CStr(fields(1)) <> "" Then rows.Add fields
                Set fields = New Collection
            End If
        ElseIf ch = Chr$(34) And Trim$(value) = "" And Not closed Then
            value = "": quoted = True
        Else
            If closed And ch <> " " Then Err.Raise 5, , "ERP: Zeichen nach abgeschlossenem Feld."
            If Not closed Then value = value & ch
        End If
    Next i
    Set LB_Tsv = rows
End Function

Public Function LB_Header(ByVal fields As Collection) As Object
    Dim obj As Object, i As Long, key As String
    Set obj = LB_Dict()
    For i = 1 To fields.Count
        key = LCase$(Trim$(CStr(fields(i))))
        If key <> "" Then
            If Not obj.Exists(key) Then obj.Add key, CStr(i)
        End If
    Next i
    Set LB_Header = obj
End Function

Public Function LB_Field(ByVal fields As Collection, ByVal headers As Object, ByVal name As String) As String
    Dim idx As Long
    name = LCase$(name)
    If Not headers.Exists(name) Then Exit Function
    idx = CLng(headers(name))
    If idx > fields.Count Then Err.Raise 5, , "ERP: Datenzeile hat zu wenige Spalten."
    LB_Field = CStr(fields(idx))
End Function

Public Function LB_Quantity(ByVal text As String, Optional ByVal invariant As Boolean = False) As Long
    Dim re As Object, n As Double, s As String
    s = Trim$(text)
    If Not invariant Then
        If InStr(s, ",") > 0 Then s = Replace(Replace(s, ".", ""), ",", ".")
    End If
    Set re = CreateObject("VBScript.RegExp"): re.Pattern = "^[0-9]+(\.0+)?$"
    If Not re.Test(s) Then Err.Raise 5, , "Menge muss eine positive ganze Labelanzahl sein: " & text
    n = Val(s)
    If n < 1 Or n > 1000000 Then Err.Raise 5, , "Menge muss zwischen 1 und 1000000 liegen."
    LB_Quantity = CLng(n)
End Function

Public Function LB_LegacyJson(ByVal text As String) As Object
    Dim re As Object
    ' Only the known legacy decimal-comma defect is repaired, never arbitrary JSON.
    Set re = CreateObject("VBScript.RegExp")
    re.Global = True
    re.Pattern = "(" & Chr$(34) & "Menge" & Chr$(34) & "\s*:\s*)([0-9]+),([0-9]+)(\s*,\s*" & Chr$(34) & ")"
    text = re.Replace(text, "$1$2.$3$4")
    Set LB_LegacyJson = LB_ParseJson(text)
End Function

Option Explicit

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal milliseconds As Long)
Private Declare PtrSafe Function CoCreateGuid Lib "ole32" (ByRef guid As LB_GUID) As Long
Private Type LB_GUID
    D1 As Long
    D2 As Integer
    D3 As Integer
    D4(0 To 7) As Byte
End Type

Private lockNumber As Integer
Private lockHeld As Boolean
Private storePath As String
Private lastSequence As Long
Public LB_CommitSucceeded As Boolean

Public Function LB_NewId() As String
    Dim g As LB_GUID, result As String, i As Long
    If CoCreateGuid(g) <> 0 Then Err.Raise 5, , "Eindeutige ID konnte nicht erstellt werden."
    result = Right$("00000000" & Hex$(g.D1), 8) & Right$("0000" & Hex$(g.D2), 4) & Right$("0000" & Hex$(g.D3), 4)
    For i = 0 To 7
        result = result & Right$("00" & Hex$(g.D4(i)), 2)
    Next i
    LB_NewId = LCase$(result)
End Function

Public Function LB_Timestamp() As String
    LB_Timestamp = Format$(Now, "yyyy-mm-dd\Thh:nn:ss")
End Function

Public Function LB_ReadText(ByVal path As String, Optional ByVal legacy As Boolean = False) As String
    Dim stream As Object, text As String
    Set stream = CreateObject("ADODB.Stream")
    stream.Type = 1: stream.Open: stream.LoadFromFile path
    stream.Position = 0: stream.Type = 2: stream.Charset = "utf-8"
    text = stream.ReadText
    If InStr(text, ChrW$(-3)) > 0 Then
        If Not legacy Then stream.Close: Err.Raise 5, , "Ungueltige UTF-8-Datei: " & path
        stream.Position = 0: stream.Charset = "windows-1252": text = stream.ReadText
    End If
    stream.Close
    If Left$(text, 1) = ChrW$(-257) Then text = Mid$(text, 2)
    LB_ReadText = text
End Function

Public Sub LB_WriteText(ByVal path As String, ByVal text As String)
    Dim stream As Object, binary As Object
    Set stream = CreateObject("ADODB.Stream")
    stream.Type = 2: stream.Charset = "utf-8": stream.Open: stream.WriteText text
    stream.Position = 0: stream.Type = 1: stream.Position = 3
    Set binary = CreateObject("ADODB.Stream"): binary.Type = 1: binary.Open
    stream.CopyTo binary: binary.SaveToFile path, 1
    binary.Close: stream.Close
End Sub

Public Sub LB_Lock(ByVal baseFolder As String)
    Dim fs As Object, path As String, started As Double, elapsed As Double, code As Long, message As String
    If lockHeld Then Err.Raise 5, , "Datenbank ist in dieser Excel-Instanz bereits gesperrt."
    Set fs = CreateObject("Scripting.FileSystemObject")
    baseFolder = Trim$(baseFolder)
    If baseFolder = "" Or Not fs.FolderExists(baseFolder) Then Err.Raise 76, , "Datenordner fehlt oder ist nicht erreichbar."
    If InStr(1, baseFolder, "http", vbTextCompare) = 1 Then Err.Raise 5, , "Nur ein lokaler Ordner oder SMB-Netzwerkpfad ist erlaubt."
    path = fs.BuildPath(baseFolder, ".label-v2.lock")
    started = Timer
    Do
        lockNumber = FreeFile
        On Error Resume Next
        Err.Clear
        Open path For Binary Access Read Write Lock Read Write As #lockNumber
        code = Err.Number: message = Err.Description
        On Error GoTo 0
        If code = 0 Then Exit Do
        elapsed = Timer - started: If elapsed < 0 Then elapsed = elapsed + 86400#
        If elapsed >= 5# Then Err.Raise code, , "Datenbank belegt oder nicht beschreibbar: " & message
        Sleep 50
    Loop
    lockHeld = True
    storePath = fs.BuildPath(baseFolder, "LabelDB-v2")
    On Error GoTo Failed
    If Not fs.FolderExists(storePath) Then fs.CreateFolder storePath
    Exit Sub
Failed:
    code = Err.Number: message = Err.Description: LB_Unlock
    Err.Raise code, , message
End Sub

Public Sub LB_Unlock()
    If lockHeld Then
        On Error Resume Next
        Close #lockNumber
        On Error GoTo 0
    End If
    lockHeld = False: lockNumber = 0
End Sub

Public Function LB_LockIsHeld() As Boolean
    LB_LockIsHeld = lockHeld
End Function

Public Function LB_PositionKey(ByVal record As Object) As String
    Dim project As String, position As String
    project = LB_Get(record, "Projekt"): position = LB_Get(record, "AufPos")
    LB_PositionKey = CStr(Len(project)) & ":" & project & CStr(Len(position)) & ":" & position
End Function

Public Sub LB_CheckRecord(ByVal r As Object)
    Dim q As Long, re As Object, status As String
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "^[0-9a-f]{32}$"
    If Not re.Test(LB_Get(r, "Id")) Then Err.Raise 5, , "Datensatz-ID ungueltig."
    If LB_Get(r, "Schema") <> "2" Then Err.Raise 5, , "Datensatzversion ungueltig."
    re.Pattern = "^[0-9]{10}$"
    If Not re.Test(LB_Get(r, "Projekt")) Then Err.Raise 5, , "Projekt muss aus zehn Ziffern bestehen."
    If Trim$(LB_Get(r, "AufPos")) = "" Or Trim$(LB_Get(r, "BestelltFuer")) = "" Or Trim$(LB_Get(r, "Bezeichnung")) = "" Then Err.Raise 5, , "Position/Kennung, Person oder Bezeichnung fehlt."
    q = LB_Quantity(LB_Get(r, "Positionsmenge"), True)
    q = LB_Quantity(LB_Get(r, "Bestellmenge"), True)
    q = LB_Quantity(LB_Get(r, "Revision"), True)
    status = LB_Get(r, "LabelStat")
    If status <> "Offen" And status <> "Bestellt" And status <> "Eingetroffen" Then Err.Raise 5, , "Bestellstatus ungueltig."
    If status <> "Offen" And LB_Get(r, "BestelltAm") = "" Then Err.Raise 5, , "Bestelldatum fehlt."
    If status = "Eingetroffen" And LB_Get(r, "EingetroffenAm") = "" Then Err.Raise 5, , "Eingangsdatum fehlt."
End Sub

Private Sub CheckUpdate(ByVal old As Object, ByVal current As Object)
    Dim keys As Variant, key As Variant, oldStatus As String, newStatus As String
    If CLng(current("Revision")) <> CLng(old("Revision")) + 1 Then Err.Raise 5, , "Zwischenzeitlich geaendert. Bitte aktualisieren."
    keys = Array("Id", "Projekt", "AufPos", "BestelltFuer", "ArtikelKunde", "EAN", "KdSeriennummer", "ArtikelBezKunde", "Bezeichnung", "ZweiteBezeichnung", "Zeichnung", "Positionsmenge", "ErfasstAm", "Quelle", "LegacyRef", "LegacyRaw", "ArtikelERP")
    For Each key In keys
        If LB_Get(old, CStr(key)) <> LB_Get(current, CStr(key)) Then Err.Raise 5, , "Unveraenderliches Bestellfeld wurde geaendert: " & CStr(key)
    Next key
    oldStatus = old("LabelStat"): newStatus = current("LabelStat")
    If oldStatus = "Eingetroffen" And newStatus <> "Eingetroffen" Then Err.Raise 5, , "Eingetroffene Bestellung darf nicht zurueckgesetzt werden."
    If oldStatus = "Bestellt" And newStatus = "Offen" Then Err.Raise 5, , "Bestellte Bestellung darf nicht zurueckgesetzt werden."
    If oldStatus = "Offen" And newStatus = "Eingetroffen" Then Err.Raise 5, , "Bestellschritt fehlt."
    If oldStatus <> "Offen" Then
        keys = Array("Bestellmenge", "Kit", "BestelltAm", "BestellTyp")
        For Each key In keys
            If LB_Get(old, CStr(key)) <> LB_Get(current, CStr(key)) Then Err.Raise 5, , "Bereits bestelltes Feld wurde geaendert: " & CStr(key)
        Next key
    End If
    If oldStatus = "Eingetroffen" And old("EingetroffenAm") <> current("EingetroffenAm") Then Err.Raise 5, , "Eingangszeit darf nicht geaendert werden."
End Sub

Public Function LB_LoadLocked() As Object
    Dim fs As Object, folder As Object, f As Object, names As Object, name As Variant
    Dim lines As Variant, i As Long, text As String, head As Object, foot As Object, r As Object
    Dim state As Object, pending As Collection, re As Object, seq As Long, id As String, count As Long, seen As Object
    If Not lockHeld Then Err.Raise 5, , "Datenbankzugriff ohne Sperre."
    Set fs = CreateObject("Scripting.FileSystemObject"): Set folder = fs.GetFolder(storePath)
    Set names = LB_Dict()
    Set re = CreateObject("VBScript.RegExp"): re.Pattern = "^[0-9]{10}-[0-9a-f]{32}\.jsonl$"
    For Each f In folder.Files
        If LCase$(fs.GetExtensionName(f.Name)) = "jsonl" Then
            If Not re.Test(f.Name) Then Err.Raise 5, , "Unerwartete Journaldatei: " & f.Name
            names.Add CStr(f.Name), "1"
        End If
    Next f
    Set state = LB_Dict(): lastSequence = 0
    For Each name In LB_SortedKeys(names)
        seq = CLng(Left$(CStr(name), 10))
        If seq <> lastSequence + 1 Then Err.Raise 5, , "Journalfolge fehlt oder ist doppelt: " & CStr(name)
        text = LB_ReadText(fs.BuildPath(storePath, CStr(name)))
        lines = Split(Replace(text, vbCrLf, vbLf), vbLf)
        count = UBound(lines)
        If count < 2 Or CStr(lines(count)) <> "" Then Err.Raise 5, , "Journaldatei unvollstaendig: " & CStr(name)
        Set head = LB_ParseJson(CStr(lines(0))): Set foot = LB_ParseJson(CStr(lines(count - 1)))
        If LB_Get(head, "Kind") <> "Begin" Or LB_Get(foot, "Kind") <> "Commit" Or LB_Get(head, "Tx") <> LB_Get(foot, "Tx") Then Err.Raise 5, , "Transaktionsrahmen ungueltig."
        If LB_Get(head, "Sequence") <> CStr(seq) Or LB_Get(head, "Schema") <> "2" Then Err.Raise 5, , "Transaktionsversion ungueltig."
        If Mid$(CStr(name), 12, 32) <> LB_Get(head, "Tx") Then Err.Raise 5, , "Transaktions-ID passt nicht zum Dateinamen."
        If LB_Get(foot, "Rows") <> CStr(count - 2) Then Err.Raise 5, , "Transaktionszeilen fehlen."
        Set pending = New Collection: Set seen = LB_Dict()
        For i = 1 To count - 2
            Set r = LB_ParseJson(CStr(lines(i))): LB_CheckRecord r: id = r("Id")
            If seen.Exists(id) Then Err.Raise 5, , "Datensatz-ID doppelt innerhalb der Journaltransaktion."
            seen.Add id, "1"
            If state.Exists(id) Then
                CheckUpdate state(id), r
            ElseIf r("Revision") <> "1" Then
                Err.Raise 5, , "Erste Datensatzrevision muss 1 sein."
            End If
            pending.Add r
        Next i
        For Each r In pending
            id = r("Id"): If state.Exists(id) Then state.Remove id
            state.Add id, r
        Next r
        lastSequence = seq
    Next name
    Set LB_LoadLocked = state
End Function

Public Sub LB_CommitLocked(ByVal changes As Collection, ByVal state As Object)
    Dim fs As Object, r As Object, ids As Object, head As Object, foot As Object, id As String
    Dim text As String, tx As String, tempPath As String, finalPath As String
    If Not lockHeld Then Err.Raise 5, , "Speichern ohne Sperre."
    If changes.Count = 0 Then Exit Sub
    Set ids = LB_Dict()
    For Each r In changes
        LB_CheckRecord r: id = r("Id")
        If ids.Exists(id) Then Err.Raise 5, , "Datensatz doppelt in Transaktion."
        ids.Add id, "1"
        If state.Exists(id) Then
            CheckUpdate state(id), r
        ElseIf r("Revision") <> "1" Then
            Err.Raise 5, , "Neuer Datensatz hat ungueltige Revision."
        End If
    Next r
    If lastSequence >= 999999999 Then Err.Raise 5, , "Journalgrenze erreicht."
    tx = LB_NewId(): Set head = LB_Dict(): Set foot = LB_Dict()
    head.Add "Kind", "Begin": head.Add "Schema", "2": head.Add "Tx", tx
    head.Add "Sequence", CStr(lastSequence + 1)
    text = LB_Json(head) & vbLf
    For Each r In changes
        text = text & LB_Json(r) & vbLf
    Next r
    foot.Add "Kind", "Commit": foot.Add "Tx", tx: foot.Add "Rows", CStr(changes.Count)
    text = text & LB_Json(foot) & vbLf
    Set fs = CreateObject("Scripting.FileSystemObject")
    tempPath = fs.BuildPath(storePath, tx & ".tmp")
    finalPath = fs.BuildPath(storePath, Format$(lastSequence + 1, "0000000000") & "-" & tx & ".jsonl")
    LB_WriteText tempPath, text
    If LB_ReadText(tempPath) <> text Then Err.Raise 5, , "Schreibkontrolle fehlgeschlagen."
    Name tempPath As finalPath
    LB_CommitSucceeded = True
    lastSequence = lastSequence + 1
    For Each r In changes
        id = r("Id"): If state.Exists(id) Then state.Remove id
        state.Add id, LB_Copy(r)
    Next r
End Sub

Public Function LB_Ordered(ByVal state As Object, ByVal record As Object) As Double
    Dim key As Variant, r As Object, identity As String
    identity = LB_PositionKey(record)
    For Each key In state.Keys
        Set r = state(key)
        If LB_PositionKey(r) = identity And r("LabelStat") <> "Offen" And LB_Get(r, "BestellTyp") <> "Ersatzbestellung" Then
            LB_Ordered = LB_Ordered + CDbl(r("Bestellmenge"))
        End If
    Next key
End Function

Public Function LB_History(ByVal state As Object, ByVal record As Object) As String
    Dim key As Variant, r As Object, n As Long, result As String
    For Each key In state.Keys
        Set r = state(key)
        If LB_PositionKey(r) = LB_PositionKey(record) And r("Id") <> record("Id") Then
            n = n + 1
            If n <= 8 Then result = result & vbCrLf & r("Bestellmenge") & " Label, " & r("LabelStat") & ", KIT: " & LB_Get(r, "Kit")
        End If
    Next key
    If n > 8 Then result = result & vbCrLf & "Weitere Vorgangaenge: " & CStr(n - 8)
    LB_History = result
End Function

Option Explicit

Public Const LB_FIRST As Long = 16
Public Const LB_VERSION As String = "2.0.0"
Public LB_Busy As Boolean
Private oldScreen As Boolean, oldEvents As Boolean, oldCalculation As XlCalculation

Public Function LB_Begin() As Boolean
    If LB_Busy Then Exit Function
    oldScreen = Application.ScreenUpdating
    oldEvents = Application.EnableEvents
    oldCalculation = Application.Calculation
    LB_Busy = True
    LB_CommitSucceeded = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    LB_Begin = True
End Function

Public Sub LB_End()
    On Error Resume Next
    LB_Unlock
    LB_Sheet.Protect UserInterfaceOnly:=True, AllowFiltering:=True
    Application.Calculation = oldCalculation
    Application.ScreenUpdating = oldScreen
    Application.EnableEvents = oldEvents
    LB_Busy = False
    On Error GoTo 0
End Sub

Public Sub LB_Error(ByVal message As String)
    If LB_CommitSucceeded Then message = "Zentral bereits gespeichert. Die Ansicht muss erneut aktualisiert werden. " & message
    On Error Resume Next
    LB_Sheet.Range("A5").Value2 = "NICHT BESTAETIGT: " & message
    LB_Sheet.Range("A5").Font.Color = RGB(180, 45, 45)
    On Error GoTo 0
    If Application.UserControl Then MsgBox message, vbExclamation, "LabelBestellen"
End Sub

Public Function LB_Sheet() As Worksheet
    Set LB_Sheet = ThisWorkbook.Worksheets("Positionen")
End Function

Public Function LB_IsMaster() As Boolean
    LB_IsMaster = (LCase$(ThisWorkbook.Name) = "labelbestellen.xlsm")
End Function

Public Function LB_BaseFolder() As String
    LB_BaseFolder = Trim$(CStr(LB_Sheet.Range("B4").Value2))
End Function

Public Function LB_Keys() As Variant
    LB_Keys = Array("Projekt", "BestelltFuer", "AufPos", "ArtikelKunde", "EAN", "KdSeriennummer", "ArtikelBezKunde", "Bezeichnung", "ZweiteBezeichnung", "Zeichnung", "Positionsmenge", "BestellTyp", "LabelStat", "Bestellmenge", "Kit", "ErfasstAm", "BestelltAm", "EingetroffenAm", "", "", "Bemerkung", "Id", "Revision", "Quelle")
End Function

Public Function LB_LastRow() As Long
    Dim last As Long
    last = LB_Sheet.Cells(LB_Sheet.Rows.Count, 22).End(xlUp).Row
    Do While last >= LB_FIRST
        If Len(CStr(LB_Sheet.Cells(last, 22).Value2)) > 0 Then Exit Do
        last = last - 1
    Loop
    If last < LB_FIRST Then last = LB_FIRST - 1
    LB_LastRow = last
End Function

Public Sub LB_EnsureLayout()
    Dim ws As Worksheet, backup As Worksheet
    Set ws = LB_Sheet
    If CStr(ws.Range("AA1").Value2) = LB_VERSION Then
        ws.Protect UserInterfaceOnly:=True, AllowFiltering:=True
        Exit Sub
    End If
    If CStr(ws.Range("A1").Value2) <> "" Then
        On Error Resume Next
        Set backup = ThisWorkbook.Worksheets("Altbestand")
        On Error GoTo 0
        If Not backup Is Nothing Then Err.Raise 5, , "Altbestand existiert bereits. Installation zur Sicherheit angehalten."
        ws.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        Set backup = ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        backup.Name = "Altbestand"
        Dim shape As Shape
        For Each shape In backup.Shapes
            shape.OnAction = ""
        Next shape
        backup.Protect
    End If
    LB_BuildLayout "", "", ""
End Sub

Public Sub LB_BuildLayout(ByVal folder As String, ByVal project As String, ByVal person As String)
    Dim ws As Worksheet, i As Long, names As Variant, table As ListObject
    Set ws = LB_Sheet: ws.Unprotect
    Do While ws.ListObjects.Count > 0
        ws.ListObjects(1).Delete
    Loop
    For i = ws.Shapes.Count To 1 Step -1
        ws.Shapes(i).Delete
    Next i
    ws.Cells.Clear
    ws.Range("A1:Y35").Font.Name = "Arial"
    ws.Range("A1:Y35").Font.Size = 10
    ws.Range("A1:Y35").Font.Color = RGB(30, 41, 59)
    ws.Range("A1:Y35").VerticalAlignment = xlCenter
    ws.Rows("1:15").RowHeight = 22
    ws.Rows(2).RowHeight = 30
    ws.Range("A2").Value2 = "Labelbestellungen"
    ws.Range("A2").Font.Size = 16: ws.Range("A2").Font.Bold = True
    ws.Range("D2").Value2 = "Version " & LB_VERSION
    ws.Range("A3:U3").Borders(xlEdgeBottom).Color = RGB(37, 99, 235)
    ws.Range("A4").Value2 = "Datenordner": ws.Range("B4").NumberFormat = "@": ws.Range("B4").Value2 = folder
    ws.Range("A5").Value2 = "Datenordner waehlen; danach Altbestand uebernehmen oder neue Positionen erfassen."
    ws.Range("A6").Value2 = "Projekt": ws.Range("B6").NumberFormat = "@": ws.Range("B6").Value2 = project
    ws.Range("C6").Value2 = "Bestellt fuer": ws.Range("D6").NumberFormat = "@": ws.Range("D6").Value2 = person
    ws.Range("B6,D6").Interior.Color = RGB(254, 249, 195): ws.Range("B6,D6").Locked = False
    LB_Button "lb_import", "ERP-Zwischenablage", "LB_Import", "A8:B9"
    LB_Button "lb_manual", "Manuell erfassen", "LB_Manual", "C8:D9"
    LB_Button "lb_order", "Auswahl bestellen", "LB_Order", "E8:F9"
    LB_Button "lb_receive", "Auswahl eingetroffen", "LB_Receive", "A10:B11"
    LB_Button "lb_refresh", "Status aktualisieren", "LB_Refresh", "C10:D11"
    LB_Button "lb_reset", "Zuruecksetzen", "LB_Reset", "E10:F11"
    LB_Button "lb_copy", "Neue Kopie speichern", "LB_CopyWorkbook", "A12:B13"
    LB_Button "lb_folder", "Datenordner waehlen", "LB_ChooseFolder", "C12:D13"
    LB_Button "lb_migrate", "Altbestand uebernehmen", "LB_Migrate", "E12:F13"
    ws.Range("A14").Value2 = "Offen: Menge und KIT editierbar. Bemerkung bleibt je Bestellung editierbar."
    names = Array("Projekt", "Bestellt fuer", "Auf.-Pos. / Kennung", "Artikel-Nr. (Kunde)", "EAN-Nummer", "Kd.-Seriennummer", "Artikelbezeichnung Kunde", "Bezeichnung", "2. Bezeichnung", "Zeichnung", "Positionsmenge", "Bestell-Typ", "Label Status", "Bestellmenge", "KIT / Labelcode", "Erfasst am", "Bestellt am", "Eingetroffen am", "Bereits bestellt", "Noch bestellbar", "Bemerkung", "Datensatz-ID", "Revision", "Quelle", "Gesicherter Datensatz")
    For i = 0 To UBound(names)
        ws.Cells(15, i + 1).Value2 = names(i)
    Next i
    Set table = ws.ListObjects.Add(xlSrcRange, ws.Range("A15:Y16"), , xlYes)
    table.Name = "tblLabelBestellungen": table.TableStyle = "TableStyleMedium2"
    ws.Range("A15:Y15").Interior.Color = RGB(30, 64, 175)
    ws.Range("A15:Y15").Font.Color = vbWhite: ws.Range("A15:Y15").Font.Bold = True
    ws.Range("A15:Y15").WrapText = True: ws.Rows(15).RowHeight = 36
    ws.Columns("A:D").ColumnWidth = 18: ws.Columns("E:F").ColumnWidth = 24
    ws.Columns("G:J").ColumnWidth = 29: ws.Columns("K:N").ColumnWidth = 17
    ws.Columns("O:O").ColumnWidth = 28: ws.Columns("P:R").ColumnWidth = 21
    ws.Columns("S:T").ColumnWidth = 17: ws.Columns("U:U").ColumnWidth = 44
    ws.Columns("V:AA").Hidden = True
    ws.Range("AA1").Value2 = LB_VERSION
    ws.Range("A16:J35,L16:M35,O16:O35,U16:Y35").NumberFormat = "@"
    ws.Range("K16:K35,N16:N35,S16:T35").NumberFormat = "#,##0"
    ws.Range("P16:R35").NumberFormat = "dd.mm.yyyy hh:mm"
    ws.Activate
    If ThisWorkbook.Windows.Count > 0 Then
        With ThisWorkbook.Windows(1)
            .DisplayGridlines = False: .FreezePanes = False
            .SplitRow = 15: .SplitColumn = 3: .FreezePanes = True
        End With
    End If
    ws.PageSetup.Orientation = xlLandscape
    ws.PageSetup.PrintTitleRows = "$15:$15"
    ws.PageSetup.Zoom = False: ws.PageSetup.FitToPagesWide = 1: ws.PageSetup.FitToPagesTall = False
    ws.Protect UserInterfaceOnly:=True, AllowFiltering:=True
End Sub

Private Sub LB_Button(ByVal name As String, ByVal caption As String, ByVal macro As String, ByVal address As String)
    Dim area As Range, shape As Shape
    Set area = LB_Sheet.Range(address)
    Set shape = LB_Sheet.Shapes.AddShape(msoShapeRoundedRectangle, area.Left, area.Top, area.Width - 6, area.Height - 5)
    shape.Name = name: shape.Fill.ForeColor.RGB = RGB(37, 99, 235): shape.Line.Visible = msoFalse
    shape.TextFrame2.TextRange.Text = caption
    shape.TextFrame2.TextRange.Font.Name = "Arial": shape.TextFrame2.TextRange.Font.Size = 11
    shape.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = vbWhite
    shape.TextFrame2.VerticalAnchor = msoAnchorMiddle
    shape.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    shape.OnAction = "'" & Replace(ThisWorkbook.Name, "'", "''") & "'!" & macro
    shape.Placement = xlFreeFloating: shape.DrawingObject.PrintObject = False
End Sub

Public Sub LB_RebindButtons()
    Dim shape As Shape, action As String
    For Each shape In LB_Sheet.Shapes
        If Left$(shape.Name, 3) = "lb_" Then
            action = shape.OnAction
            If InStrRev(action, "!") > 0 Then
                action = Mid$(action, InStrRev(action, "!") + 1)
                action = "'" & Replace(ThisWorkbook.Name, "'", "''") & "'!" & action
                If shape.OnAction <> action Then shape.OnAction = action
            End If
        End If
    Next shape
End Sub

Public Function LB_Baseline(ByVal row As Long) As Object
    If row < LB_FIRST Or CStr(LB_Sheet.Cells(row, 25).Value2) = "" Then Err.Raise 5, , "Keine registrierte Bestellung in dieser Zeile."
    Set LB_Baseline = LB_ParseJson(CStr(LB_Sheet.Cells(row, 25).Value2))
End Function

Public Sub LB_RenderRow(ByVal row As Long, ByVal record As Object, Optional ByVal state As Object)
    Dim keys As Variant, data(1 To 1, 1 To 25) As Variant, i As Long, value As String
    Dim ws As Worksheet, total As Double, status As String
    Set ws = LB_Sheet: keys = LB_Keys(): status = record("LabelStat")
    ws.Range(ws.Cells(row, 1), ws.Cells(row, 25)).Locked = True
    ws.Range(ws.Cells(row, 1), ws.Cells(row, 25)).NumberFormat = "@"
    For i = 0 To UBound(keys)
        If CStr(keys(i)) <> "" Then data(1, i + 1) = LB_Get(record, CStr(keys(i)))
    Next i
    data(1, 11) = CLng(record("Positionsmenge")): data(1, 14) = CLng(record("Bestellmenge"))
    If Not state Is Nothing Then
        total = LB_Ordered(state, record)
    ElseIf IsNumeric(ws.Cells(row, 19).Value2) Then
        total = CDbl(ws.Cells(row, 19).Value2)
    End If
    data(1, 19) = total
    data(1, 20) = Application.Max(0, CLng(record("Positionsmenge")) - total)
    data(1, 25) = LB_Json(record)
    ws.Range(ws.Cells(row, 1), ws.Cells(row, 25)).Value2 = data
    ws.Range("K" & row & ",N" & row & ",S" & row & ":T" & row).NumberFormat = "#,##0"
    For i = 16 To 18
        value = CStr(data(1, i))
        If Len(value) = 19 Then
            ws.Cells(row, i).NumberFormat = "dd.mm.yyyy hh:mm"
            ws.Cells(row, i).Value = DateSerial(CInt(Left$(value, 4)), CInt(Mid$(value, 6, 2)), CInt(Mid$(value, 9, 2))) + TimeSerial(CInt(Mid$(value, 12, 2)), CInt(Mid$(value, 15, 2)), CInt(Right$(value, 2)))
        End If
    Next i
    ws.Cells(row, 13).Locked = False: ws.Cells(row, 21).Locked = False
    If status = "Offen" Then ws.Cells(row, 14).Locked = False: ws.Cells(row, 15).Locked = False
    ws.Cells(row, 13).Validation.Delete
    ws.Cells(row, 13).Validation.Add xlValidateList, xlValidAlertStop, xlBetween, "Offen" & Application.International(xlListSeparator) & "Bestellt" & Application.International(xlListSeparator) & "Eingetroffen"
    ws.Cells(row, 13).Validation.ShowError = True
    ws.Cells(row, 13).Interior.Color = RGB(254, 243, 199)
    If status = "Bestellt" Then ws.Cells(row, 13).Interior.Color = RGB(219, 234, 254)
    If status = "Eingetroffen" Then ws.Cells(row, 13).Interior.Color = RGB(220, 252, 231)
    ws.Cells(row, 21).WrapText = True: ws.Rows(row).RowHeight = 30
End Sub

Public Sub LB_ResizeTable()
    Dim last As Long
    last = LB_LastRow(): If last < LB_FIRST Then last = LB_FIRST
    LB_Sheet.ListObjects("tblLabelBestellungen").Resize LB_Sheet.Range("A15:Y" & last)
    LB_Sheet.PageSetup.PrintArea = "$A$2:$U$" & last
End Sub

Public Sub LB_Summary()
    Dim row As Long, status As String, nOpen As Long, nOrdered As Long, nReceived As Long
    For row = LB_FIRST To LB_LastRow()
        status = CStr(LB_Sheet.Cells(row, 13).Value2)
        Select Case status
            Case "Offen": nOpen = nOpen + 1
            Case "Bestellt": nOrdered = nOrdered + 1
            Case "Eingetroffen": nReceived = nReceived + 1
        End Select
    Next row
    LB_Sheet.Range("A7").Value2 = "In dieser Ansicht: " & nOpen & " offen, " & nOrdered & " bestellt, " & nReceived & " eingetroffen."
End Sub

Public Sub LB_RefreshInternal(ByVal allOrders As Boolean, Optional ByVal outstandingOnly As Boolean = False)
    Dim state As Object, key As Variant, row As Long, missing As Long, r As Object, last As Long
    LB_Lock LB_BaseFolder(): Set state = LB_LoadLocked(): LB_Unlock
    LB_Sheet.Unprotect
    If allOrders Then
        last = LB_LastRow()
        If last >= LB_FIRST Then LB_Sheet.Range("A16:Y" & last).ClearContents
        row = LB_FIRST
        For Each key In state.Keys
            LB_RenderRow row, state(key), state: row = row + 1
        Next key
    Else
        For row = LB_FIRST To LB_LastRow()
            If Not outstandingOnly Or CStr(LB_Sheet.Cells(row, 13).Value2) <> "Eingetroffen" Then
                Set r = LB_Baseline(row): key = r("Id")
                If state.Exists(key) Then
                    LB_RenderRow row, state(key), state
                Else
                    missing = missing + 1
                End If
            End If
        Next row
    End If
    Call LB_ResizeTable: LB_Summary
    If missing > 0 Then Err.Raise 5, , CStr(missing) & " Bestellung(en) fehlen im gewaehlten Datenbestand; gespeicherte Werte beibehalten."
    LB_Sheet.Range("A5").Value2 = "Zentral geprueft: " & Format$(Now, "dd.mm.yyyy hh:nn:ss") & IIf(ThisWorkbook.ReadOnly, " | Exceldatei schreibgeschuetzt; zentral speichern weiterhin moeglich. Eigene Kopie verwenden.", "")
    LB_Sheet.Range("A5").Font.Color = RGB(30, 64, 175)
End Sub

Public Sub LB_OnOpen()
    Dim message As String
    If Not LB_Begin() Then Exit Sub
    On Error GoTo Failed
    Call LB_EnsureLayout: LB_RebindButtons
    If LB_BaseFolder() <> "" Then LB_RefreshInternal LB_IsMaster(), Not LB_IsMaster()
    Call LB_End: Exit Sub
Failed:
    message = Err.Description: Call LB_End: LB_Error message
End Sub

Public Sub LB_Refresh()
    Dim message As String
    If Not LB_Begin() Then Exit Sub
    On Error GoTo Failed
    LB_RefreshInternal LB_IsMaster(): Call LB_End: Exit Sub
Failed:
    message = Err.Description: Call LB_End: LB_Error message
End Sub

Public Sub LB_Reset()
    Dim message As String, folder As String, project As String, person As String
    If MsgBox("Nur die angezeigte Liste leeren? Zentrale Bestellungen und Altbestand bleiben erhalten.", vbYesNo + vbQuestion, "Ansicht zuruecksetzen") <> vbYes Then Exit Sub
    If Not LB_Begin() Then Exit Sub
    On Error GoTo Failed
    folder = LB_BaseFolder(): project = CStr(LB_Sheet.Range("B6").Value2): person = CStr(LB_Sheet.Range("D6").Value2)
    LB_BuildLayout folder, project, person: LB_Summary: Call LB_End: Exit Sub
Failed:
    message = Err.Description: Call LB_End: LB_Error message
End Sub

Public Sub LB_ChooseFolder()
    Dim dialog As Object, folder As String, message As String
    Set dialog = Application.FileDialog(msoFileDialogFolderPicker)
    dialog.Title = "Gemeinsamen Datenordner waehlen (alle Kopien verwenden denselben Ordner)"
    If dialog.Show <> -1 Then Exit Sub
    folder = dialog.SelectedItems(1)
    If LB_BaseFolder() <> "" And StrComp(folder, LB_BaseFolder(), vbTextCompare) <> 0 And LB_LastRow() >= LB_FIRST Then
        MsgBox "Bei gefuellter Ansicht den Datenordner nicht wechseln. Zuerst eine Kopie sichern und die Ansicht zuruecksetzen.", vbExclamation: Exit Sub
    End If
    If Not LB_Begin() Then Exit Sub
    On Error GoTo Failed
    LB_Lock folder: LB_Unlock
    LB_Sheet.Unprotect: LB_Sheet.Range("B4").Value2 = folder
    LB_RefreshInternal LB_IsMaster(): Call LB_End: Exit Sub
Failed:
    message = Err.Description: Call LB_End: LB_Error message
End Sub

Public Sub LB_CopyWorkbook()
    Dim target As Variant, path As String, fs As Object, message As String
    target = Application.GetSaveAsFilename(InitialFileName:="KW" & Format$(DatePart("ww", Date, vbMonday, vbFirstFourDays), "00") & "-" & Format$(Date, "yyyy") & ".xlsm", FileFilter:="Excel mit Makros (*.xlsm), *.xlsm")
    If VarType(target) = vbBoolean Then Exit Sub
    path = CStr(target): Set fs = CreateObject("Scripting.FileSystemObject")
    If LCase$(fs.GetExtensionName(path)) <> "xlsm" Then MsgBox "Bitte .xlsm verwenden.", vbExclamation: Exit Sub
    If fs.FileExists(path) Then MsgBox "Datei existiert bereits. Bitte einen neuen Namen waehlen.", vbExclamation: Exit Sub
    On Error GoTo Failed
    ThisWorkbook.SaveCopyAs path
    MsgBox "Kopie gespeichert. Sie behaelt ihre Bestellungen; offene Status werden beim Oeffnen zentral geprueft.", vbInformation
    Exit Sub
Failed:
    message = Err.Description: LB_Error message
End Sub

Option Explicit

Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal format As Long) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal memory As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal memory As LongPtr) As Long
Private Declare PtrSafe Function lstrlenW Lib "kernel32" (ByVal text As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal dest As LongPtr, ByVal source As LongPtr, ByVal size As LongPtr)

Public Function LB_Clipboard() As String
    Dim handle As LongPtr, pointer As LongPtr, n As Long, text As String, message As String
    If OpenClipboard(0) = 0 Then Err.Raise 5, , "Zwischenablage ist momentan belegt. Bitte erneut versuchen."
    On Error GoTo Failed
    handle = GetClipboardData(13)
    If handle = 0 Then Err.Raise 5, , "Keine Unicode-Textdaten in der Zwischenablage."
    pointer = GlobalLock(handle)
    If pointer = 0 Then Err.Raise 5, , "Zwischenablage konnte nicht gelesen werden."
    n = lstrlenW(pointer)
    If n > 5000000 Then Err.Raise 5, , "Zwischenablage ist zu gross. Bitte kleinere Auswahl kopieren."
    If n > 0 Then
        text = String$(n, vbNullChar)
        CopyMemory StrPtr(text), pointer, CLngPtr(n) * 2
    End If
    GlobalUnlock handle: CloseClipboard
    LB_Clipboard = text: Exit Function
Failed:
    message = Err.Description
    If pointer <> 0 Then GlobalUnlock handle
    Call CloseClipboard: Err.Raise 5, , message
End Function

Public Function LB_Ask(ByVal prompt As String, ByRef value As String, Optional ByVal allowEmpty As Boolean = False) As Boolean
    Dim result As Variant
    result = Application.InputBox(prompt, "LabelBestellen", value, Type:=2)
    If VarType(result) = vbBoolean Then Exit Function
    value = CStr(result)
    If Not allowEmpty And Trim$(value) = "" Then Err.Raise 5, , "Erforderliche Eingabe fehlt."
    LB_Ask = True
End Function

Public Function LB_NewRecord() As Object
    Dim r As Object, keys As Variant, key As Variant
    Set r = LB_Dict(): keys = LB_Keys()
    For Each key In keys
        If CStr(key) <> "" Then r.Add CStr(key), ""
    Next key
    r.Add "Schema", "2": r("Id") = LB_NewId(): r("Revision") = "1"
    r("LabelStat") = "Offen": r("BestellTyp") = "Erstbestellung"
    r("ErfasstAm") = LB_Timestamp(): Set LB_NewRecord = r
End Function

Public Function LB_ErpRecords(ByVal text As String, ByVal project As String, ByVal person As String) As Collection
    Dim rows As Collection, fields As Collection, headers As Object, candidates As New Collection
    Dim r As Object, seen As Object, i As Long, start As Long, key As String
    Set rows = LB_Tsv(text): Set seen = LB_Dict()
    For i = 1 To rows.Count
        Set headers = LB_Header(rows(i))
        If headers.Exists("auf.-pos.") And headers.Exists("bezeichnung") And headers.Exists("menge") Then start = i + 1: Exit For
    Next i
    If start = 0 Then Err.Raise 5, , "ERP-Kopfzeile fehlt: Auf.-Pos., Bezeichnung und Menge werden benoetigt. Bitte mit Spaltenueberschriften kopieren."
    For i = start To rows.Count
        Set fields = rows(i)
        If fields.Count < 3 Then Err.Raise 5, , "Unerwartete Zeile nach ERP-Tabelle. Bitte ausschliesslich die Positionstabelle kopieren."
        Set r = LB_NewRecord(): r("Projekt") = project: r("BestelltFuer") = person
        r("AufPos") = LB_Field(fields, headers, "Auf.-Pos.")
        r("ArtikelKunde") = LB_Field(fields, headers, "Artikel-Nr. (Kunde)")
        r("EAN") = LB_Field(fields, headers, "EAN-Nummer")
        r("KdSeriennummer") = LB_Field(fields, headers, "Kd.-Seriennummer")
        r("ArtikelBezKunde") = LB_Field(fields, headers, "Artikelbezeichnung Kunde")
        r("Bezeichnung") = LB_Field(fields, headers, "Bezeichnung")
        r("ZweiteBezeichnung") = LB_Field(fields, headers, "2. Bezeichnung")
        r("Zeichnung") = LB_Field(fields, headers, "Zeichnung")
        r("Positionsmenge") = CStr(LB_Quantity(LB_Field(fields, headers, "Menge")))
        r("Bestellmenge") = r("Positionsmenge"): r("Quelle") = "ERP"
        If headers.Exists("artikel-nr.") Then r.Add "ArtikelERP", LB_Field(fields, headers, "Artikel-Nr.")
        key = LB_PositionKey(r)
        If seen.Exists(key) Then Err.Raise 5, , "Projektposition mehrfach im Import. Bitte Auswahl pruefen: " & r("AufPos")
        seen.Add key, "1": LB_CheckRecord r: candidates.Add r
    Next i
    If candidates.Count = 0 Then Err.Raise 5, , "Keine Positionen nach ERP-Kopfzeile vorhanden."
    Set LB_ErpRecords = candidates
End Function

Public Function LB_PositionStamp(ByVal state As Object, ByVal record As Object) As String
    Dim key As Variant, r As Object, result As String
    For Each key In state.Keys
        Set r = state(key)
        If LB_PositionKey(r) = LB_PositionKey(record) Then result = result & LB_Json(r) & vbLf
    Next key
    LB_PositionStamp = result
End Function

Private Sub LB_AddDrafts(ByVal records As Collection)
    Dim state As Object, fresh As Object, stamps As Object, r As Object, warnings As String
    Dim key As String, history As String, rest As Double, row As Long
    LB_Lock LB_BaseFolder(): Set state = LB_LoadLocked(): LB_Unlock
    Set stamps = LB_Dict()
    For Each r In records
        key = LB_PositionKey(r): stamps.Add key, LB_PositionStamp(state, r)
        history = LB_History(state, r)
        If history <> "" Then warnings = warnings & vbCrLf & r("Projekt") & " / " & r("AufPos") & history & vbCrLf
        rest = CLng(r("Positionsmenge")) - LB_Ordered(state, r)
        If rest > 0 And rest <= 1000000 Then r("Bestellmenge") = CStr(CLng(rest))
    Next r
    If warnings <> "" Then
        If MsgBox("Diese Projektpositionen sind bereits erfasst:" & Left$(warnings, 1500) & vbCrLf & "Trotzdem neue OFFENE Bestellvorgaenge anlegen? Vor dem Bestellen Menge/KIT pruefen.", vbYesNo + vbExclamation, "Vorhandene Bestellungen") <> vbYes Then Exit Sub
    End If
    LB_Lock LB_BaseFolder(): Set fresh = LB_LoadLocked()
    For Each r In records
        If LB_PositionStamp(fresh, r) <> stamps(LB_PositionKey(r)) Then Err.Raise 5, , "Bestand wurde waehrend der Eingabe geaendert. Bitte erneut importieren. Es wurde nichts gespeichert."
    Next r
    LB_CommitLocked records, fresh: LB_Unlock
    LB_Sheet.Unprotect
    row = LB_LastRow() + 1
    For Each r In records
        LB_RenderRow row, r, fresh: row = row + 1
    Next r
    Call LB_ResizeTable: LB_Summary
    LB_Sheet.Range("A5").Value2 = records.Count & " offene Bestellvorgaenge zentral gespeichert. Menge/KIT/Bemerkung pruefen, dann Auswahl bestellen."
End Sub

Public Sub LB_Import()
    Dim project As String, person As String, message As String, records As Collection, text As String
    If Not LB_Begin() Then Exit Sub
    On Error GoTo Failed
    text = LB_Clipboard()
    project = CStr(LB_Sheet.Range("B6").Value2): person = CStr(LB_Sheet.Range("D6").Value2)
    If Not LB_Ask("Zehnstellige Projekt-/Auftragsnummer fuer diese Positionen:", project) Then GoTo Finished
    If Not LB_Ask("Fuer wen werden die Label bestellt?", person) Then GoTo Finished
    Set records = LB_ErpRecords(text, Trim$(project), Trim$(person))
    LB_Sheet.Range("B6").Value2 = Trim$(project): LB_Sheet.Range("D6").Value2 = Trim$(person)
    LB_AddDrafts records
Finished:
    Call LB_End: Exit Sub
Failed:
    message = Err.Description: Call LB_End: LB_Error message
End Sub

Public Sub LB_Manual()
    Dim r As Object, records As New Collection, value As String, message As String
    If Not LB_Begin() Then Exit Sub
    On Error GoTo Failed
    Set r = LB_NewRecord(): value = CStr(LB_Sheet.Range("B6").Value2)
    If Not LB_Ask("Zehnstellige Projekt-/Auftragsnummer:", value) Then GoTo Finished
    r("Projekt") = Trim$(value): value = CStr(LB_Sheet.Range("D6").Value2)
    If Not LB_Ask("Fuer wen werden die Label bestellt?", value) Then GoTo Finished
    r("BestelltFuer") = Trim$(value): value = ""
    If Not LB_Ask("Wiederverwendbare Kennung dieser Labelart, z.B. LAGER-FACH. Keine ERP-Position erforderlich:", value) Then GoTo Finished
    r("AufPos") = "MAN:" & UCase$(Trim$(value)): value = ""
    If Not LB_Ask("Bezeichnung / gewuenschter Labeltext:", value) Then GoTo Finished
    r("Bezeichnung") = value: value = "1"
    If Not LB_Ask("Gesamtbedarf fuer diese Labelart (Bestellmenge danach in der Tabelle aenderbar):", value) Then GoTo Finished
    r("Positionsmenge") = CStr(LB_Quantity(value)): r("Bestellmenge") = r("Positionsmenge")
    value = "": If Not LB_Ask("Artikel-/Zeichnungsnummer, falls vorhanden (sonst leer):", value, True) Then GoTo Finished
    r("ArtikelKunde") = value
    value = "": If Not LB_Ask("KIT / vorhandener Labelcode, falls bekannt (sonst leer):", value, True) Then GoTo Finished
    r("Kit") = value
    value = "": If Not LB_Ask("Bemerkung (optional):", value, True) Then GoTo Finished
    r("Bemerkung") = value: r("Quelle") = "Manuell": LB_CheckRecord r: records.Add r
    LB_AddDrafts records
Finished:
    Call LB_End: Exit Sub
Failed:
    message = Err.Description: Call LB_End: LB_Error message
End Sub

Public Function LB_SelectedRows(ByVal selection As Range) As Object
    Dim result As Object, area As Range, bounded As Range, rowRange As Range, first As Long, last As Long, i As Long
    Set result = LB_Dict()
    If Not selection.Parent Is LB_Sheet Then Err.Raise 5, , "Bitte Bestellzeilen im Blatt Positionen markieren."
    Set bounded = Intersect(selection, LB_Sheet.Range("A" & LB_FIRST & ":Y" & Application.Max(LB_FIRST, LB_LastRow())))
    If bounded Is Nothing Then Set LB_SelectedRows = result: Exit Function
    For Each area In bounded.Areas
        first = area.Row: last = first + area.Rows.Count - 1
        For i = first To last
            If CStr(LB_Sheet.Cells(i, 22).Value2) <> "" Then
                If Not result.Exists(CStr(i)) Then result.Add CStr(i), "1"
            End If
        Next i
    Next area
    Set LB_SelectedRows = result
End Function

Public Sub LB_RestoreRows(ByVal rows As Object)
    Dim key As Variant, r As Object
    If rows Is Nothing Then Exit Sub
    On Error Resume Next
    LB_Sheet.Unprotect
    For Each key In rows.Keys
        Set r = LB_Baseline(CLng(key)): LB_RenderRow CLng(key), r
    Next key
    LB_Summary
    On Error GoTo 0
End Sub

Public Sub LB_SaveRows(ByVal rows As Object, Optional ByVal forceStatus As String = "")
    Dim state As Object, fresh As Object, changes As New Collection, old As Object, r As Object
    Dim key As Variant, id As String, row As Long, desired As String, note As String, history As String
    Dim ordered As Double, rest As Double, stamp As Object, answer As VbMsgBoxResult
    If rows.Count = 0 Then Err.Raise 5, , "Bitte mindestens eine Bestellzeile markieren."
    LB_Lock LB_BaseFolder(): Set state = LB_LoadLocked(): LB_Unlock
    Set stamp = LB_Dict()
    For Each key In rows.Keys
        row = CLng(key): Set old = LB_Baseline(row): id = old("Id")
        If Not state.Exists(id) Then Err.Raise 5, , "Bestellung fehlt zentral. Datenordner/Altbestand pruefen."
        If state(id)("Revision") <> old("Revision") Then Err.Raise 5, , "Bestellung wurde von einer anderen Person geaendert. Bitte zuerst aktualisieren."
        Set r = LB_Copy(state(id))
        desired = CStr(LB_Sheet.Cells(row, 13).Value2)
        If forceStatus <> "" Then desired = forceStatus
        If desired <> "Offen" And desired <> "Bestellt" And desired <> "Eingetroffen" Then Err.Raise 5, , "Ungueltiger Status."
        If old("LabelStat") = "Eingetroffen" And desired <> "Eingetroffen" Then Err.Raise 5, , "Eingetroffene Bestellungen werden nicht zurueckgesetzt."
        If old("LabelStat") = "Bestellt" And desired = "Offen" Then Err.Raise 5, , "Bestellte Vorgaenge werden nicht auf Offen zurueckgesetzt."
        If old("LabelStat") = "Offen" And desired = "Eingetroffen" Then Err.Raise 5, , "Bitte offene Vorgaenge zuerst bestellen."
        r("Bestellmenge") = CStr(LB_Quantity(CStr(LB_Sheet.Cells(row, 14).Value2), True))
        r("Kit") = CStr(LB_Sheet.Cells(row, 15).Value2)
        r("Bemerkung") = CStr(LB_Sheet.Cells(row, 21).Value2)
        If Len(r("Bemerkung")) > 4000 Or Len(r("Kit")) > 2000 Then Err.Raise 5, , "Bemerkung/KIT-Angabe ist zu lang."
        If old("LabelStat") <> "Offen" Then
            If r("Bestellmenge") <> old("Bestellmenge") Or r("Kit") <> old("Kit") Then Err.Raise 5, , "Bestellmenge/KIT sind nach Bestellung fest."
        End If
        If old("LabelStat") = "Offen" And desired = "Bestellt" Then
            history = LB_History(state, r)
            If history <> "" Then
                answer = MsgBox("Projekt " & r("Projekt") & ", Position " & r("AufPos") & " ist bereits erfasst:" & history & vbCrLf & "Weitere " & r("Bestellmenge") & " Label mit KIT '" & r("Kit") & "' bestellen?", vbYesNo + vbExclamation, "Doppelbestellung pruefen")
                If answer <> vbYes Then Err.Raise 5, , "Gesamte Auswahl abgebrochen; nichts gespeichert."
            End If
            ordered = LB_Ordered(state, r): rest = CLng(r("Positionsmenge")) - ordered
            If CLng(r("Bestellmenge")) > rest Then
                If MsgBox("Bestellmenge uebersteigt den Restbedarf (" & CStr(Application.Max(0, rest)) & "). Als bewusste ERSATZBESTELLUNG ausfuehren?", vbYesNo + vbExclamation) <> vbYes Then Err.Raise 5, , "Gesamte Auswahl abgebrochen."
                note = ""
                If Not LB_Ask("Grund fuer die Ersatzbestellung (Pflicht):", note) Then Err.Raise 5, , "Ersatzbestellung abgebrochen."
                r("BestellTyp") = "Ersatzbestellung"
                r("Bemerkung") = r("Bemerkung") & IIf(r("Bemerkung") = "", "", vbLf) & "Ersatz: " & note
            ElseIf ordered > 0 Then
                r("BestellTyp") = "Teilbestellung"
            End If
            r("BestelltAm") = LB_Timestamp()
        End If
        If old("LabelStat") = "Bestellt" And desired = "Eingetroffen" Then r("EingetroffenAm") = LB_Timestamp()
        r("LabelStat") = desired
        If LB_Json(r) <> LB_Json(old) Then
            r("Revision") = CStr(CLng(old("Revision")) + 1)
            changes.Add r
            If Not stamp.Exists(LB_PositionKey(r)) Then stamp.Add LB_PositionKey(r), LB_PositionStamp(state, r)
            ' Include earlier selected orders when checking subsequent selected rows.
            state.Remove id: state.Add id, r
        End If
    Next key
    If changes.Count = 0 Then Exit Sub
    LB_Lock LB_BaseFolder(): Set fresh = LB_LoadLocked()
    ' The stamp for each affected position was taken before the first local change.
    For Each key In stamp.Keys
        For Each r In changes
            If LB_PositionKey(r) = CStr(key) Then
                If LB_PositionStamp(fresh, r) <> stamp(key) Then Err.Raise 5, , "Zwischenzeitlicher Zugriff. Gesamte Auswahl nicht gespeichert; bitte aktualisieren."
                Exit For
            End If
        Next r
    Next key
    LB_CommitLocked changes, fresh: LB_Unlock
    LB_Sheet.Unprotect
    For Each key In rows.Keys
        Set old = LB_Baseline(CLng(key)): LB_RenderRow CLng(key), fresh(old("Id")), fresh
    Next key
    LB_Summary
    LB_Sheet.Range("A5").Value2 = changes.Count & " Bestellung(en) zentral gespeichert: " & Format$(Now, "dd.mm.yyyy hh:nn:ss")
End Sub

Private Sub LB_SetSelectedStatus(ByVal status As String)
    Dim rows As Object, message As String
    If TypeName(Selection) <> "Range" Then MsgBox "Bitte Bestellzeilen markieren.", vbInformation: Exit Sub
    If Not LB_Begin() Then Exit Sub
    On Error GoTo Failed
    Set rows = LB_SelectedRows(Selection)
    LB_SaveRows rows, status
    Call LB_End: Exit Sub
Failed:
    message = Err.Description: LB_RestoreRows rows: Call LB_End: LB_Error message
End Sub

Public Sub LB_Order()
    LB_SetSelectedStatus "Bestellt"
End Sub

Public Sub LB_Receive()
    LB_SetSelectedStatus "Eingetroffen"
End Sub

Public Sub LB_OnChange(ByVal ws As Worksheet, ByVal target As Range)
    Dim watched As Range, rows As Object, message As String
    If LB_Busy Or CStr(ws.Range("AA1").Value2) <> LB_VERSION Then Exit Sub
    Set watched = Intersect(target, Union(ws.Range("M16:O" & Application.Max(16, LB_LastRow())), ws.Range("U16:U" & Application.Max(16, LB_LastRow()))))
    If watched Is Nothing Then Exit Sub
    If Not LB_Begin() Then Exit Sub
    On Error GoTo Failed
    Set rows = LB_SelectedRows(watched): LB_SaveRows rows
    Call LB_End: Exit Sub
Failed:
    message = Err.Description: LB_RestoreRows rows: Call LB_End: LB_Error message
End Sub

Option Explicit

Private Function LegacyTime(ByVal value As String) As String
    Dim d As Date
    If Trim$(value) = "" Then LegacyTime = LB_Timestamp(): Exit Function
    On Error GoTo Failed
    If Len(value) = 19 And Mid$(value, 3, 1) = "." And Mid$(value, 6, 1) = "." Then
        d = DateSerial(CInt(Mid$(value, 7, 4)), CInt(Mid$(value, 4, 2)), CInt(Left$(value, 2))) + TimeSerial(CInt(Mid$(value, 12, 2)), CInt(Mid$(value, 15, 2)), CInt(Right$(value, 2)))
    Else
        d = CDate(value)
    End If
    LegacyTime = Format$(d, "yyyy-mm-dd\Thh:nn:ss"): Exit Function
Failed:
    Err.Raise 5, , "Unbekanntes Datum im Altbestand: " & value
End Function

Public Function LB_LegacyRecord(ByVal old As Object, ByVal reference As String) As Object
    Dim r As Object, keys As Variant, key As Variant, status As String, quantity As String
    Set r = LB_NewRecord(): keys = Array("Projekt", "BestelltFuer", "AufPos", "ArtikelKunde", "EAN", "KdSeriennummer", "ArtikelBezKunde", "Bezeichnung", "ZweiteBezeichnung", "Zeichnung")
    For Each key In keys
        r(key) = LB_Get(old, CStr(key))
    Next key
    If r("Projekt") = "" Then r("Projekt") = LB_Get(old, "Projektnummer")
    If r("ArtikelKunde") = "" Then r("ArtikelKunde") = LB_Get(old, "Artikel")
    If r("BestelltFuer") = "" Then Err.Raise 5, , "Person fehlt im Altbestand: " & reference
    quantity = LB_Get(old, "Menge"): r("Positionsmenge") = CStr(LB_Quantity(quantity, True))
    r("Bestellmenge") = r("Positionsmenge"): r("BestellTyp") = "Altbestand"
    r("ErfasstAm") = LegacyTime(LB_Get(old, "Zeit"))
    status = LB_Get(old, "LabelStat")
    If status = "" Then Err.Raise 5, , "Status fehlt im Altbestand: " & reference
    r("LabelStat") = status
    If status <> "Offen" Then r("BestelltAm") = r("ErfasstAm")
    If status = "Eingetroffen" Then
        r("EingetroffenAm") = r("ErfasstAm")
        r("Bemerkung") = "Altbestand: genaues Eingangsdatum nicht ueberliefert; Zeit aus dem Ursprungsdatensatz."
    End If
    r("Quelle") = "Altbestand"
    r.Add "LegacyRef", reference: r.Add "LegacyRaw", LB_Json(old)
    LB_CheckRecord r: Set LB_LegacyRecord = r
End Function

Private Function LegacySignature(ByVal r As Object) As String
    Dim keys As Variant, key As Variant, result As String, value As String
    keys = Array("Projekt", "BestelltFuer", "AufPos", "ArtikelKunde", "EAN", "KdSeriennummer", "ArtikelBezKunde", "Bezeichnung", "ZweiteBezeichnung", "Zeichnung", "Positionsmenge", "Bestellmenge")
    For Each key In keys
        value = LB_Get(r, CStr(key))
        result = result & CStr(Len(value)) & ":" & value
    Next key
    LegacySignature = result
End Function

Public Function LB_MigrationCandidates(ByVal folder As String, ByVal state As Object, Optional ByVal includeSheet As Boolean = True) As Collection
    Dim fs As Object, f As Object, re As Object, files As Object, path As Variant
    Dim lines As Variant, i As Long, old As Object, r As Object, refs As Object, signatures As Object
    Dim key As Variant, signature As String, text As String, reference As String, candidates As New Collection
    Dim backup As Worksheet, row As Long, fields As Variant, j As Long, value As Variant
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set refs = LB_Dict(): Set signatures = LB_Dict(): Set files = LB_Dict()
    For Each key In state.Keys
        Set r = state(key)
        If LB_Get(r, "LegacyRef") <> "" Then refs.Add LB_Get(r, "LegacyRef"), LB_Get(r, "LegacyRaw")
        signatures(LegacySignature(r)) = "1"
    Next key
    Set re = CreateObject("VBScript.RegExp"): re.Pattern = "^[0-9]{10}_daten\.txt$"
    For Each f In fs.GetFolder(folder).Files
        If re.Test(f.Name) Then files.Add CStr(f.Path), "1"
    Next f
    For Each path In LB_SortedKeys(files)
        text = LB_ReadText(CStr(path), True): lines = Split(Replace(text, vbCrLf, vbLf), vbLf)
        For i = 0 To UBound(lines)
            If Trim$(CStr(lines(i))) <> "" Then
                reference = fs.GetFileName(CStr(path)) & ":" & CStr(i + 1)
                Set old = LB_LegacyJson(CStr(lines(i)))
                If refs.Exists(reference) Then
                    If refs(reference) <> LB_Json(old) Then Err.Raise 5, , "Bereits uebernommene Quelldatei wurde geaendert: " & reference & ". Keine automatische zweite Uebernahme."
                Else
                    Set r = LB_LegacyRecord(old, reference)
                    If Left$(fs.GetFileName(CStr(path)), 10) <> r("Projekt") Then Err.Raise 5, , "Projekt passt nicht zum Dateinamen: " & reference
                    candidates.Add r: signatures(LegacySignature(r)) = "1"
                    refs.Add reference, LB_Json(old)
                End If
            End If
        Next i
    Next path
    If includeSheet Then
        On Error Resume Next
        Set backup = ThisWorkbook.Worksheets("Altbestand")
        On Error GoTo 0
        If Not backup Is Nothing Then
            fields = Array("Projekt", "BestelltFuer", "AufPos", "ArtikelKunde", "EAN", "KdSeriennummer", "ArtikelBezKunde", "Bezeichnung", "ZweiteBezeichnung", "Zeichnung", "Menge", "Status", "LabelStat")
            For row = 2 To backup.Cells(backup.Rows.Count, 1).End(xlUp).Row
                If CStr(backup.Cells(row, 1).Value2) <> "" Then
                    Set old = LB_Dict()
                    For j = 0 To UBound(fields)
                        value = backup.Cells(row, j + 1).Value2
                        If j = 10 Then
                            old.Add CStr(fields(j)), Trim$(Str$(CDbl(value)))
                        ElseIf j = 2 And VarType(value) <> vbString And IsNumeric(value) Then
                            ' Old workbooks stored ERP positions as decimal numbers.
                            old.Add CStr(fields(j)), Replace(Format$(CDbl(value), "0.000"), ",", ".")
                        Else
                            old.Add CStr(fields(j)), CStr(value)
                        End If
                    Next j
                    reference = "Arbeitsmappe:" & CStr(row)
                    Set r = LB_LegacyRecord(old, reference): signature = LegacySignature(r)
                    If Not signatures.Exists(signature) Then
                        If refs.Exists(reference) Then Err.Raise 5, , "Altbestandszeile wurde nach Uebernahme geaendert."
                        r("Bemerkung") = "Aus gesicherter Arbeitsmappe uebernommen; urspruenglicher Erfassungszeitpunkt nicht bekannt."
                        candidates.Add r: signatures.Add signature, "1"
                    End If
                End If
            Next row
        End If
    End If
    Set LB_MigrationCandidates = candidates
End Function

Public Sub LB_Migrate()
    Dim state As Object, fresh As Object, candidates As Collection, current As Collection, i As Long, message As String
    If MsgBox("Altdateien bleiben unveraendert. Vorher den gesamten alten Datenordner privat sichern und ALLE alten Makroversionen ausser Betrieb nehmen. Ist dies erledigt?", vbYesNo + vbExclamation, "Altbestand kontrolliert uebernehmen") <> vbYes Then Exit Sub
    If Not LB_Begin() Then Exit Sub
    On Error GoTo Failed
    LB_Lock LB_BaseFolder(): Set state = LB_LoadLocked()
    Set candidates = LB_MigrationCandidates(LB_BaseFolder(), state)
    LB_Unlock
    If candidates.Count = 0 Then
        MsgBox "Keine neuen Altbestandsdaten vorhanden.", vbInformation: GoTo Finished
    End If
    If MsgBox(CStr(candidates.Count) & " Altbestandsvorgaenge uebernehmen? Die alten Dateien werden weder geaendert noch geloescht.", vbYesNo + vbQuestion) <> vbYes Then GoTo Finished
    LB_Lock LB_BaseFolder(): Set fresh = LB_LoadLocked()
    Set current = LB_MigrationCandidates(LB_BaseFolder(), fresh)
    If current.Count <> candidates.Count Then Err.Raise 5, , "Altbestand wurde zwischenzeitlich geaendert. Bitte erneut pruefen."
    For i = 1 To current.Count
        If current(i)("LegacyRef") <> candidates(i)("LegacyRef") Or current(i)("LegacyRaw") <> candidates(i)("LegacyRaw") Then Err.Raise 5, , "Quelldaten wurden zwischenzeitlich geaendert."
    Next i
    LB_CommitLocked candidates, fresh: LB_Unlock
    LB_RefreshInternal True
Finished:
    Call LB_End: Exit Sub
Failed:
    message = Err.Description: Call LB_End: LB_Error message
End Sub

Option Explicit

Private Sub Workbook_Open()
    LB_OnOpen
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    LB_Unlock
End Sub

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
    If Success Then LB_RebindButtons
End Sub

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    LB_OnChange Me, Target
End Sub