Attribute VB_Name = "Word2HTML"

' =============================================================================
' Word-Makro: SnipBook - Export Filtered HTML + Viewer-Injektion

' Version: 26-04-11-v75  (Mac/Windows kompatibel, Charset-Preflight, Linked-Graphics-Check)
'
' Ziele:
'  - Export aus Word als "Gefilterte Webseite" (Filtered HTML)
'  - Viewer (UI/CSS/JS) aus SnipBook-Tools\{VIEWER_FILE} injizieren
'  - KEINE CDN-Links (nur relative Pfade in Viewer/Tools)
'  - Optional: Ergebnis-HTM automatisch im Standardbrowser öffnen
'
' Änderungen in v74 (konsolidiert):
'  - MapSharePointUrlToLocalFolder: Fix für deutsche OneDrive-Ordnernamen
'    * Sucht nach /Dokumente/ UND /Documents/ in der SharePoint-URL
'    * Hängt den lokalen Ordnernamen explizit wieder an den OneDrive-Root
'  - WriteAllTextUTF8 (Windows):
'    * Schreibt zunächst nach %TEMP%, dann FSO.CopyFile ans Ziel
'    * Bei Blockade durch AV/Sync: Fallback-Speicherung nach %TEMP%\SnipBookWork\
'    * ADODB-Fallback auf Pure-VBA falls ADODB.Stream nicht verfügbar
'    * Zieldatei vor dem Schreiben explizit entsperren (SetAttr + FSO.DeleteFile)
'  - ReadAllTextUTF8 (Windows): ADODB-Fallback auf Pure-VBA
'  - Browser öffnen (Windows): Shell "cmd /c start" ersetzt durch FollowHyperlink
'    * cmd.exe wurde von Bitdefender als SuspiciousBehavior blockiert
'  - STAGE-Marker innerhalb "write" feiner aufgeteilt:
'    write-copy-files / write-htm / write-kill-tmp / write-browser
'  - Error-Handler: Strukturierte Fehlermeldung mit a/b/c-Ursachen
'    und gegliederten Technischen Details
'  - DiagnoseSchreiben(): Neuer Diagnose-Sub zum manuellen Testen
'
' Basis-Versionen:
'  - v50b: Viewer-Suche relativ zum DOTM-Template
'  - v51:  Vollständige Mac-Kompatibilität
'    * CombinePath nutzt Application.PathSeparator (\ vs /)
'    * GetTempWorkFolder: Mac nutzt TMPDIR statt TEMP/TMP
'    * EnsureFolder: Mac-Fallback via VBA MkDir
'    * CopyFolderRecursive: Mac-Fallback via FileCopy Loop
'    * ReadAllTextUTF8: Mac-Fallback via Open...For Input
'    * WriteAllTextUTF8: Mac-Fallback via Open...For Output
'    * RemoveByRegex: Mac-Fallback via Pure-VBA
'    * Browser öffnen: Mac via Shell "open"
'  - v53:  ExtractHtmlAttr, ExtractImgWidth/Height, Video/GIF-Player
' =============================================================================

' >>> Einstellungen <<<
Private Const VIEWER_FOLDER As String = "SnipBook-Tools"
' Immer die zuletzt gelieferte Viewer-Version eintragen:
Private Const VIEWER_FILE As String = "SnipBook-Viewer-Template-V75.html"
Private Const AUTO_OPEN_BROWSER As Boolean = True
Private Const ERROR_LOG_FILE As String = "SnipBook-Fehlerprotokoll.txt"

' Marker (neu)
Private Const MK_HEAD_S As String = "<!--SNIPBOOK:INJECTED_HEAD_START-->"
Private Const MK_HEAD_E As String = "<!--SNIPBOOK:INJECTED_HEAD_END-->"
Private Const MK_UI_S   As String = "<!--SNIPBOOK:INJECTED_UI_START-->"
Private Const MK_UI_E   As String = "<!--SNIPBOOK:INJECTED_UI_END-->"
Private Const MK_JS_S   As String = "<!--SNIPBOOK:INJECTED_JS_START-->"
Private Const MK_JS_E   As String = "<!--SNIPBOOK:INJECTED_JS_END-->"

' Legacy-Kommentare (alt, m?ssen raus)
Private Const LEG_CSS As String = "<!-- SnipBook injected CSS -->"
Private Const LEG_UI  As String = "<!-- SnipBook injected UI -->"
Private Const LEG_JS  As String = "<!-- SnipBook injected JS -->"

' =============================================================================
' Platform-Erkennung
' =============================================================================
Private Function IsMac() As Boolean
    ' VBA-Compiler-Direktive: wird zur Compile-Zeit ausgewertet, funktioniert in Word auf beiden Plattformen.
    ' Application.OperatingSystem existiert in Word VBA nicht (nur in Excel).
    #If Mac Then
        IsMac = True
    #Else
        IsMac = False
    #End If
End Function

' =============================================================================
' Entry point
' =============================================================================
Public Sub Word2HTMLSnipBook()
    On Error GoTo EH

    Dim oldScreenUpdating As Boolean
    Dim oldDisplayAlerts As WdAlertLevel
    oldScreenUpdating = Application.ScreenUpdating
    oldDisplayAlerts = Application.DisplayAlerts
    Application.ScreenUpdating = False

    Dim STAGE As String
    STAGE = "init"

    Dim doc As Document
    Set doc = ActiveDocument

    ' --- Schutz: nicht auf HTML-Dateien laufen lassen ---
    If IsHtmlDocument(doc) Then
        MsgBox "Dieses Makro darf nicht auf einer .htm/.html-Datei ausgef" & Chr(252) & "hrt werden." & vbCrLf & _
               Chr(214) & "ffne bitte das Original-DOCX und starte das Makro erneut." & vbCrLf & vbCrLf & _
               "Aktuelles Dokument: " & doc.Name, vbExclamation
        Exit Sub
    End If

    If Len(doc.path) = 0 Then
        MsgBox "Bitte speichere das Dokument zuerst (DOCX), damit Pfade und Ausgabeordner eindeutig sind.", vbExclamation
        Exit Sub
    End If

    If DocumentHasLinkedGraphics(doc) Then
        MsgBox "Nur importierte Bilder ohne Verkn" & Chr$(252) & "pfung zurzeit erlaubt", vbExclamation, "SnipBook V74"
        Exit Sub
    End If

    Dim localDocFolder As String
    localDocFolder = GetLocalDocFolder(doc)
    If Len(localDocFolder) = 0 Then Err.Raise 5, , "Dokument-Ordner konnte nicht ermittelt werden."

    ' v50b: Viewer wird relativ zum DOTM-Template gesucht (nicht mehr relativ zum DOCX)
    Dim templateFolder As String
    templateFolder = GetTemplateFolder()
    If Len(templateFolder) = 0 Then Err.Raise 5, , "Template-Ordner konnte nicht ermittelt werden. Bitte stelle sicher, dass das Makro aus einem .dotm-Template l" & Chr(228) & "uft."

    Dim viewerPath As String
    viewerPath = FindViewerFile(templateFolder)
    If Len(viewerPath) = 0 Then
        Err.Raise 5, , "Viewer-Datei fehlt im Template-Ordner: " & templateFolder & vbCrLf & _
                       "Suche nach: " & VIEWER_FOLDER & PathSep() & VIEWER_FILE & " oder " & VIEWER_FILE
    End If

    STAGE = "export"
    Dim tmpHtmlPath As String
    tmpHtmlPath = ExportFilteredHtmlToTemp(doc)

    ' OneDrive/AV/Indexing can delay the file becoming readable. Wait + retry.
    STAGE = "wait-file"
    WaitForFileReady tmpHtmlPath, 80, 100

    Dim sourceCharsetReport As String
    sourceCharsetReport = BuildCharsetReport(tmpHtmlPath)

    STAGE = "read"
    Dim wordHtml As String
    wordHtml = ReadAllTextUTF8(tmpHtmlPath)

    STAGE = "read-viewer"
    Dim viewerHtml As String
    viewerHtml = ReadAllTextUTF8(viewerPath)
    ' Defensiv: Alles vor <!DOCTYPE oder <html entfernen (verhindert versehentlichen Dateiname-Pr?fix)
    Dim dtPos As Long
    dtPos = InStr(1, viewerHtml, "<!DOCTYPE", vbTextCompare)
    If dtPos > 1 Then viewerHtml = mid$(viewerHtml, dtPos)

    STAGE = "inject"
    Dim outHtml As String
    outHtml = InjectSnipBook(wordHtml, viewerHtml)

    outHtml = PatchExpandedColor(outHtml, doc)

    STAGE = "patch-video"
    outHtml = PatchVideoPlaceholders(outHtml)

    STAGE = "patch-gif"
    Dim tmpHtmlFolder As String
    tmpHtmlFolder = Left$(tmpHtmlPath, InStrRev(tmpHtmlPath, PathSep()))
    outHtml = PatchGifPlaceholders(outHtml, tmpHtmlFolder)

    STAGE = "write-copy-files"
    Dim outPath As String
    Dim baseNameOut As String
    baseNameOut = FileNameWithoutExt(doc.Name)

    Dim destFolder As String
    destFolder = localDocFolder
    outPath = CombinePath(destFolder, baseNameOut & ".htm")

    ' Ressourcenordner (_files) aus dem Temp-Export uebernehmen
    CopySnipBookResourceFolder tmpHtmlPath, outPath

    STAGE = "normalize-charset"
    outHtml = EnsureUtf8HtmlMeta(outHtml)

    STAGE = "write-htm"
    Dim actualOutPath As String
    actualOutPath = WriteAllTextUTF8(outPath, outHtml)
    ' actualOutPath kann vom Ziel abweichen wenn Bitdefender das Ziel blockiert (Fallback nach %TEMP%)

    STAGE = "write-kill-tmp"
    On Error Resume Next
    kill tmpHtmlPath
    Err.Clear
    On Error GoTo EH

    STAGE = "write-browser"
    If AUTO_OPEN_BROWSER Then
        On Error Resume Next
        #If Mac Then
            Shell "open """ & actualOutPath & """"
        #Else
            ThisDocument.FollowHyperlink Address:=actualOutPath
        #End If
        Err.Clear
        On Error GoTo EH
    End If

    ' Hinweis wenn Fallback-Pfad verwendet wurde
    If actualOutPath <> outPath Then
        MsgBox "=== SnipBook: Achtung ===" & vbCrLf & vbCrLf & _
               "Antivirus-Software hat das Schreiben ins Zielverzeichnis blockiert." & vbCrLf & _
               "Die Datei wurde stattdessen hier gespeichert:" & vbCrLf & vbCrLf & _
               actualOutPath & vbCrLf & vbCrLf & _
               "Erweiterte Bedrohungsabwehr -> Ausnahmen ->" & vbCrLf & _
               "Anwendung hinzufuegen -> WINWORD.EXE", vbExclamation, "SnipBook V74"
    Else
        If Not AUTO_OPEN_BROWSER Then
            MsgBox "SnipBook exportiert:" & vbCrLf & actualOutPath, vbInformation, "SnipBook V74"
        End If
    End If

    doc.Activate
    On Error Resume Next
    ActiveWindow.View.Type = wdPrintView
    On Error GoTo EH

    Dim origPath As String
    origPath = doc.fullName

    If doc.ReadOnly Then
        doc.Close SaveChanges:=wdDoNotSaveChanges
        Set doc = Documents.Open(FileName:=origPath, ReadOnly:=False, AddToRecentFiles:=False)
    End If

CleanExit:
    On Error Resume Next
    Application.DisplayAlerts = oldDisplayAlerts
    Application.ScreenUpdating = oldScreenUpdating
    On Error GoTo 0
    Exit Sub

EH:
    Dim errNum As Long
    Dim errDesc As String
    errNum = Err.Number
    errDesc = Err.Description

    Dim errTemplateFolder As String
    Dim errLocalDocFolder As String
    Dim errViewerPath As String

    On Error Resume Next
    errTemplateFolder = GetTemplateFolder()
    errLocalDocFolder = GetLocalDocFolder(doc)
    If Len(errTemplateFolder) > 0 Then errViewerPath = FindViewerFile(errTemplateFolder)
    On Error GoTo 0

    Dim pL As String
    #If Mac Then
        pL = "Mac"
    #Else
        pL = "Windows"
    #End If

    Dim stageExtra As String
    Select Case STAGE
        Case "read-viewer"
            stageExtra = "Hinweis: Viewer-Datei wurde nicht gefunden oder konnte nicht gelesen werden."
        Case "write-htm", "write-copy-files"
            stageExtra = "Hinweis: Schreiben oder Kopieren im Zielordner wurde blockiert."
        Case "export"
            stageExtra = "Hinweis: Export nach gefiltertem HTML ist fehlgeschlagen."
        Case Else
            stageExtra = ""
    End Select

    Dim errMsg As String
    errMsg = BuildErrorMessage(doc, STAGE, errNum, errDesc, pL, errLocalDocFolder, errTemplateFolder, errViewerPath, stageExtra)

    Dim logPath As String
    logPath = WriteSnipBookLogBesideDocumentOrTemplate(doc, errLocalDocFolder, errTemplateFolder, errMsg)
    If Len(logPath) > 0 Then
        errMsg = Left$(errMsg, 1800) & vbCrLf & vbCrLf & _
                 "Vollst" & Chr$(228) & "ndiges Fehlerprotokoll:" & vbCrLf & logPath
    End If

    On Error Resume Next
    Application.DisplayAlerts = oldDisplayAlerts
    Application.ScreenUpdating = oldScreenUpdating
    On Error GoTo 0

    MsgBox errMsg, vbCritical, "SnipBook V74"
    GoTo CleanExit
End Sub


' =============================================================================
' Entry point: Reines Word-HTML ? OHNE SnipBook-Injektion (Debugging)
' Dateiname: <DocName>-WordDirekt.htm  (neben dem DOCX)
' =============================================================================
Public Sub Word2HTMLDirekt()
    On Error GoTo EH

    Dim oldScreenUpdating As Boolean
    Dim oldDisplayAlerts As WdAlertLevel
    oldScreenUpdating = Application.ScreenUpdating
    oldDisplayAlerts = Application.DisplayAlerts
    Application.ScreenUpdating = False

    Dim STAGE As String
    STAGE = "init"

    Dim doc As Document
    Set doc = ActiveDocument

    ' Schutz: nicht auf HTML-Dateien laufen lassen
    If IsHtmlDocument(doc) Then
        MsgBox "Dieses Makro darf nicht auf einer .htm/.html-Datei ausgef" & Chr(252) & "hrt werden." & vbCrLf & _
               "Bitte das Original-DOCX " & Chr(246) & "ffnen und erneut starten." & vbCrLf & vbCrLf & _
               "Aktuelles Dokument: " & doc.Name, vbExclamation
        Exit Sub
    End If

    If Len(doc.path) = 0 Then
        MsgBox "Bitte das Dokument zuerst speichern (DOCX).", vbExclamation
        Exit Sub
    End If

    If DocumentHasLinkedGraphics(doc) Then
        MsgBox "Nur importierte Bilder ohne Verkn" & Chr$(252) & "pfung zurzeit erlaubt", vbExclamation, "SnipBook V74"
        Exit Sub
    End If

    Dim localDocFolder As String
    localDocFolder = GetLocalDocFolder(doc)
    If Len(localDocFolder) = 0 Then Err.Raise 5, , "Dokument-Ordner konnte nicht ermittelt werden."

    ' Export nach Temp
    STAGE = "export"
    Dim tmpHtmlPath As String
    tmpHtmlPath = ExportFilteredHtmlToTemp(doc)

    ' Warten bis Datei lesbar
    STAGE = "wait-file"
    WaitForFileReady tmpHtmlPath, 80, 100

    ' Word-HTML einlesen
    Dim sourceCharsetReport As String
    sourceCharsetReport = BuildCharsetReport(tmpHtmlPath)

    STAGE = "read"
    Dim wordHtml As String
    wordHtml = ReadAllTextUTF8(tmpHtmlPath)
    wordHtml = EnsureUtf8HtmlMeta(wordHtml)

    ' Ausgabepfad: <DocName>-WordDirekt.htm
    STAGE = "write"
    Dim baseName As String
    baseName = FileNameWithoutExt(doc.Name)

    Dim outPath As String
    outPath = CombinePath(localDocFolder, baseName & "-WordDirekt.htm")

    ' Ressourcenordner (_files) kopieren
    CopySnipBookResourceFolder tmpHtmlPath, outPath

    ' Reines Word-HTML schreiben
    WriteAllTextUTF8 outPath, wordHtml

    ' Temp aufr" & Chr(228) & "umen
    On Error Resume Next
    kill tmpHtmlPath
    On Error GoTo EH

    ' Browser oeffnen
    #If Mac Then
        Shell "open """ & outPath & """"
    #Else
        On Error Resume Next
        ThisDocument.FollowHyperlink Address:=outPath
        On Error GoTo 0
    #End If

CleanExit:
    On Error Resume Next
    Application.DisplayAlerts = oldDisplayAlerts
    Application.ScreenUpdating = oldScreenUpdating
    On Error GoTo 0
    Exit Sub

EH:
    On Error Resume Next
    Application.DisplayAlerts = oldDisplayAlerts
    Application.ScreenUpdating = oldScreenUpdating
    On Error GoTo 0

    MsgBox "Word2HTMLDirekt ? Fehler in Stage: " & STAGE & vbCrLf & _
           "Err " & Err.Number & ": " & Err.Description, vbCritical
    GoTo CleanExit
End Sub

' =============================================================================
' Platform-Hilfsfunktion: Pfad-Trenner
' =============================================================================
Private Function PathSep() As String
    ' Application.PathSeparator liefert "\" auf Windows, "/" auf Mac
    PathSep = Application.PathSeparator
End Function

' =============================================================================
' Export: Filtered HTML to temp file
' =============================================================================
Private Function ExportFilteredHtmlToTemp(ByVal doc As Document) As String
    On Error GoTo EH

    Dim workRoot As String
    Dim stamp As String
    Dim workFolder As String
    Dim baseName As String
    Dim tmpHtml As String
    Dim tmpDocx As String

    Dim oldAlerts As WdAlertLevel
    Dim tmpDoc As Document
    Dim tmpBuild As Document
    Dim errSaveCopy As Long

    workRoot = GetTempWorkFolder()
    EnsureFolder workRoot

    stamp = Format$(Now, "yyyymmdd-hhnnss")
    workFolder = CombinePath(workRoot, FileNameWithoutExt(doc.Name) & "-" & stamp)
    EnsureFolder workFolder

    baseName = FileNameWithoutExt(doc.Name)
    tmpHtml = CombinePath(workFolder, baseName & ".htm")
    tmpDocx = CombinePath(workFolder, baseName & "-SnipBook-TMP-EXPORT.docx")

    oldAlerts = Application.DisplayAlerts
    Application.DisplayAlerts = wdAlertsNone

    On Error Resume Next
    doc.SaveCopyAs tmpDocx
    errSaveCopy = Err.Number
    Err.Clear
    On Error GoTo EH

    If errSaveCopy <> 0 Then
        Set tmpBuild = Documents.Add

        On Error Resume Next
        CopyCustomStyles doc, tmpBuild
        On Error GoTo EH

        tmpBuild.content.FormattedText = doc.content.FormattedText
        tmpBuild.SaveAs2 FileName:=tmpDocx, FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
        tmpBuild.Close SaveChanges:=wdDoNotSaveChanges
        Set tmpBuild = Nothing
    End If

    Set tmpDoc = Documents.Open(FileName:=tmpDocx, ReadOnly:=False, AddToRecentFiles:=False)
    tmpDoc.SaveAs2 FileName:=tmpHtml, FileFormat:=wdFormatFilteredHTML, LockComments:=False, AddToRecentFiles:=False
    tmpDoc.Close SaveChanges:=wdDoNotSaveChanges
    Set tmpDoc = Nothing

    Application.DisplayAlerts = oldAlerts
    ExportFilteredHtmlToTemp = tmpHtml
    Exit Function

EH:
    On Error Resume Next
    If Not tmpDoc Is Nothing Then tmpDoc.Close SaveChanges:=wdDoNotSaveChanges
    If Not tmpBuild Is Nothing Then tmpBuild.Close SaveChanges:=wdDoNotSaveChanges
    Application.DisplayAlerts = oldAlerts
    On Error GoTo 0
    Err.Raise Err.Number, "ExportFilteredHtmlToTemp", Err.Description
End Function


' =============================================================================
' Injection
' =============================================================================
Private Function InjectSnipBook(ByVal wordHtml As String, ByVal viewerHtml As String) As String
    wordHtml = RemoveExistingSnipBookBlocks(wordHtml)

    Dim snipCss As String, snipUi As String, snipJs As String

    snipCss = ExtractBetweenAny(viewerHtml, "<!--SNIPBOOK:HEAD_START-->", "<!--SNIPBOOK:HEAD_END-->", _
                                "<!--SNIPBOOK:CSS_START-->", "<!--SNIPBOOK:CSS_END-->")
    If Len(Trim$(snipCss)) = 0 Then
        snipCss = ExtractBetweenAny(viewerHtml, "<!--SNIPBOOK:INJECTED_HEAD_START-->", "<!--SNIPBOOK:INJECTED_HEAD_END-->", _
                                    "/*SNIPBOOK:CSS_START*/", "/*SNIPBOOK:CSS_END*/")
    End If
    If Len(Trim$(snipCss)) = 0 Then
        snipCss = ExtractTagBlockById(viewerHtml, "style", "snipbook-viewer-css")
    End If

    snipUi = ExtractBetweenAny(viewerHtml, "<!--SNIPBOOK:UI_START-->", "<!--SNIPBOOK:UI_END-->", _
                               "<!--SNIPBOOK:INJECTED_UI_START-->", "<!--SNIPBOOK:INJECTED_UI_END-->")

    snipJs = ExtractBetweenAny(viewerHtml, "<!--SNIPBOOK:JS_START-->", "<!--SNIPBOOK:JS_END-->", _
                               "<!--SNIPBOOK:INJECTED_JS_START-->", "<!--SNIPBOOK:INJECTED_JS_END-->")

    If Len(Trim$(snipJs)) = 0 Then
        snipJs = ExtractSnipBookScriptBundle(viewerHtml)
    End If

    If Len(Trim$(snipJs)) = 0 Then
        snipJs = ExtractTagBlockById(viewerHtml, "script", "snipbook-viewer-js")
    End If

    Dim headBlock As String, uiBlock As String, jsBlock As String
    headBlock = snipCss
    uiBlock = snipUi
    jsBlock = snipJs

    headBlock = PrefixToolPaths(headBlock)
    jsBlock = PrefixToolPaths(jsBlock)

    If Len(Trim$(headBlock)) = 0 Then Err.Raise 5, , "Viewer HEAD Block leer."
    If Len(Trim$(uiBlock)) = 0 Then Err.Raise 5, , "Viewer UI Block leer."
    If Len(Trim$(jsBlock)) = 0 Then Err.Raise 5, , "Viewer JS Block leer."

    ' Viewport Meta-Tag
    Dim viewportTag As String
    viewportTag = "<meta name=""viewport"" content=""width=device-width, initial-scale=1.0"" />"

    If InStr(1, wordHtml, "name=""viewport""", vbTextCompare) = 0 And _
       InStr(1, wordHtml, "name='viewport'", vbTextCompare) = 0 Then
        Dim headPos As Long
        headPos = InStr(1, wordHtml, "<head>", vbTextCompare)
        If headPos > 0 Then
            wordHtml = Left$(wordHtml, headPos + Len("<head>") - 1) & vbCrLf & viewportTag & vbCrLf & mid$(wordHtml, headPos + Len("<head>"))
        End If
    End If

    wordHtml = InsertBeforeCloseTag(wordHtml, "head", vbCrLf & MK_HEAD_S & vbCrLf & headBlock & vbCrLf & MK_HEAD_E & vbCrLf)
    wordHtml = InsertAfterBodyOpen(wordHtml, vbCrLf & MK_UI_S & vbCrLf & uiBlock & vbCrLf & MK_UI_E & vbCrLf)
    wordHtml = InsertBeforeCloseTag(wordHtml, "body", vbCrLf & MK_JS_S & vbCrLf & jsBlock & vbCrLf & MK_JS_E & vbCrLf)

    InjectSnipBook = wordHtml
End Function

' =============================================================================
' Remove existing SnipBook blocks
' =============================================================================
Private Function RemoveExistingSnipBookBlocks(ByVal html As String) As String
    Do While InStr(1, html, MK_HEAD_S, vbTextCompare) > 0 And InStr(1, html, MK_HEAD_E, vbTextCompare) > 0
        html = RemoveBetweenInclusive(html, MK_HEAD_S, MK_HEAD_E)
    Loop
    Do While InStr(1, html, MK_UI_S, vbTextCompare) > 0 And InStr(1, html, MK_UI_E, vbTextCompare) > 0
        html = RemoveBetweenInclusive(html, MK_UI_S, MK_UI_E)
    Loop
    Do While InStr(1, html, MK_JS_S, vbTextCompare) > 0 And InStr(1, html, MK_JS_E, vbTextCompare) > 0
        html = RemoveBetweenInclusive(html, MK_JS_S, MK_JS_E)
    Loop

    html = RemoveLegacyInjectedBlock(html, LEG_CSS)
    html = RemoveLegacyInjectedBlock(html, LEG_UI)
    html = RemoveLegacyInjectedBlock(html, LEG_JS)

    html = RemoveByRegex(html, "<div[^>]+id=""snipbook-source""[\s\S]*?</div>")
    html = RemoveByRegex(html, "<script[\s\S]*?src\s*=\s*[""" & Chr$(39) & "']https?://[^""" & Chr$(39) & "']*(jquery|slick)[^""" & Chr$(39) & "']*[""" & Chr$(39) & "'][\s\S]*?</script>")
    html = RemoveByRegex(html, "<link[\s\S]*?href\s*=\s*[""" & Chr$(39) & "']https?://[^""" & Chr$(39) & "']*(slick)[^""" & Chr$(39) & "']*[""" & Chr$(39) & "'][\s\S]*?>")

    RemoveExistingSnipBookBlocks = html
End Function

Private Function RemoveLegacyInjectedBlock(ByVal html As String, ByVal legacyMarker As String) As String
    Dim p As Long
    p = InStr(1, html, legacyMarker, vbTextCompare)
    If p = 0 Then
        RemoveLegacyInjectedBlock = html
        Exit Function
    End If

    Dim pEnd As Long
    pEnd = InStr(p, html, "</style>", vbTextCompare)
    If pEnd > 0 Then
        pEnd = pEnd + Len("</style>")
        RemoveLegacyInjectedBlock = Left$(html, p - 1) & mid$(html, pEnd + 1)
        Exit Function
    End If

    pEnd = InStr(p, html, "</script>", vbTextCompare)
    If pEnd > 0 Then
        pEnd = pEnd + Len("</script>")
        RemoveLegacyInjectedBlock = Left$(html, p - 1) & mid$(html, pEnd + 1)
        Exit Function
    End If

    RemoveLegacyInjectedBlock = Replace$(html, legacyMarker, "", 1, -1, vbTextCompare)
End Function

' =============================================================================
' HTML insertion helpers
' =============================================================================
Private Function InsertBeforeCloseTag(ByVal html As String, ByVal tagName As String, ByVal insertText As String) As String
    Dim closeTag As String
    closeTag = "</" & tagName & ">"
    Dim p As Long
    p = InStr(1, html, closeTag, vbTextCompare)
    If p = 0 Then Err.Raise 5, , "Tag nicht gefunden: " & closeTag
    InsertBeforeCloseTag = Left$(html, p - 1) & insertText & mid$(html, p)
End Function

Private Function InsertAfterBodyOpen(ByVal html As String, ByVal insertText As String) As String
    Dim pBody As Long
    pBody = InStr(1, html, "<body", vbTextCompare)
    If pBody = 0 Then Err.Raise 5, , "<body> nicht gefunden."
    Dim pGT As Long
    pGT = InStr(pBody, html, ">", vbTextCompare)
    If pGT = 0 Then Err.Raise 5, , "<body ...> Abschluss '>' nicht gefunden."
    InsertAfterBodyOpen = Left$(html, pGT) & insertText & mid$(html, pGT + 1)
End Function

Private Function ExtractBetween(ByVal s As String, ByVal a As String, ByVal b As String) As String
    Dim p1 As Long, p2 As Long
    p1 = InStr(1, s, a, vbTextCompare)
    If p1 = 0 Then Exit Function
    p1 = p1 + Len(a)
    p2 = InStr(p1, s, b, vbTextCompare)
    If p2 = 0 Then Exit Function
    ExtractBetween = mid$(s, p1, p2 - p1)
End Function

Private Function ExtractBetweenAny(ByVal Text As String, ByVal startA As String, ByVal endA As String, ByVal startB As String, ByVal endB As String) As String
    Dim tmp As String
    tmp = ExtractBetween(Text, startA, endA)
    If Len(tmp) > 0 Then
        ExtractBetweenAny = tmp
        Exit Function
    End If
    ExtractBetweenAny = ExtractBetween(Text, startB, endB)
End Function

Function ExtractTagBlockById(ByVal html As String, ByVal tagName As String, ByVal idValue As String) As String
    Dim pid As Long, pTagStart As Long, pTagEnd As Long, pClose As Long
    pid = InStr(1, html, "id=""" & idValue & """", vbTextCompare)
    If pid = 0 Then Exit Function
    pTagStart = InStrRev(html, "<" & tagName, pid, vbTextCompare)
    If pTagStart = 0 Then Exit Function
    pTagEnd = InStr(pid, html, ">", vbTextCompare)
    If pTagEnd = 0 Then Exit Function
    pClose = InStr(pTagEnd + 1, html, "</" & tagName & ">", vbTextCompare)
    If pClose = 0 Then Exit Function
    ExtractTagBlockById = mid$(html, pTagEnd + 1, pClose - (pTagEnd + 1))
End Function

Private Function RemoveBetweenInclusive(ByVal s As String, ByVal a As String, ByVal b As String) As String
    Dim p1 As Long, p2 As Long
    p1 = InStr(1, s, a, vbTextCompare)
    If p1 = 0 Then
        RemoveBetweenInclusive = s
        Exit Function
    End If
    p2 = InStr(p1, s, b, vbTextCompare)
    If p2 = 0 Then
        RemoveBetweenInclusive = s
        Exit Function
    End If
    p2 = p2 + Len(b)
    RemoveBetweenInclusive = Left$(s, p1 - 1) & mid$(s, p2 + 1)
End Function

' =============================================================================
' Regex helper
' Windows: VBScript.RegExp
' Mac:     Pure-VBA Fallback (entfernt den Block zwischen erstem Tag-Paar)
' =============================================================================
Private Function RemoveByRegex(ByVal s As String, ByVal pattern As String) As String
    #If Mac Then
        ' Mac hat kein VBScript.RegExp.
        ' Fallback: einfache Tag-Block-Entfernung f?r die zwei bekannten Muster.
        RemoveByRegex = RemoveByRegexMacFallback(s, pattern)
    #Else
        Dim re As Object
        Set re = CreateObject("VBScript.RegExp")
        re.pattern = pattern
        re.Global = True
        re.IgnoreCase = True
        re.Multiline = True
        RemoveByRegex = re.Replace(s, "")
    #End If
End Function

' Mac-Fallback: erkennt die zwei konkreten Muster aus RemoveExistingSnipBookBlocks
Private Function RemoveByRegexMacFallback(ByVal s As String, ByVal pattern As String) As String
    Dim result As String
    result = s

    ' Muster 1: <div id="snipbook-source"...>...</div>
    If InStr(1, pattern, "snipbook-source", vbTextCompare) > 0 Then
        result = RemoveTagBlock(result, "<div", "id=""snipbook-source""", "</div>")

    ' Muster 2: <script src="...jquery/slick...">...</script>
    ElseIf InStr(1, pattern, "jquery", vbTextCompare) > 0 Or _
           InStr(1, pattern, "slick", vbTextCompare) > 0 Then
        ' Alle <script src="https://...jquery/slick..."> entfernen
        Dim pS As Long, pe As Long
        Dim searchFrom As Long
        searchFrom = 1
        Do
            pS = InStr(searchFrom, result, "<script", vbTextCompare)
            If pS = 0 Then Exit Do
            pe = InStr(pS, result, "</script>", vbTextCompare)
            If pe = 0 Then Exit Do
            pe = pe + Len("</script>")
            Dim block As String
            block = mid$(result, pS, pe - pS)
            Dim hasCDN As Boolean
            hasCDN = (InStr(1, block, "https://", vbTextCompare) > 0) And _
                     ((InStr(1, block, "jquery", vbTextCompare) > 0) Or _
                      (InStr(1, block, "slick", vbTextCompare) > 0))
            If hasCDN Then
                result = Left$(result, pS - 1) & mid$(result, pe)
                searchFrom = pS
            Else
                searchFrom = pS + 1
            End If
        Loop

    ' Muster 3: <link href="https://...slick...">
    ElseIf InStr(1, pattern, "<link", vbTextCompare) > 0 Then
        Dim pL As Long, pLE As Long
        Dim sfL As Long
        sfL = 1
        Do
            pL = InStr(sfL, result, "<link", vbTextCompare)
            If pL = 0 Then Exit Do
            pLE = InStr(pL, result, ">", vbTextCompare)
            If pLE = 0 Then Exit Do
            pLE = pLE + 1
            Dim lblock As String
            lblock = mid$(result, pL, pLE - pL)
            Dim hasCDNLink As Boolean
            hasCDNLink = (InStr(1, lblock, "https://", vbTextCompare) > 0) And _
                         (InStr(1, lblock, "slick", vbTextCompare) > 0)
            If hasCDNLink Then
                result = Left$(result, pL - 1) & mid$(result, pLE)
                sfL = pL
            Else
                sfL = pL + 1
            End If
        Loop
    End If

    RemoveByRegexMacFallback = result
End Function

' Hilfsfunktion: entfernt einen Tag-Block der ein bestimmtes Attribut enth?lt
Private Function RemoveTagBlock(ByVal s As String, ByVal openTag As String, ByVal attrHint As String, ByVal closeTag As String) As String
    Dim result As String
    result = s
    Dim searchFrom As Long
    searchFrom = 1
    Do
        Dim pOpen As Long
        pOpen = InStr(searchFrom, result, openTag, vbTextCompare)
        If pOpen = 0 Then Exit Do
        Dim pClose As Long
        pClose = InStr(pOpen, result, closeTag, vbTextCompare)
        If pClose = 0 Then Exit Do
        pClose = pClose + Len(closeTag)
        Dim blk As String
        blk = mid$(result, pOpen, pClose - pOpen)
        If InStr(1, blk, attrHint, vbTextCompare) > 0 Then
            result = Left$(result, pOpen - 1) & mid$(result, pClose)
            searchFrom = pOpen
        Else
            searchFrom = pOpen + 1
        End If
    Loop
    RemoveTagBlock = result
End Function

' =============================================================================
' Safety: refuse to run on HTML documents
' =============================================================================
Private Function IsHtmlDocument(ByVal doc As Document) As Boolean
    Dim n As String
    n = LCase$(doc.Name)
    IsHtmlDocument = (Right$(n, 4) = ".htm") Or (Right$(n, 5) = ".html") Or _
                     (Right$(n, 4) = ".mht") Or (Right$(n, 5) = ".mhtml")
End Function

' =============================================================================
' Temp-Ordner
' Windows: TEMP / TMP / C:\Temp
' Mac:     TMPDIR (z.B. /var/folders/... oder /tmp)
' =============================================================================
Private Function GetTempWorkFolder() As String
    Dim base As String
    #If Mac Then
        base = Environ$("TMPDIR")
        If Len(base) = 0 Then base = "/tmp"
        ' Mac-Pfade enden oft auf "/" ? Trailing-Slash entfernen
        If Right$(base, 1) = "/" Then base = Left$(base, Len(base) - 1)
    #Else
        base = Environ$("TEMP")
        If Len(base) = 0 Then base = Environ$("TMP")
        If Len(base) = 0 Then base = "C:\Temp"
    #End If
    GetTempWorkFolder = CombinePath(base, "SnipBookWork")
End Function

' =============================================================================
' Viewer-Datei suchen
' =============================================================================
Private Function FindViewerFile(ByVal searchFolder As String) As String
    Dim p1 As String, p2 As String
    p1 = CombinePath(CombinePath(searchFolder, VIEWER_FOLDER), VIEWER_FILE)
    If Dir$(p1, vbNormal) <> "" Then
        FindViewerFile = p1
        Exit Function
    End If
    p2 = CombinePath(searchFolder, VIEWER_FILE)
    If Dir$(p2, vbNormal) <> "" Then
        FindViewerFile = p2
        Exit Function
    End If
    FindViewerFile = ""
End Function

' =============================================================================
' Ordner erstellen
' Windows: Scripting.FileSystemObject
' Mac:     VBA MkDir (rekursiv)
' =============================================================================
Private Sub EnsureFolder(ByVal folderPath As String)
    #If Mac Then
        EnsureFolderMac folderPath
    #Else
        Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        If Not fso.FolderExists(folderPath) Then
            fso.CreateFolder folderPath
        End If
    #End If
End Sub

#If Mac Then
' Mac: erstellt Ordner rekursiv mit MkDir
Private Sub EnsureFolderMac(ByVal folderPath As String)
    If Dir$(folderPath, vbDirectory) <> "" Then Exit Sub ' existiert bereits

    ' ?bergeordneten Ordner zuerst sicherstellen
    Dim sep As String
    sep = PathSep()
    Dim parentPath As String
    Dim lastSep As Long
    lastSep = 0
    Dim i As Long
    For i = Len(folderPath) To 1 Step -1
        If mid$(folderPath, i, 1) = sep Then
            lastSep = i
            Exit For
        End If
    Next i

    If lastSep > 1 Then
        parentPath = Left$(folderPath, lastSep - 1)
        If Dir$(parentPath, vbDirectory) = "" Then
            EnsureFolderMac parentPath
        End If
    End If

    On Error Resume Next
    MkDir folderPath
    On Error GoTo 0
End Sub
#End If

' =============================================================================
' Ordner rekursiv kopieren
' Windows: Scripting.FileSystemObject.CopyFolder
' Mac:     VBA FileCopy Loop
' =============================================================================
Private Sub CopyFolderRecursive(ByVal srcFolder As String, ByVal dstFolder As String)
    #If Mac Then
        CopyFolderRecursiveMac srcFolder, dstFolder
    #Else
        Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        If Not fso.FolderExists(srcFolder) Then Exit Sub
        If fso.FolderExists(dstFolder) Then
            On Error Resume Next
            fso.DeleteFolder dstFolder, True
            On Error GoTo 0
        End If
        fso.CopyFolder srcFolder, dstFolder, True
    #End If
End Sub

#If Mac Then
' Mac: kopiert Ordnerinhalt rekursiv mit FileCopy
Private Sub CopyFolderRecursiveMac(ByVal srcFolder As String, ByVal dstFolder As String)
    If Dir$(srcFolder, vbDirectory) = "" Then Exit Sub

    EnsureFolderMac dstFolder

    Dim sep As String
    sep = PathSep()

    ' Dateien kopieren
    Dim f As String
    f = Dir$(CombinePath(srcFolder, "*"), vbNormal)
    Do While f <> ""
        On Error Resume Next
        FileCopy CombinePath(srcFolder, f), CombinePath(dstFolder, f)
        On Error GoTo 0
        f = Dir$
    Loop

    ' Unterordner rekursiv
    Dim d As String
    d = Dir$(CombinePath(srcFolder, "*"), vbDirectory)
    Do While d <> ""
        If d <> "." And d <> ".." Then
            CopyFolderRecursiveMac CombinePath(srcFolder, d), CombinePath(dstFolder, d)
        End If
        d = Dir$
    Loop
End Sub
#End If

' =============================================================================
' Ressourcenordner kopieren
' =============================================================================
Private Function HtmlFilesFolderWithSuffix(ByVal htmPath As String, ByVal suffix As String) As String
    Dim base As String
    base = Left$(htmPath, InStrRev(htmPath, ".") - 1)
    HtmlFilesFolderWithSuffix = base & suffix
End Function

Private Function HtmlFilesSuffix(ByVal htmPath As String) As String
    Dim base As String
    base = Left$(htmPath, InStrRev(htmPath, ".") - 1)

    If Dir$(base & "_files", vbDirectory) <> "" Then
        HtmlFilesSuffix = "_files"
        Exit Function
    End If
    If Dir$(base & "-Dateien", vbDirectory) <> "" Then
        HtmlFilesSuffix = "-Dateien"
        Exit Function
    End If
    If Dir$(base & "_Dateien", vbDirectory) <> "" Then
        HtmlFilesSuffix = "_Dateien"
        Exit Function
    End If

    If Dir$(base & ".fld", vbDirectory) <> "" Then
        HtmlFilesSuffix = ".fld"
        Exit Function
    End If

    HtmlFilesSuffix = ""
End Function

Private Sub CopySnipBookResourceFolder(ByVal tmpHtm As String, ByVal outHtm As String)
    On Error GoTo EH
    Dim suf As String
    suf = HtmlFilesSuffix(tmpHtm)


    If Len(suf) = 0 Then Exit Sub

    Dim srcFolder As String, dstFolder As String
    srcFolder = HtmlFilesFolderWithSuffix(tmpHtm, suf)
    dstFolder = HtmlFilesFolderWithSuffix(outHtm, suf)

    #If Mac Then
        ' Mac: MacScript/do shell script ist synchron und umgeht VBA-Sandbox
        On Error Resume Next
        MacScript "do shell script ""rm -rf '" & Replace(dstFolder, "'", "'\''") & "'"""
        MacScript "do shell script ""cp -R '" & Replace(srcFolder, "'", "'\''") & "' '" & Replace(dstFolder, "'", "'\''") & "'"""
        On Error GoTo EH
    #Else
        If Dir$(dstFolder, vbDirectory) <> "" Then
            Dim fso As Object
            Set fso = CreateObject("Scripting.FileSystemObject")
            On Error Resume Next
            fso.DeleteFolder dstFolder, True
            On Error GoTo EH
        End If
        CopyFolderRecursive srcFolder, dstFolder
    #End If

    Exit Sub
EH:
    ' Ressourcenordner ist nice-to-have, nicht fatal.
End Sub

' =============================================================================
' File readiness
' =============================================================================
Private Sub WaitForFileReady(ByVal filePath As String, ByVal maxTries As Long, ByVal sleepMs As Long)
    Dim i As Long
    For i = 1 To maxTries
        If Dir$(filePath, vbNormal) <> "" Then
            If CanOpenForRead(filePath) Then Exit Sub
        End If
        DoEvents
        DelayMilliseconds sleepMs
    Next i
    Err.Raise 3002, , "Die Datei konnte nicht ge" & Chr(246) & "ffnet werden: " & filePath
End Sub

Private Function CanOpenForRead(ByVal filePath As String) As Boolean
    On Error GoTo NO
    Dim ff As Integer
    ff = FreeFile
    Open filePath For Binary Access Read As #ff
    Close #ff
    CanOpenForRead = True
    Exit Function
NO:
    On Error Resume Next
    If ff <> 0 Then Close #ff
    CanOpenForRead = False
End Function

Private Sub DelayMilliseconds(ByVal ms As Long)
    Dim startT As Double, nowT As Double
    startT = CDbl(Timer)
    Do
        DoEvents
        nowT = CDbl(Timer)
        If nowT < startT Then nowT = nowT + 86400#
    Loop While (nowT - startT) * 1000# < ms
End Sub

' =============================================================================
' Datei lesen (UTF-8)
' Windows: ADODB.Stream
' Mac:     VBA Open...For Input (Mac Office liest UTF-8 nativ)
' =============================================================================
Private Function ReadAllTextUTF8(ByVal filePath As String) As String
    Dim enc As String
    enc = DetectFileEncoding(filePath)

    #If Mac Then
        ReadAllTextUTF8 = ReadAllTextMacDetected(filePath, enc)
    #Else
        ReadAllTextUTF8 = ReadAllTextWindowsDetected(filePath, enc)
    #End If
End Function

#If Mac Then
Private Function ReadAllTextMacDetected(ByVal filePath As String, ByVal enc As String) As String
    ' Mac: vorhandenes robustes Textlesen beibehalten.
    ' Wenn Word bereits UTF-8 exportiert, bleiben Umlaute damit stabil.
    Dim ff As Integer
    Dim s As String
    ff = FreeFile
    Open filePath For Input As #ff
    s = Input$(LOF(ff), #ff)
    Close #ff
    ReadAllTextMacDetected = s
End Function
#Else
Private Function ReadAllTextWindowsDetected(ByVal filePath As String, ByVal enc As String) As String
    On Error GoTo FallbackRead
    Dim stm As Object
    Set stm = CreateObject("ADODB.Stream")
    stm.Type = 2
    stm.Charset = MapEncodingToAdoCharset(enc)
    stm.Open
    stm.LoadFromFile filePath
    ReadAllTextWindowsDetected = stm.ReadText(-1)
    stm.Close
    Exit Function

FallbackRead:
    On Error GoTo 0
    Dim ff As Integer
    ff = FreeFile
    Dim fileSz As Long
    fileSz = fileLen(filePath)
    If fileSz = 0 Then
        ReadAllTextWindowsDetected = ""
        Exit Function
    End If

    Dim rawBytes() As Byte
    ReDim rawBytes(fileSz - 1)
    Open filePath For Binary Access Read As #ff
    Get #ff, , rawBytes
    Close #ff

    If LCase$(enc) = "utf-16le" Or LCase$(enc) = "unicode" Then
        ReadAllTextWindowsDetected = StrConv(rawBytes, vbUnicode)
    Else
        ReadAllTextWindowsDetected = StrConv(rawBytes, vbUnicode)
    End If
End Function
#End If

' =============================================================================
' Datei schreiben (UTF-8)
' Windows: ADODB.Stream
' Mac:     VBA Open...For Output mit StrConv
' =============================================================================
Private Function WriteAllTextUTF8(ByVal filePath As String, ByVal content As String) As String
    ' Rueckgabewert: tatsaechlicher Pfad der geschriebenen Datei (kann Fallback-Pfad sein)
    WriteAllTextUTF8 = filePath
    #If Mac Then
        WriteAllTextMac filePath, content
    #Else
        ' v79: Zieldatei entsperren/loeschen falls vorhanden
        On Error Resume Next
        If Dir$(filePath, vbNormal) <> "" Then
            SetAttr filePath, vbNormal
            Dim fso0 As Object
            Set fso0 = CreateObject("Scripting.FileSystemObject")
            If Err.Number = 0 Then
                fso0.DeleteFile filePath, True
            Else
                kill filePath
            End If
        End If
        Err.Clear
        On Error GoTo 0

        ' Schritt 1: In %TEMP% schreiben
        Dim tmpPath As String
        tmpPath = Environ$("TEMP") & "\snipbook_out_tmp.htm"

        On Error Resume Next
        Err.Clear
        Dim stm As Object
        Set stm = CreateObject("ADODB.Stream")
        If Err.Number = 0 Then
            stm.Type = 2
            stm.Charset = "utf-8"
            stm.Open
            stm.WriteText content
            stm.Position = 0
            stm.SaveToFile tmpPath, 2
            stm.Close
        End If
        Dim adoErr As Long: adoErr = Err.Number
        On Error GoTo 0

        If adoErr <> 0 Then
            Dim rawBytes() As Byte
            rawBytes = StrConv(content, vbFromUnicode)
            Dim ff As Integer: ff = FreeFile
            Open tmpPath For Binary Access Write As #ff
            Put #ff, , rawBytes
            Close #ff
        End If

        ' Schritt 2: Von %TEMP% ans Ziel kopieren
        On Error Resume Next
        Err.Clear
        Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        fso.CopyFile tmpPath, filePath, True
        Dim copyErr As Long: copyErr = Err.Number
        On Error GoTo 0

        If copyErr <> 0 Then
            ' v80: Bitdefender blockiert Kopie ins Ziel.
            ' Fallback: HTM bleibt in %TEMP%\SnipBookWork\ und wird dort geoeffnet.
            Dim fallbackPath As String
            fallbackPath = GetTempWorkFolder() & "\" & _
                           FileNameWithoutExt(mid$(filePath, InStrRev(filePath, "\") + 1)) & ".htm"
            On Error Resume Next
            fso.CopyFile tmpPath, fallbackPath, True
            On Error GoTo 0
            WriteAllTextUTF8 = fallbackPath   ' Rueckgabe des tatsaechlichen Pfads
            Err.Raise copyErr, "WriteAllTextUTF8:CopyFile", _
                "Bitdefender blockiert Schreibzugriff ins Zielverzeichnis (Err " & copyErr & ")." & vbCrLf & _
                "Datei wurde stattdessen gespeichert unter:" & vbCrLf & fallbackPath
        End If

        ' Aufraumen
        On Error Resume Next
        kill tmpPath
        On Error GoTo 0
    #End If
End Function

Private Sub WriteAllTextUTF8Direct(ByVal filePath As String, ByVal content As String)
    #If Mac Then
        WriteAllTextMac filePath, content
    #Else
        On Error GoTo FallbackDirect
        Dim stm As Object
        Set stm = CreateObject("ADODB.Stream")
        stm.Type = 2
        stm.Charset = "utf-8"
        stm.Open
        stm.WriteText content
        stm.SaveToFile filePath, 2
        stm.Close
        Exit Sub

FallbackDirect:
        On Error GoTo 0
        Dim rawBytes() As Byte
        Dim ff As Integer
        rawBytes = StrConv(content, vbFromUnicode)
        ff = FreeFile
        Open filePath For Binary Access Write As #ff
        Put #ff, , rawBytes
        Close #ff
    #End If
End Sub

' =============================================================================
' Diagnose: Schreibzugriff auf Output-Ordner testen (manuell aufrufbar)
' =============================================================================
Public Sub DiagnoseCharsetPreflight()
    On Error GoTo EH

    Dim doc As Document
    Set doc = ActiveDocument

    If IsHtmlDocument(doc) Then
        MsgBox "Bitte das Original-DOCX öffnen und nicht die HTML-Datei.", vbExclamation
        Exit Sub
    End If

    If Len(doc.path) = 0 Then
        MsgBox "Bitte das Dokument zuerst speichern (DOCX).", vbExclamation
        Exit Sub
    End If

    If DocumentHasLinkedGraphics(doc) Then
        MsgBox "Nur importierte Bilder ohne Verkn" & Chr$(252) & "pfung zurzeit erlaubt", vbExclamation, "SnipBook V74"
        Exit Sub
    End If

    Dim tmpHtmlPath As String
    tmpHtmlPath = ExportFilteredHtmlToTemp(doc)
    WaitForFileReady tmpHtmlPath, 80, 100

    Dim report As String
    report = BuildCharsetReport(tmpHtmlPath)

    Dim localDocFolder As String
    localDocFolder = GetLocalDocFolder(doc)

    Dim logPath As String
    If Len(localDocFolder) > 0 Then
        logPath = CombinePath(localDocFolder, FileNameWithoutExt(doc.Name) & "-SnipBook-Charsetprotokoll.txt")
    Else
        logPath = CombinePath(GetTemplateFolder(), FileNameWithoutExt(doc.Name) & "-SnipBook-Charsetprotokoll.txt")
    End If

    WriteAllTextUTF8Direct logPath, report

    MsgBox Left$(report, 1800) & vbCrLf & vbCrLf & "Vollständiges Protokoll:" & vbCrLf & logPath, vbInformation, "SnipBook Charset-Preflight"
    Exit Sub

EH:
    MsgBox "Charset-Preflight: Fehler " & Err.Number & " - " & Err.Description, vbCritical
End Sub

Public Sub DiagnoseTemplateUndPfade()
    Dim msg As String
    msg = BuildDiagnosticsBlock(ActiveDocument)
    MsgBox msg, vbInformation, "SnipBook Diagnose"
End Sub

Public Sub DiagnoseSchreiben()
    Dim doc As Document
    Set doc = ActiveDocument

    Dim outFolder As String
    outFolder = GetLocalDocFolder(doc)

    Dim msg As String
    msg = BuildDiagnosticsBlock(doc) & vbCrLf & String(38, "-") & vbCrLf
    msg = msg & "=== SCHREIBTEST ===" & vbCrLf
    msg = msg & "Ausgabeordner: " & outFolder & vbCrLf & vbCrLf

    If Len(outFolder) = 0 Then
        msg = msg & "Dokumentordner konnte nicht lokal aufgeloest werden."
        MsgBox msg, vbExclamation, "DiagnoseSchreiben"
        Exit Sub
    End If

    Dim testFile As String
    testFile = CombinePath(outFolder, "__snipbook_write_test.txt")

    Dim htmFile As String
    htmFile = CombinePath(outFolder, FileNameWithoutExt(doc.Name) & ".htm")
    If Dir$(htmFile, vbNormal) <> "" Then
        Dim attr As Integer
        On Error Resume Next
        attr = GetAttr(htmFile)
        msg = msg & "HTM-Datei existiert: JA" & vbCrLf
        msg = msg & "HTM Read-Only: " & ((attr And vbReadOnly) <> 0) & vbCrLf
        On Error GoTo 0
    Else
        msg = msg & "HTM-Datei existiert: NEIN" & vbCrLf
    End If

    On Error Resume Next
    Err.Clear
    Dim ff As Integer: ff = FreeFile
    Open testFile For Output As #ff
    Print #ff, "test"
    Close #ff
    msg = msg & vbCrLf & "Pure-VBA Write: Err=" & Err.Number & " " & Err.Description
    kill testFile
    Err.Clear
    On Error GoTo 0

    On Error Resume Next
    Err.Clear
    Dim stm As Object
    Set stm = CreateObject("ADODB.Stream")
    msg = msg & vbCrLf & "ADODB.Stream Create: Err=" & Err.Number & " " & Err.Description
    If Err.Number = 0 Then
        stm.Type = 2: stm.Charset = "utf-8": stm.Open
        stm.WriteText "test"
        stm.Position = 0
        stm.SaveToFile testFile, 2
        stm.Close
        msg = msg & vbCrLf & "ADODB Write: Err=" & Err.Number & " " & Err.Description
        kill testFile
    End If
    Err.Clear
    On Error GoTo 0

    MsgBox msg, vbInformation, "DiagnoseSchreiben"
End Sub

#If Mac Then
' Mac: schreibt UTF-8 via StrConv + Binary Output
Private Sub WriteAllTextMac(ByVal filePath As String, ByVal content As String)
    Dim rawBytes() As Byte
    rawBytes = StrConv(content, vbFromUnicode)
    Dim ff As Integer
    ff = FreeFile
    Open filePath For Binary Access Write As #ff
    Put #ff, , rawBytes
    Close #ff
End Sub
#End If

' =============================================================================
' Pfad-Hilfsfunktionen
' =============================================================================
Private Function CombinePath(ByVal a As String, ByVal b As String) As String
    Dim sep As String
    sep = PathSep()
    ' Trailing-Separator normalisieren: nur einen Separator zwischen a und b
    If Right$(a, 1) = "\" Or Right$(a, 1) = "/" Then
        CombinePath = a & b
    Else
        CombinePath = a & sep & b
    End If
End Function

Private Function FileNameWithoutExt(ByVal FileName As String) As String
    Dim p As Long
    p = InStrRev(FileName, ".")
    If p = 0 Then
        FileNameWithoutExt = FileName
    Else
        FileNameWithoutExt = Left$(FileName, p - 1)
    End If
End Function

' =============================================================================
' Lokalen Dokument-Ordner ermitteln (SharePoint URL ? lokaler Pfad)
' =============================================================================
Private Function GetLocalDocFolder(ByVal doc As Document) As String
    Dim p As String
    p = doc.path
    If Len(p) = 0 Then
        GetLocalDocFolder = ""
        Exit Function
    End If
    If LCase$(Left$(p, 4)) = "http" Then
        GetLocalDocFolder = MapUrlToLocalFolder(p)
    Else
        GetLocalDocFolder = p
    End If
End Function

' =============================================================================
' Template-Ordner ermitteln
' 1) bevorzugt: AttachedTemplate des aktiven Dokuments
' 2) Fallback: Makro-Container (ThisDocument)
' =============================================================================
Private Function GetTemplateFolder() As String
    On Error Resume Next

    Dim p As String

    p = ActiveDocument.AttachedTemplate.path
    If Len(p) > 0 Then
        If LCase$(Left$(p, 4)) = "http" Then
            GetTemplateFolder = MapUrlToLocalFolder(p)
        Else
            GetTemplateFolder = p
        End If
        Exit Function
    End If

    p = ThisDocument.path
    If Len(p) > 0 Then
        If LCase$(Left$(p, 4)) = "http" Then
            GetTemplateFolder = MapUrlToLocalFolder(p)
        Else
            GetTemplateFolder = p
        End If
        Exit Function
    End If

    GetTemplateFolder = ""
    On Error GoTo 0
End Function

' =============================================================================
' URL -> lokaler OneDrive-Pfad
' Unterstützt:
' - persönliches OneDrive (d.docs.live.net)
' - OneDrive for Business / SharePoint
' =============================================================================
Private Function MapUrlToLocalFolder(ByVal urlPath As String) As String
    #If Mac Then
        MapUrlToLocalFolder = MapUrlToLocalFolderMac(urlPath)
    #Else
        MapUrlToLocalFolder = MapUrlToLocalFolderWindows(urlPath)
    #End If
End Function

#If Mac Then
Private Function MapUrlToLocalFolderMac(ByVal urlPath As String) As String
    Dim homeDir As String
    Dim cloudBase As String
    Dim odFolder As String
    Dim oneDriveRoot As String
    Dim kp As Long
    Dim rel As String

    homeDir = Environ$("HOME")
    cloudBase = CombinePath(homeDir, "Library/CloudStorage")

    If Dir$(cloudBase, vbDirectory) <> "" Then
        odFolder = Dir$(CombinePath(cloudBase, "OneDrive*"), vbDirectory)
        If Len(odFolder) > 0 Then oneDriveRoot = CombinePath(cloudBase, odFolder)
    End If

    If Len(oneDriveRoot) = 0 Then
        odFolder = Dir$(CombinePath(homeDir, "OneDrive*"), vbDirectory)
        If Len(odFolder) > 0 Then oneDriveRoot = CombinePath(homeDir, odFolder)
    End If

    If Len(oneDriveRoot) = 0 Then
        MapUrlToLocalFolderMac = ""
        Exit Function
    End If

    kp = InStr(1, urlPath, "/Documents/", vbTextCompare)
    If kp = 0 Then kp = InStr(1, urlPath, "/Dokumente/", vbTextCompare)
    If kp > 0 Then
        rel = mid$(urlPath, kp + 11)
        rel = Replace$(rel, "%20", " ")
        rel = Replace$(rel, "/", PathSep())
        MapUrlToLocalFolderMac = CombinePath(oneDriveRoot, rel)
    Else
        MapUrlToLocalFolderMac = ""
    End If
End Function
#Else
Private Function MapUrlToLocalFolderWindows(ByVal urlPath As String) As String
    Dim roots(0 To 2) As String
    Dim lastIndex As Long
    Dim personalRoot As String
    Dim candidate As String
    Dim rel As String
    Dim i As Long

    lastIndex = -1
    urlPath = Trim$(Replace$(urlPath, "%20", " "))

    personalRoot = Environ$("UserProfile") & "\OneDrive"

    If Len(Environ$("OneDriveCommercial")) > 0 Then
        lastIndex = lastIndex + 1
        roots(lastIndex) = Environ$("OneDriveCommercial")
    End If

    If Len(Environ$("OneDrive")) > 0 Then
        If Not IsAlreadyInArray(roots, lastIndex, Environ$("OneDrive")) Then
            lastIndex = lastIndex + 1
            roots(lastIndex) = Environ$("OneDrive")
        End If
    End If

    If FolderExists(personalRoot) Then
        If Not IsAlreadyInArray(roots, lastIndex, personalRoot) Then
            lastIndex = lastIndex + 1
            roots(lastIndex) = personalRoot
        End If
    End If

    If InStr(1, urlPath, "d.docs.live.net", vbTextCompare) > 0 Then
        If EndsWithCI(urlPath, "/Dokumente") Then
            candidate = personalRoot & "\Dokumente"
            If FolderExists(candidate) Then
                MapUrlToLocalFolderWindows = candidate
                Exit Function
            End If
            candidate = personalRoot & "\Documents"
            If FolderExists(candidate) Then
                MapUrlToLocalFolderWindows = candidate
                Exit Function
            End If
        End If

        If EndsWithCI(urlPath, "/Documents") Then
            candidate = personalRoot & "\Documents"
            If FolderExists(candidate) Then
                MapUrlToLocalFolderWindows = candidate
                Exit Function
            End If
            candidate = personalRoot & "\Dokumente"
            If FolderExists(candidate) Then
                MapUrlToLocalFolderWindows = candidate
                Exit Function
            End If
        End If

        rel = ExtractRelativePart(urlPath, "/Dokumente/")
        If Len(rel) > 0 Then
            rel = Replace$(rel, "/", "\")
            candidate = personalRoot & "\Dokumente\" & rel
            If FolderExists(candidate) Then
                MapUrlToLocalFolderWindows = candidate
                Exit Function
            End If
            candidate = personalRoot & "\Documents\" & rel
            If FolderExists(candidate) Then
                MapUrlToLocalFolderWindows = candidate
                Exit Function
            End If
        End If

        rel = ExtractRelativePart(urlPath, "/Documents/")
        If Len(rel) > 0 Then
            rel = Replace$(rel, "/", "\")
            candidate = personalRoot & "\Documents\" & rel
            If FolderExists(candidate) Then
                MapUrlToLocalFolderWindows = candidate
                Exit Function
            End If
            candidate = personalRoot & "\Dokumente\" & rel
            If FolderExists(candidate) Then
                MapUrlToLocalFolderWindows = candidate
                Exit Function
            End If
        End If
    End If

    For i = 0 To lastIndex
        If Len(roots(i)) > 0 Then
            If EndsWithCI(urlPath, "/Dokumente") Then
                candidate = roots(i) & "\Dokumente"
                If FolderExists(candidate) Then
                    MapUrlToLocalFolderWindows = candidate
                    Exit Function
                End If
                candidate = roots(i) & "\Documents"
                If FolderExists(candidate) Then
                    MapUrlToLocalFolderWindows = candidate
                    Exit Function
                End If
            End If

            If EndsWithCI(urlPath, "/Documents") Then
                candidate = roots(i) & "\Documents"
                If FolderExists(candidate) Then
                    MapUrlToLocalFolderWindows = candidate
                    Exit Function
                End If
                candidate = roots(i) & "\Dokumente"
                If FolderExists(candidate) Then
                    MapUrlToLocalFolderWindows = candidate
                    Exit Function
                End If
            End If

            rel = ExtractRelativePart(urlPath, "/Dokumente/")
            If Len(rel) > 0 Then
                rel = Replace$(rel, "/", "\")
                candidate = roots(i) & "\Dokumente\" & rel
                If FolderExists(candidate) Then
                    MapUrlToLocalFolderWindows = candidate
                    Exit Function
                End If
                candidate = roots(i) & "\" & rel
                If FolderExists(candidate) Then
                    MapUrlToLocalFolderWindows = candidate
                    Exit Function
                End If
            End If

            rel = ExtractRelativePart(urlPath, "/Documents/")
            If Len(rel) > 0 Then
                rel = Replace$(rel, "/", "\")
                candidate = roots(i) & "\Documents\" & rel
                If FolderExists(candidate) Then
                    MapUrlToLocalFolderWindows = candidate
                    Exit Function
                End If
                candidate = roots(i) & "\" & rel
                If FolderExists(candidate) Then
                    MapUrlToLocalFolderWindows = candidate
                    Exit Function
                End If
            End If
        End If
    Next i

    MapUrlToLocalFolderWindows = ""
End Function
#End If

Private Function EndsWithCI(ByVal txt As String, ByVal suffix As String) As Boolean
    If Len(txt) < Len(suffix) Then
        EndsWithCI = False
    Else
        EndsWithCI = (LCase$(Right$(txt, Len(suffix))) = LCase$(suffix))
    End If
End Function

Private Function ExtractRelativePart(ByVal fullText As String, ByVal marker As String) As String
    Dim p As Long

    p = InStr(1, fullText, marker, vbTextCompare)
    If p > 0 Then
        ExtractRelativePart = mid$(fullText, p + Len(marker))
    Else
        ExtractRelativePart = ""
    End If
End Function

Private Function FolderExists(ByVal folderPath As String) As Boolean
    On Error Resume Next
    FolderExists = (Len(Dir$(folderPath, vbDirectory)) > 0)
    On Error GoTo 0
End Function

Private Function IsAlreadyInArray(ByRef arr() As String, ByVal lastIndex As Long, ByVal value As String) As Boolean
    Dim i As Long

    If lastIndex < 0 Then Exit Function

    For i = 0 To lastIndex
        If LCase$(Trim$(arr(i))) = LCase$(Trim$(value)) Then
            IsAlreadyInArray = True
            Exit Function
        End If
    Next i
End Function


Private Function DocumentHasLinkedGraphics(ByVal doc As Document) As Boolean
    On Error GoTo SafeExit

    Dim i As Long

    For i = 1 To doc.Fields.count
        Select Case doc.Fields(i).Type
            Case wdFieldIncludePicture, wdFieldLink
                DocumentHasLinkedGraphics = True
                Exit Function
        End Select
    Next i

    For i = 1 To doc.InlineShapes.count
        On Error Resume Next
        If Not doc.InlineShapes(i).LinkFormat Is Nothing Then
            If Len(Trim$(doc.InlineShapes(i).LinkFormat.SourceFullName)) > 0 Then
                DocumentHasLinkedGraphics = True
                Exit Function
            End If
        End If
        On Error GoTo SafeExit
    Next i

    For i = 1 To doc.Shapes.count
        On Error Resume Next
        If Not doc.Shapes(i).LinkFormat Is Nothing Then
            If Len(Trim$(doc.Shapes(i).LinkFormat.SourceFullName)) > 0 Then
                DocumentHasLinkedGraphics = True
                Exit Function
            End If
        End If
        On Error GoTo SafeExit
    Next i

SafeExit:
End Function

Private Function BuildCharsetReport(ByVal filePath As String) As String
    Dim enc As String
    Dim metaCharset As String
    Dim txt As String
    Dim hasUtf8Decl As String

    enc = DetectFileEncoding(filePath)
    txt = ReadAllTextUTF8(filePath)
    metaCharset = ExtractHtmlCharsetFromText(Left$(txt, 4000))

    If InStr(1, LCase$(txt), "charset=utf-8", vbTextCompare) > 0 Then
        hasUtf8Decl = "Ja"
    Else
        hasUtf8Decl = "Nein"
    End If

    BuildCharsetReport = "=== SnipBook Charset-Preflight ===" & vbCrLf & vbCrLf & _
                         "Datei: " & filePath & vbCrLf & _
                         "Erkanntes Quell-Encoding: " & enc & vbCrLf & _
                         "HTML-Meta-Charset: " & metaCharset & vbCrLf & _
                         "Finales Ziel-Encoding: utf-8" & vbCrLf & _
                         "UTF-8-Deklaration im gelesenen Text vorhanden: " & hasUtf8Decl & vbCrLf & vbCrLf & _
                         "Testzeichen im gelesenen Text gefunden:" & vbCrLf & _
                         "- äöüÄÖÜß: " & IIf(InStr(txt, "ä") > 0 And InStr(txt, "ß") > 0, "Ja", "Nein") & vbCrLf & _
                         "- typografische Anführungen: " & IIf(InStr(txt, "„") > 0 Or InStr(txt, "“") > 0, "Ja", "Nein") & vbCrLf & _
                         "- Gedankenstrich: " & IIf(InStr(txt, "–") > 0, "Ja", "Nein") & vbCrLf & _
                         "- Eurozeichen: " & IIf(InStr(txt, "€") > 0, "Ja", "Nein") & vbCrLf
End Function

Private Function DetectFileEncoding(ByVal filePath As String) As String
    Dim ff As Integer
    Dim fileSz As Long
    Dim rawBytes() As Byte
    Dim sampleText As String
    Dim metaCharset As String

    On Error GoTo Fallback

    fileSz = fileLen(filePath)
    If fileSz = 0 Then
        DetectFileEncoding = "utf-8"
        Exit Function
    End If

    ff = FreeFile
    ReDim rawBytes(fileSz - 1)
    Open filePath For Binary Access Read As #ff
    Get #ff, , rawBytes
    Close #ff

    If fileSz >= 3 Then
        If rawBytes(0) = &HEF And rawBytes(1) = &HBB And rawBytes(2) = &HBF Then
            DetectFileEncoding = "utf-8"
            Exit Function
        End If
    End If

    If fileSz >= 2 Then
        If rawBytes(0) = &HFF And rawBytes(1) = &HFE Then
            DetectFileEncoding = "utf-16le"
            Exit Function
        End If
        If rawBytes(0) = &HFE And rawBytes(1) = &HFF Then
            DetectFileEncoding = "utf-16be"
            Exit Function
        End If
    End If

    sampleText = GetAsciiSampleFromBytes(rawBytes, 4096)
    metaCharset = LCase$(ExtractHtmlCharsetFromText(sampleText))

    If Len(metaCharset) > 0 Then
        Select Case metaCharset
            Case "utf-8", "utf8"
                DetectFileEncoding = "utf-8"
                Exit Function
            Case "utf-16", "utf-16le", "unicode"
                DetectFileEncoding = "utf-16le"
                Exit Function
            Case "windows-1252", "cp1252", "ansi_x3.4-1968", "iso-8859-1", "latin1"
                DetectFileEncoding = "windows-1252"
                Exit Function
        End Select
    End If

    If LooksLikeUtf8Bytes(rawBytes) Then
        DetectFileEncoding = "utf-8"
    Else
        DetectFileEncoding = "windows-1252"
    End If
    Exit Function

Fallback:
    On Error Resume Next
    If ff <> 0 Then Close #ff
    DetectFileEncoding = "utf-8"
End Function

Private Function GetAsciiSampleFromBytes(ByRef rawBytes() As Byte, ByVal maxLen As Long) As String
    Dim i As Long, n As Long, b As Integer, s As String
    n = UBound(rawBytes) + 1
    If n > maxLen Then n = maxLen

    For i = 0 To n - 1
        b = rawBytes(i)
        If b >= 32 And b <= 126 Then
            s = s & Chr$(b)
        ElseIf b = 9 Or b = 10 Or b = 13 Then
            s = s & Chr$(b)
        Else
            s = s & " "
        End If
    Next i
    GetAsciiSampleFromBytes = s
End Function

Private Function LooksLikeUtf8Bytes(ByRef rawBytes() As Byte) As Boolean
    Dim i As Long, b As Long, needCont As Long, n As Long
    n = UBound(rawBytes)

    i = 0
    Do While i <= n
        b = rawBytes(i)

        If b <= &H7F Then
            i = i + 1
        ElseIf b >= &HC2 And b <= &HDF Then
            needCont = 1
            If Not CheckUtf8Continuation(rawBytes, i, needCont) Then Exit Function
            i = i + needCont + 1
        ElseIf b >= &HE0 And b <= &HEF Then
            needCont = 2
            If Not CheckUtf8Continuation(rawBytes, i, needCont) Then Exit Function
            i = i + needCont + 1
        ElseIf b >= &HF0 And b <= &HF4 Then
            needCont = 3
            If Not CheckUtf8Continuation(rawBytes, i, needCont) Then Exit Function
            i = i + needCont + 1
        Else
            LooksLikeUtf8Bytes = False
            Exit Function
        End If
    Loop

    LooksLikeUtf8Bytes = True
End Function

Private Function CheckUtf8Continuation(ByRef rawBytes() As Byte, ByVal startIdx As Long, ByVal needCont As Long) As Boolean
    Dim j As Long, idx As Long, b As Long
    For j = 1 To needCont
        idx = startIdx + j
        If idx > UBound(rawBytes) Then Exit Function
        b = rawBytes(idx)
        If b < &H80 Or b > &HBF Then Exit Function
    Next j
    CheckUtf8Continuation = True
End Function

Private Function MapEncodingToAdoCharset(ByVal enc As String) As String
    Select Case LCase$(Trim$(enc))
        Case "utf-8", "utf8"
            MapEncodingToAdoCharset = "utf-8"
        Case "utf-16", "utf-16le", "unicode"
            MapEncodingToAdoCharset = "unicode"
        Case "utf-16be"
            MapEncodingToAdoCharset = "unicode"
        Case Else
            MapEncodingToAdoCharset = "windows-1252"
    End Select
End Function

Private Function ExtractHtmlCharsetFromText(ByVal txt As String) As String
    Dim p As Long, s As String, i As Long, ch As String
    p = InStr(1, txt, "charset=", vbTextCompare)
    If p = 0 Then Exit Function

    s = mid$(txt, p + 8)
    s = Replace$(s, Chr$(34), "")
    s = Replace$(s, Chr$(39), "")

    For i = 1 To Len(s)
        ch = mid$(s, i, 1)
        If ch Like "[A-Za-z0-9_-]" Then
            ExtractHtmlCharsetFromText = ExtractHtmlCharsetFromText & ch
        Else
            Exit For
        End If
    Next i
End Function

Private Function EnsureUtf8HtmlMeta(ByVal html As String) As String
    html = Replace$(html, "charset=windows-1252", "charset=utf-8", 1, -1, vbTextCompare)
    html = Replace$(html, "charset=iso-8859-1", "charset=utf-8", 1, -1, vbTextCompare)
    html = Replace$(html, "charset=UTF-8", "charset=utf-8", 1, -1, vbTextCompare)
    html = Replace$(html, "charset=utf8", "charset=utf-8", 1, -1, vbTextCompare)

    If InStr(1, html, "charset=", vbTextCompare) = 0 Then
        If InStr(1, html, "<head>", vbTextCompare) > 0 Then
            html = Replace$(html, "<head>", "<head>" & vbCrLf & "<meta charset=""utf-8"">", 1, 1, vbTextCompare)
        End If
    End If

    EnsureUtf8HtmlMeta = html
End Function

Private Function BuildDiagnosticsBlock(ByVal doc As Document) As String
    Dim adName As String, adPath As String, adFull As String
    Dim tdName As String, tdPath As String, tdFull As String
    Dim atName As String, atPath As String, atFull As String
    Dim localDocFolder As String, templateFolder As String, viewerPath As String
    Dim msg As String

    On Error Resume Next
    adName = doc.Name
    adPath = doc.path
    adFull = doc.fullName

    tdName = ThisDocument.Name
    tdPath = ThisDocument.path
    tdFull = ThisDocument.fullName

    atName = doc.AttachedTemplate.Name
    atPath = doc.AttachedTemplate.path
    atFull = doc.AttachedTemplate.fullName

    localDocFolder = GetLocalDocFolder(doc)
    templateFolder = GetTemplateFolder()
    If Len(templateFolder) > 0 Then viewerPath = FindViewerFile(templateFolder)
    On Error GoTo 0

    msg = ""
    msg = msg & "=== AKTIVES DOKUMENT ===" & vbCrLf
    msg = msg & "Name: " & adName & vbCrLf
    msg = msg & "Path: " & adPath & vbCrLf
    msg = msg & "FullName: " & adFull & vbCrLf & vbCrLf

    msg = msg & "=== MAKRO-CONTAINER (ThisDocument) ===" & vbCrLf
    msg = msg & "Name: " & tdName & vbCrLf
    msg = msg & "Path: " & tdPath & vbCrLf
    msg = msg & "FullName: " & tdFull & vbCrLf & vbCrLf

    msg = msg & "=== ANGEHÄNGTES TEMPLATE ===" & vbCrLf
    msg = msg & "Name: " & atName & vbCrLf
    msg = msg & "Path: " & atPath & vbCrLf
    msg = msg & "FullName: " & atFull & vbCrLf & vbCrLf

    msg = msg & "=== ERMITTLUNGEN ===" & vbCrLf
    msg = msg & "Lokaler Dokumentordner: " & localDocFolder & vbCrLf
    msg = msg & "Template-Ordner: " & templateFolder & vbCrLf
    msg = msg & "Viewer-Datei: " & viewerPath & vbCrLf
    msg = msg & "Verknüpfte Grafiken vorhanden: " & IIf(DocumentHasLinkedGraphics(doc), "Ja", "Nein") & vbCrLf & vbCrLf

    msg = msg & "=== UMGEBUNG ===" & vbCrLf
    msg = msg & "OneDriveCommercial: " & Environ$("OneDriveCommercial") & vbCrLf
    msg = msg & "OneDrive: " & Environ$("OneDrive") & vbCrLf
    msg = msg & "UserProfile: " & Environ$("UserProfile")

    BuildDiagnosticsBlock = msg
End Function

Private Function BuildErrorMessage(ByVal doc As Document, ByVal stageName As String, ByVal errNum As Long, ByVal errDesc As String, ByVal platformName As String, ByVal localDocFolder As String, ByVal templateFolder As String, ByVal viewerPath As String, ByVal stageExtra As String) As String
    Dim msg As String

    msg = ""
    msg = msg & "=== SnipBook-Fehler ===" & vbCrLf & vbCrLf
    msg = msg & "M" & Chr$(246) & "gliche Ursachen:" & vbCrLf
    msg = msg & "a) Dokument oder Pfad konnte nicht lokal aufgel" & Chr$(246) & "st werden" & vbCrLf
    msg = msg & "b) Viewer-Datei fehlt im Template-Ordner" & vbCrLf
    msg = msg & "c) Dateiprozesse blockieren Export, Lesen oder Schreiben" & vbCrLf

    If Len(stageExtra) > 0 Then
        msg = msg & vbCrLf & vbCrLf & stageExtra
    End If

    msg = msg & vbCrLf & vbCrLf & String(38, "-") & vbCrLf
    msg = msg & "=== TECHNISCHE DETAILS ===" & vbCrLf
    msg = msg & "Stage: " & stageName & vbCrLf
    msg = msg & "Fehler: " & errNum & " - " & errDesc & vbCrLf
    msg = msg & "Plattform: " & platformName & vbCrLf
    msg = msg & "Temp: " & GetTempWorkFolder() & vbCrLf
    msg = msg & "Lokaler Dokumentordner: " & localDocFolder & vbCrLf
    msg = msg & "Template-Ordner: " & templateFolder & vbCrLf
    msg = msg & "Viewer-Datei: " & viewerPath & vbCrLf & vbCrLf

    msg = msg & BuildDiagnosticsBlock(doc)

    BuildErrorMessage = msg
End Function

Private Function GetPreferredLogFolder(ByVal doc As Document, ByVal localDocFolder As String, ByVal templateFolder As String) As String
    If Len(localDocFolder) > 0 And FolderExists(localDocFolder) Then
        GetPreferredLogFolder = localDocFolder
        Exit Function
    End If

    If Len(templateFolder) > 0 And FolderExists(templateFolder) Then
        GetPreferredLogFolder = templateFolder
        Exit Function
    End If

    On Error Resume Next
    If Not doc Is Nothing Then
        If Len(doc.path) > 0 And LCase$(Left$(doc.path, 4)) <> "http" And FolderExists(doc.path) Then
            GetPreferredLogFolder = doc.path
            Exit Function
        End If
    End If
    On Error GoTo 0

    GetPreferredLogFolder = ""
End Function

Private Function WriteSnipBookLogBesideDocumentOrTemplate(ByVal doc As Document, ByVal localDocFolder As String, ByVal templateFolder As String, ByVal logText As String) As String
    Dim logFolder As String
    Dim logPath As String
    Dim baseName As String

    logFolder = GetPreferredLogFolder(doc, localDocFolder, templateFolder)
    If Len(logFolder) = 0 Then Exit Function

    On Error Resume Next
    baseName = FileNameWithoutExt(doc.Name)
    If Len(baseName) = 0 Then baseName = "SnipBook"
    On Error GoTo 0

    logPath = CombinePath(logFolder, baseName & "-" & ERROR_LOG_FILE)

    On Error Resume Next
    WriteAllTextUTF8Direct logPath, logText
    If Err.Number <> 0 Then
        Err.Clear
        Exit Function
    End If
    On Error GoTo 0

    WriteSnipBookLogBesideDocumentOrTemplate = logPath
End Function

' =============================================================================
' Pfade in extrahierten Viewer-Bl?cken anpassen
' =============================================================================
Private Function PrefixToolPaths(ByVal s As String) As String
    s = Replace(s, "href=""slick.css""", "href=""" & VIEWER_FOLDER & "/slick.css""")
    s = Replace(s, "href=""slick-theme.css""", "href=""" & VIEWER_FOLDER & "/slick-theme.css""")
    s = Replace(s, "src=""jquery-3.7.1.min.js""", "src=""" & VIEWER_FOLDER & "/jquery-3.7.1.min.js""")
    s = Replace(s, "src=""slick.min.js""", "src=""" & VIEWER_FOLDER & "/slick.min.js""")
    PrefixToolPaths = s
End Function

' =============================================================================
' Script Bundle extrahieren
' =============================================================================
Private Function ExtractSnipBookScriptBundle(ByVal viewerHtml As String) As String
    Dim out As String
    out = ""
    out = out & ExtractScriptTagBySrc(viewerHtml, "jquery-3.7.1.min.js")
    out = out & ExtractScriptTagBySrc(viewerHtml, "slick.min.js")

    Dim inline As String
    inline = ExtractTagBlockById(viewerHtml, "script", "snipbook-viewer-js")
    If Len(Trim$(inline)) = 0 Then
        inline = ExtractFirstScriptContaining(viewerHtml, "SNIPBOOK:")
    End If
    out = out & inline
    ExtractSnipBookScriptBundle = out
End Function

Private Function ExtractScriptTagBySrc(ByVal html As String, ByVal filePart As String) As String
    Dim p As Long, pStart As Long, pEnd As Long
    p = InStr(1, html, filePart, vbTextCompare)
    If p = 0 Then Exit Function
    pStart = InStrRev(html, "<script", p, vbTextCompare)
    If pStart = 0 Then Exit Function
    pEnd = InStr(p, html, "</script>", vbTextCompare)
    If pEnd = 0 Then Exit Function
    ExtractScriptTagBySrc = vbCrLf & mid$(html, pStart, (pEnd - pStart) + Len("</script>")) & vbCrLf
End Function

Private Function ExtractFirstScriptContaining(ByVal html As String, ByVal needle As String) As String
    Dim pNeedle As Long, pStart As Long, pEnd As Long
    pNeedle = InStr(1, html, needle, vbTextCompare)
    If pNeedle = 0 Then Exit Function
    pStart = InStrRev(html, "<script", pNeedle, vbTextCompare)
    If pStart = 0 Then Exit Function
    pEnd = InStr(pNeedle, html, "</script>", vbTextCompare)
    If pEnd = 0 Then Exit Function
    ExtractFirstScriptContaining = vbCrLf & mid$(html, pStart, (pEnd - pStart) + Len("</script>")) & vbCrLf
End Function

' =============================================================================
' Formatvorlagen kopieren
' =============================================================================
Private Sub CopyCustomStyles(sourceDoc As Document, targetDoc As Document)
    On Error Resume Next
    CopySingleStyle sourceDoc, targetDoc, Chr(220) & "berschrift 1"
    CopySingleStyle sourceDoc, targetDoc, Chr(220) & "berschrift 2"
    CopySingleStyle sourceDoc, targetDoc, Chr(220) & "berschrift 3"
    CopySingleStyle sourceDoc, targetDoc, Chr(220) & "berschrift 4"
    CopySingleStyle sourceDoc, targetDoc, "Normal"
    CopySingleStyle sourceDoc, targetDoc, "Standard"
    CopySingleStyle sourceDoc, targetDoc, "Listenabsatz"
    CopySingleStyle sourceDoc, targetDoc, "List Paragraph"
    CopySingleStyle sourceDoc, targetDoc, Chr(220) & "berschrift 2 expanded"
    CopySingleStyle sourceDoc, targetDoc, "berschrift2expanded"
    CopySingleStyle sourceDoc, targetDoc, "Body"
    CopySingleStyle sourceDoc, targetDoc, "UL1"
    CopySingleStyle sourceDoc, targetDoc, "UL2"
    CopySingleStyle sourceDoc, targetDoc, "Graphic_Anchor"
    CopySingleStyle sourceDoc, targetDoc, "GraphicAnchor"
    CopySingleStyle sourceDoc, targetDoc, "Table_Graphic_Anchor"
    CopySingleStyle sourceDoc, targetDoc, "TableGraphicAnchor"
    CopySingleStyle sourceDoc, targetDoc, "Title 1"
    On Error GoTo 0
End Sub

Private Sub CopySingleStyle(sourceDoc As Document, targetDoc As Document, styleName As String)
    On Error Resume Next
    Dim srcStyle As style
    Set srcStyle = Nothing
    Set srcStyle = sourceDoc.styles(styleName)
    If srcStyle Is Nothing Then Exit Sub
    If Err.Number <> 0 Then Err.Clear: Exit Sub

    Dim tgtStyle As style
    Set tgtStyle = Nothing
    Set tgtStyle = targetDoc.styles(styleName)
    If tgtStyle Is Nothing Or Err.Number <> 0 Then
        Err.Clear
        If Not IsBuiltInHeadingStyle(styleName) Then
            On Error Resume Next
            Set tgtStyle = targetDoc.styles.Add(Name:=styleName, Type:=wdStyleTypeParagraph)
            If Err.Number <> 0 Then Err.Clear: Exit Sub
        Else
            Exit Sub
        End If
    End If

    If Not tgtStyle Is Nothing Then
        On Error Resume Next
        tgtStyle.Font.Name = srcStyle.Font.Name
        tgtStyle.Font.Size = srcStyle.Font.Size
        tgtStyle.Font.Bold = srcStyle.Font.Bold
        tgtStyle.Font.Italic = srcStyle.Font.Italic
        tgtStyle.Font.Color = srcStyle.Font.Color
        tgtStyle.ParagraphFormat.Alignment = srcStyle.ParagraphFormat.Alignment
        tgtStyle.ParagraphFormat.LeftIndent = srcStyle.ParagraphFormat.LeftIndent
        tgtStyle.ParagraphFormat.FirstLineIndent = srcStyle.ParagraphFormat.FirstLineIndent
        tgtStyle.ParagraphFormat.SpaceBefore = srcStyle.ParagraphFormat.SpaceBefore
        tgtStyle.ParagraphFormat.SpaceAfter = srcStyle.ParagraphFormat.SpaceAfter
        tgtStyle.ParagraphFormat.LineSpacing = srcStyle.ParagraphFormat.LineSpacing
        tgtStyle.ParagraphFormat.LineSpacingRule = srcStyle.ParagraphFormat.LineSpacingRule
        Err.Clear
    End If
    On Error GoTo 0
End Sub

Private Function IsBuiltInHeadingStyle(styleName As String) As Boolean
    Select Case LCase(styleName)
        Case Chr(252) & "berschrift 1", Chr(252) & "berschrift 2", Chr(252) & "berschrift 3", _
             Chr(252) & "berschrift 4", Chr(252) & "berschrift 5", Chr(252) & "berschrift 6", _
             "normal", "standard", "listenabsatz", "list paragraph"
            IsBuiltInHeadingStyle = True
        Case Else
            IsBuiltInHeadingStyle = False
    End Select
End Function

' =============================================================================
' h2.expanded Farbe aus Word-Style patchen
' =============================================================================
Private Function PatchExpandedColor(html As String, doc As Document) As String
    On Error Resume Next

    Dim expandedStyle As style
    Set expandedStyle = Nothing
    Set expandedStyle = doc.styles(Chr(220) & "berschrift 2 expanded")

    If expandedStyle Is Nothing Then
        PatchExpandedColor = html
        Exit Function
    End If
    If Err.Number <> 0 Then
        Err.Clear
        PatchExpandedColor = html
        Exit Function
    End If

    Dim colorValue As Long
    colorValue = expandedStyle.Font.Color
    If colorValue < 0 Then
        PatchExpandedColor = html
        Exit Function
    End If

    Dim r As Long, g As Long, b As Long
    r = colorValue Mod 256
    g = (colorValue \ 256) Mod 256
    b = colorValue \ 65536

    Dim hexColor As String
    hexColor = "#" & Right("0" & Hex(r), 2) & Right("0" & Hex(g), 2) & Right("0" & Hex(b), 2)

    Dim patch As String
    patch = vbCrLf & "/* FIX V26-01-08g: h2.expanded aus Word-Style (" & hexColor & ") */" & vbCrLf & _
            ".snip-page-inner h2.expanded," & vbCrLf & _
            ".snip-page-inner .section-header h2.expanded {" & vbCrLf & _
            "    color: " & hexColor & " !important;" & vbCrLf & _
            "}" & vbCrLf & _
            "</style>"

    Dim lastStylePos As Long
    lastStylePos = InStrRev(html, "</style>", -1, vbTextCompare)
    If lastStylePos > 0 Then
        html = Left$(html, lastStylePos - 1) & patch & mid$(html, lastStylePos + Len("</style>"))
    End If

    PatchExpandedColor = html
    On Error GoTo 0
End Function

' =============================================================================
' VIDEO-PLAYER: Hauptfunktion (v54)
' Sucht alle <img alt="[[VIDEO:datei.mp4|MM:SS=Label|...]]"> im HTML
' und ersetzt sie durch einen data-Attribut-Platzhalter:
'   <div class="sbv-wrap" data-video="..." data-poster="..." data-w="..." data-h="..." data-chapters='...'></div>
' CSS + JS fuer den Player sind im SnipBook-Viewer enthalten (initVideoPlayers).
' Eingabeformat Alt-Text: [[VIDEO:datei.mp4|00:00=Intro|01:30=Kapitel 1]]
' =============================================================================
Private Function PatchVideoPlaceholders(ByVal html As String) As String
    If InStr(1, html, "[[VIDEO:", vbTextCompare) = 0 Then
        PatchVideoPlaceholders = html
        Exit Function
    End If

    Dim q As String: q = Chr(34)

    Dim searchFrom As Long
    searchFrom = 1
    Do
        Dim pMark As Long
        pMark = InStr(searchFrom, html, "[[VIDEO:", vbTextCompare)
        If pMark = 0 Then Exit Do

        Dim pImg As Long
        pImg = InStrRev(html, "<img", pMark, vbTextCompare)
        If pImg = 0 Then searchFrom = pMark + 1: GoTo NextVid

        ' v54b: Sicherheitspr?fung - [[VIDEO:]] muss im alt="..." Attribut des gefundenen <img> stehen.
        ' Ohne diese Pr?fung w?rde [[VIDEO:]] in normalem Flie?text (z.B. Dokumentation der Syntax)
        ' f?lschlicherweise verarbeitet und dabei gro?en HTML-Bereich inkl. Topic-Strukturen zerst?ren.
        Dim imgSection As String
        imgSection = mid$(html, pImg, pMark - pImg)
        ' imgSection enth?lt den Teil vom <img-Start bis zur [[VIDEO:-Position.
        ' Pr?fe: enth?lt er alt= (dann sind wir im alt-Attribut)?
        If InStr(1, imgSection, "alt=", vbTextCompare) = 0 Then
            ' [[VIDEO: ist NICHT im alt-Attribut dieses <img> ? Flie?text, ?berspringen
            searchFrom = pMark + Len("[[VIDEO:")
            GoTo NextVid
        End If
        ' Pr?fe auch: Kein schlie?endes > zwischen pImg und pMark (w?re ein anderes Tag)
        If InStr(1, imgSection, ">") > 0 Then
            ' Es gibt ein > zwischen <img und [[VIDEO: ? das <img> wurde vor [[VIDEO: geschlossen,
            ' d.h. [[VIDEO: geh?rt nicht zu diesem img-Tag
            searchFrom = pMark + Len("[[VIDEO:")
            GoTo NextVid
        End If

        Dim pImgEnd As Long
        pImgEnd = InStr(pMark, html, ">", vbTextCompare)
        If pImgEnd = 0 Then searchFrom = pMark + 1: GoTo NextVid

        Dim imgTag As String
        imgTag = mid$(html, pImg, pImgEnd - pImg + 1)

        Dim altText   As String: altText = ExtractHtmlAttr(imgTag, "alt")
        Dim posterSrc As String: posterSrc = ExtractHtmlAttr(imgTag, "src")
        Dim wPx       As String: wPx = ExtractImgWidth(imgTag)
        Dim hPx       As String: hPx = ExtractImgHeight(imgTag)
        If Len(wPx) = 0 Then wPx = "640"
        If Len(hPx) = 0 Then hPx = "360"

        Dim videoFile    As String
        Dim chaptersJson As String
        ParseVideoAltText altText, videoFile, chaptersJson

        Dim videoSrc As String
        videoSrc = ReplaceFilenameInPath(posterSrc, videoFile)

        ' v54: Nur data-Attribut-Platzhalter erzeugen.
        ' CSS + JS fuer Video-Player sind im SnipBook-Viewer (initVideoPlayers).
        ' Single quotes fuer data-chapters, um Konflikte mit JSON-Doublequotes zu vermeiden.
        Dim placeholder As String
        placeholder = "<div class=" & q & "sbv-wrap" & q & _
                      " data-video=" & q & videoSrc & q & _
                      " data-poster=" & q & posterSrc & q & _
                      " data-w=" & q & wPx & q & _
                      " data-h=" & q & hPx & q & _
                      " data-chapters='" & chaptersJson & "'></div>"

        html = Left$(html, pImg - 1) & placeholder & mid$(html, pImgEnd + 1)
        searchFrom = pImg + Len(placeholder)
NextVid:
    Loop

    PatchVideoPlaceholders = html
End Function

' Alt-Text parsen: "[[VIDEO:video.mp4|00:00=Intro|01:30=Kapitel 1]]"
Private Sub ParseVideoAltText(ByVal altText As String, _
                               ByRef videoFile As String, _
                               ByRef chaptersJson As String)
    videoFile = ""
    chaptersJson = "[]"

    Dim p1 As Long: p1 = InStr(1, altText, "[[VIDEO:", vbTextCompare)
    If p1 = 0 Then Exit Sub
    p1 = p1 + Len("[[VIDEO:")
    Dim p2 As Long: p2 = InStr(p1, altText, "]]")
    If p2 = 0 Then p2 = Len(altText) + 1

    Dim inner As String
    inner = mid$(altText, p1, p2 - p1)

    Dim parts() As String
    parts = Split(inner, "|")
    If UBound(parts) < 0 Then Exit Sub
    videoFile = Trim$(parts(0))

    Dim q  As String: q = Chr(34)
    Dim js As String: js = "["
    Dim first As Boolean: first = True
    Dim i As Integer

    For i = 1 To UBound(parts)
        Dim part As String: part = Trim$(parts(i))
        If Len(part) = 0 Then GoTo NextPart
        Dim eq As Long: eq = InStr(part, "=")
        If eq = 0 Then GoTo NextPart

        Dim timeStr As String: timeStr = Trim$(Left$(part, eq - 1))
        Dim lbl     As String: lbl = Trim$(mid$(part, eq + 1))
        ' JSON-FIX: HTML-Entities aus Word-Alttext (z.B. &quot;) vor dem JSON-Escaping dekodieren
        lbl = Replace$(lbl, "&quot;", Chr(34))
        lbl = Replace$(lbl, "&#34;", Chr(34))
        lbl = Replace$(lbl, "&apos;", "'")
        lbl = Replace$(lbl, "&#39;", "'")
        lbl = Replace$(lbl, "&amp;", "&")
        lbl = Replace$(lbl, "&lt;", "<")
        lbl = Replace$(lbl, "&gt;", ">")
        lbl = Replace$(lbl, "\", "\\")
        lbl = Replace$(lbl, Chr(34), "\" & Chr(34))

        Dim secs As Long: secs = MmSsToSeconds(timeStr)

        If Not first Then js = js & ","
        js = js & "{" & q & "t" & q & ":" & CStr(secs) & _
             "," & q & "label" & q & ":" & q & lbl & q & "}"
        first = False
NextPart:
    Next i
    chaptersJson = js & "]"
End Sub

' MM:SS -> Sekunden (ganzzahlig)
Private Function MmSsToSeconds(ByVal mmss As String) As Long
    mmss = Trim$(mmss)
    Dim p As Long: p = InStr(mmss, ":")
    If p = 0 Then
        On Error Resume Next
        MmSsToSeconds = CLng(mmss)
        On Error GoTo 0
        Exit Function
    End If
    On Error Resume Next
    MmSsToSeconds = CLng(Left$(mmss, p - 1)) * 60 + CLng(mid$(mmss, p + 1))
    On Error GoTo 0
End Function

' HTML-Attributwert aus Tag-String auslesen (doppelte oder einfache Anfuehrungszeichen)
' FIX v53: Normalisiert Whitespace, da Word img-Attribute auf mehrere Zeilen aufteilt
Private Function ExtractHtmlAttr(ByVal tag As String, ByVal attrName As String) As String
    ' Word bricht <img>-Tags auf mehrere Zeilen um -> \r\n durch Leerzeichen ersetzen
    Dim normTag As String
    normTag = Replace$(tag, vbCrLf, " ")
    normTag = Replace$(normTag, vbCr, " ")
    normTag = Replace$(normTag, vbLf, " ")
    normTag = Replace$(normTag, Chr(9), " ") ' Tab
    
    Dim q As String: q = Chr(34)
    Dim pattern As String: pattern = " " & attrName & "=" & q
    Dim p As Long: p = InStr(1, normTag, pattern, vbTextCompare)
    If p > 0 Then
        p = p + Len(pattern)
        Dim pe As Long: pe = InStr(p, normTag, q)
        If pe > 0 Then ExtractHtmlAttr = mid$(normTag, p, pe - p): Exit Function
    End If
    pattern = " " & attrName & "='"
    p = InStr(1, normTag, pattern, vbTextCompare)
    If p > 0 Then
        p = p + Len(pattern)
        Dim pe2 As Long: pe2 = InStr(p, normTag, "'")
        If pe2 > 0 Then ExtractHtmlAttr = mid$(normTag, p, pe2 - p)
    End If
End Function

' FIX v53: Ungequotetes numerisches Attribut auslesen, z.B. width=559 (Word-Stil ohne Anfuehrungszeichen)
Private Function ExtractUnquotedAttr(ByVal tag As String, ByVal attrName As String) As String
    Dim normTag As String
    normTag = Replace$(Replace$(Replace$(tag, vbCrLf, " "), vbCr, " "), vbLf, " ")
    Dim pattern As String: pattern = " " & attrName & "="
    Dim p As Long: p = InStr(1, normTag, pattern, vbTextCompare)
    If p = 0 Then Exit Function
    p = p + Len(pattern)
    If p > Len(normTag) Then Exit Function
    Dim firstChar As String: firstChar = mid$(normTag, p, 1)
    If firstChar = Chr(34) Or firstChar = "'" Then Exit Function ' gequotet -> von ExtractHtmlAttr behandelt
    Dim numStr As String: numStr = ""
    Do While p <= Len(normTag)
        Dim c As String: c = mid$(normTag, p, 1)
        If c >= "0" And c <= "9" Then numStr = numStr & c Else Exit Do
        p = p + 1
    Loop
    ExtractUnquotedAttr = numStr
End Function

' FIX v53: Bildbreite aus img-Tag (gequotet, ungequotet oder style)
Private Function ExtractImgWidth(ByVal imgTag As String) As String
    Dim v As String: v = ExtractHtmlAttr(imgTag, "width")
    If Len(v) > 0 Then ExtractImgWidth = v: Exit Function
    v = ExtractUnquotedAttr(imgTag, "width") ' Word: width=559 ohne Anf.zeichen
    If Len(v) > 0 Then ExtractImgWidth = v: Exit Function
    ExtractImgWidth = ExtractStyleProp(ExtractHtmlAttr(imgTag, "style"), "width")
End Function

' FIX v53: Bildhoehe aus img-Tag (gequotet, ungequotet oder style)
Private Function ExtractImgHeight(ByVal imgTag As String) As String
    Dim v As String: v = ExtractHtmlAttr(imgTag, "height")
    If Len(v) > 0 Then ExtractImgHeight = v: Exit Function
    v = ExtractUnquotedAttr(imgTag, "height") ' Word: height=366 ohne Anf.zeichen
    If Len(v) > 0 Then ExtractImgHeight = v: Exit Function
    ExtractImgHeight = ExtractStyleProp(ExtractHtmlAttr(imgTag, "style"), "height")
End Function

' Numerischen px-Wert aus CSS-style-String lesen (pt wird umgerechnet)
Private Function ExtractStyleProp(ByVal styleStr As String, ByVal prop As String) As String
    If Len(styleStr) = 0 Then Exit Function
    Dim p As Long: p = InStr(1, styleStr, prop & ":", vbTextCompare)
    If p = 0 Then Exit Function
    p = p + Len(prop) + 1
    Do While p <= Len(styleStr) And mid$(styleStr, p, 1) = " ": p = p + 1: Loop
    Dim numStr As String: numStr = ""
    Do While p <= Len(styleStr)
        Dim c As String: c = mid$(styleStr, p, 1)
        If (c >= "0" And c <= "9") Or c = "." Then numStr = numStr & c Else Exit Do
        p = p + 1
    Loop
    If Len(numStr) = 0 Then Exit Function
    If LCase$(mid$(styleStr, p, 2)) = "pt" Then
        ExtractStyleProp = CStr(CLng(CDbl(numStr) * 1.333))
    Else
        ExtractStyleProp = CStr(CLng(CDbl(numStr)))
    End If
End Function

' Dateinamen in relativem Pfad ersetzen, Ordner bleibt gleich
' "dok_files/image001.png" + "video.mp4" -> "dok_files/video.mp4"
Private Function ReplaceFilenameInPath(ByVal srcPath As String, _
                                        ByVal newFilename As String) As String
    Dim i As Long, lastSlash As Long: lastSlash = 0
    For i = Len(srcPath) To 1 Step -1
        Dim c As String: c = mid$(srcPath, i, 1)
        If c = "/" Or c = "\" Then lastSlash = i: Exit For
    Next i
    If lastSlash > 0 Then
        ReplaceFilenameInPath = Left$(srcPath, lastSlash) & newFilename
    Else
        ReplaceFilenameInPath = newFilename
    End If
End Function

' =============================================================================
' GIF-PLAYER: Hauptfunktion (v56d)
' Sucht alle <img alt="[[GIF|0=Intro|30=Phase1]]"> im HTML,
' liest die GIF-Datei, kodiert sie als Base64 und ersetzt das img-Tag durch:
'   <div class="sbg-wrap" data-gif="pfad.gif" data-gifdata="BASE64..."
'        data-w="480" data-h="360" data-chapters='[...]'></div>
' Kein Netzwerkzugriff zur Laufzeit noetig -> funktioniert bei file://-URLs.
' Alt-Text-Syntax: [[GIF|0=Intro|30=Phase1|75=Finale]]
' =============================================================================
Private Function PatchGifPlaceholders(ByVal html As String, ByVal baseFolder As String) As String
    If InStr(1, html, "[[GIF", vbTextCompare) = 0 Then
        PatchGifPlaceholders = html
        Exit Function
    End If

    Dim q As String: q = Chr(34)
    Dim searchFrom As Long
    searchFrom = 1

    Do
        Dim pMark As Long
        pMark = InStr(searchFrom, html, "[[GIF", vbTextCompare)
        If pMark = 0 Then Exit Do

        Dim pImg As Long
        pImg = InStrRev(html, "<img", pMark, vbTextCompare)
        If pImg = 0 Then searchFrom = pMark + 1: GoTo NextGif

        Dim imgSection As String
        imgSection = mid$(html, pImg, pMark - pImg)
        If InStr(1, imgSection, "alt=", vbTextCompare) = 0 Then
            searchFrom = pMark + 5: GoTo NextGif
        End If
        If InStr(1, imgSection, ">") > 0 Then
            searchFrom = pMark + 5: GoTo NextGif
        End If

        Dim pImgEnd As Long
        pImgEnd = InStr(pMark, html, ">", vbTextCompare)
        If pImgEnd = 0 Then searchFrom = pMark + 1: GoTo NextGif

        Dim imgTag As String
        imgTag = mid$(html, pImg, pImgEnd - pImg + 1)

        Dim altText As String: altText = ExtractHtmlAttr(imgTag, "alt")
        Dim gifSrc  As String: gifSrc = ExtractHtmlAttr(imgTag, "src")
        Dim wPx     As String: wPx = ExtractImgWidth(imgTag)
        Dim hPx     As String: hPx = ExtractImgHeight(imgTag)
        If Len(wPx) = 0 Then wPx = "400"
        If Len(hPx) = 0 Then hPx = "300"

        Dim chaptersJson As String
        chaptersJson = ParseGifAltText(altText)

        Dim gifRelClean As String
        gifRelClean = gifSrc
        gifRelClean = Replace$(gifRelClean, "/", PathSep())
        gifRelClean = Replace$(gifRelClean, "%20", " ")

        Dim gifAbsPath As String
        gifAbsPath = baseFolder & gifRelClean

        Dim B64 As String
        B64 = FileToBase64(gifAbsPath)

        Dim placeholder As String
        If Len(B64) = 0 Then
            searchFrom = pImgEnd + 1
            GoTo NextGif
        End If

        placeholder = "<div class=" & q & "sbg-wrap" & q & _
                      " data-gif=" & q & gifSrc & q & _
                      " data-gifdata=" & q & B64 & q & _
                      " data-w=" & q & wPx & q & _
                      " data-h=" & q & hPx & q & _
                      " data-chapters='" & chaptersJson & "'></div>"

        html = Left$(html, pImg - 1) & placeholder & mid$(html, pImgEnd + 1)
        searchFrom = pImg + Len(placeholder)
NextGif:
    Loop

    PatchGifPlaceholders = html
End Function

' Alt-Text parsen: "[[GIF|0=Intro|30=Phase1|75=Finale]]"
' Liefert JSON: [{"frame":0,"label":"Intro"},{"frame":30,"label":"Phase1"},...]
Private Function ParseGifAltText(ByVal altText As String) As String
    Dim q  As String: q = Chr(34)
    Dim js As String: js = "["
    Dim first As Boolean: first = True

    Dim p1 As Long: p1 = InStr(1, altText, "[[GIF", vbTextCompare)
    If p1 = 0 Then ParseGifAltText = "[]": Exit Function
    Dim p2 As Long: p2 = InStr(p1, altText, "]]")
    If p2 = 0 Then p2 = Len(altText) + 1

    Dim inner As String
    inner = mid$(altText, p1, p2 - p1)

    Dim parts() As String
    parts = Split(inner, "|")

    Dim i As Integer
    For i = 1 To UBound(parts)
        Dim part As String: part = Trim$(parts(i))
        If Len(part) = 0 Then GoTo NextPart
        Dim eq As Long: eq = InStr(part, "=")
        If eq = 0 Then GoTo NextPart

        Dim frameStr As String: frameStr = Trim$(Left$(part, eq - 1))
        Dim lbl      As String: lbl = Trim$(mid$(part, eq + 1))
        lbl = Replace$(lbl, "]]", "")
        ' JSON-FIX: HTML-Entities aus Word-Alttext (z.B. &quot;) vor dem JSON-Escaping dekodieren
        lbl = Replace$(lbl, "&quot;", Chr(34))
        lbl = Replace$(lbl, "&#34;", Chr(34))
        lbl = Replace$(lbl, "&apos;", "'")
        lbl = Replace$(lbl, "&#39;", "'")
        lbl = Replace$(lbl, "&amp;", "&")
        lbl = Replace$(lbl, "&lt;", "<")
        lbl = Replace$(lbl, "&gt;", ">")
        lbl = Replace$(lbl, "\", "\\")
        lbl = Replace$(lbl, Chr(34), "\" & Chr(34))

        If Not IsNumeric(frameStr) Then GoTo NextPart

        If Not first Then js = js & ","
        js = js & "{" & q & "frame" & q & ":" & frameStr & _
             "," & q & "label" & q & ":" & q & lbl & q & "}"
        first = False
NextPart:
    Next i

    ParseGifAltText = js & "]"
End Function

' Datei binaer einlesen und als Base64-String liefern.
' Windows: ADODB.Stream + MSXML2.DOMDocument
' Mac:     Open...For Binary + Pure-VBA Base64-Encoder
Private Function FileToBase64(ByVal filePath As String) As String
    FileToBase64 = ""
    On Error Resume Next
    If Len(Dir$(filePath)) = 0 Then Exit Function
    On Error GoTo 0

    #If Mac Then
        Dim fileNum As Integer
        fileNum = FreeFile()
        Dim fileSz As Long
        fileSz = fileLen(filePath)
        If fileSz = 0 Then Exit Function
        Dim rawBytes() As Byte
        ReDim rawBytes(0 To fileSz - 1)
        Open filePath For Binary Access Read As #fileNum
        Get #fileNum, , rawBytes
        Close #fileNum
        FileToBase64 = Base64EncodePureVBA(rawBytes)
    #Else
        On Error GoTo WinErr
        Dim stream As Object
        Set stream = CreateObject("ADODB.Stream")
        stream.Type = 1
        stream.Open
        stream.LoadFromFile filePath
        Dim winBytes() As Byte
        winBytes = stream.Read
        stream.Close
        Dim xmlDoc As Object
        Set xmlDoc = CreateObject("MSXML2.DOMDocument")
        Dim node As Object
        Set node = xmlDoc.createElement("b64")
        node.DataType = "bin.base64"
        node.nodeTypedValue = winBytes
        FileToBase64 = Replace$(Replace$(node.Text, Chr(13), ""), Chr(10), "")
        Exit Function
WinErr:
        FileToBase64 = ""
    #End If
End Function

' Pure-VBA Base64-Encoder (Mac + Windows-Fallback)
Private Function Base64EncodePureVBA(rawBytes() As Byte) As String
    Const B64 As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
    Dim n As Long
    n = UBound(rawBytes) - LBound(rawBytes) + 1
    If n = 0 Then Exit Function

    Dim outLen As Long
    outLen = ((n + 2) \ 3) * 4
    Dim out() As Byte
    ReDim out(0 To outLen - 1)

    Dim i As Long: i = LBound(rawBytes)
    Dim j As Long: j = 0
    Dim rem3 As Long: rem3 = n

    Do While rem3 >= 3
        Dim b0 As Long: b0 = rawBytes(i)
        Dim b1 As Long: b1 = rawBytes(i + 1)
        Dim b2 As Long: b2 = rawBytes(i + 2)
        out(j) = Asc(mid$(B64, (b0 \ 4) + 1, 1))
        out(j + 1) = Asc(mid$(B64, ((b0 And 3) * 16) + (b1 \ 16) + 1, 1))
        out(j + 2) = Asc(mid$(B64, ((b1 And 15) * 4) + (b2 \ 64) + 1, 1))
        out(j + 3) = Asc(mid$(B64, (b2 And 63) + 1, 1))
        i = i + 3: j = j + 4: rem3 = rem3 - 3
    Loop

    If rem3 = 2 Then
        Dim c0 As Long: c0 = rawBytes(i)
        Dim c1 As Long: c1 = rawBytes(i + 1)
        out(j) = Asc(mid$(B64, (c0 \ 4) + 1, 1))
        out(j + 1) = Asc(mid$(B64, ((c0 And 3) * 16) + (c1 \ 16) + 1, 1))
        out(j + 2) = Asc(mid$(B64, ((c1 And 15) * 4) + 1, 1))
        out(j + 3) = Asc("=")
    ElseIf rem3 = 1 Then
        Dim d0 As Long: d0 = rawBytes(i)
        out(j) = Asc(mid$(B64, (d0 \ 4) + 1, 1))
        out(j + 1) = Asc(mid$(B64, ((d0 And 3) * 16) + 1, 1))
        out(j + 2) = Asc("=")
        out(j + 3) = Asc("=")
    End If

    Base64EncodePureVBA = out
End Function


