Attribute VB_Name = "MonlamPdfAttachment"
Option Explicit

' Native VBA PDF attachment writer. Uses standard Windows ADO streams only;
' no PDF executable, Acrobat, PDF COM library, or Windows API declarations.
' Supports unencrypted PDFs with traditional xref tables, including /Prev
' chains and the historical report's trailing legacy /XRefStm marker. Catalog
' and names dictionaries must be ordinary, uncompressed indirect objects.
' Existing EmbeddedFiles, certified documents, and xref-stream-only files are
' rejected. Intended for a freshly generated Access report, not arbitrary PDFs.
Public Sub AttachMonlamJsonToPdf(ByVal pdfPath As String, ByVal jsonPath As String, Optional ByVal expectedPageCount As Long = 0)
    Dim fso As Object, context As Object, catalog As Object, names As Object
    Dim output As Object, inputJson As Object, trailer As Object
    Dim source As String, temporaryPath As String, backupPath As String
    Dim rootRef As Variant, rootOffset As Long, firstNew As Long, xrefOffset As Long
    Dim offsets(3) As Long, index As Long, jsonSize As Long, fileName As String
    Dim originalMoved As Boolean, failureNumber As Long, failureDescription As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error GoTo AttachmentFailed
    If Not fso.FileExists(pdfPath) Then MPdfFail "PDF not found: " & pdfPath
    If Not fso.FileExists(jsonPath) Then MPdfFail "JSON not found: " & jsonPath
    If StrComp(fso.GetAbsolutePathName(pdfPath), fso.GetAbsolutePathName(jsonPath), vbTextCompare) = 0 Then MPdfFail "PDF and JSON paths must differ."
    source = MPdfReadSource(pdfPath)
    Set context = MPdfContext(source)
    Set trailer = context("Trailer")
    rootRef = MPdfReference(trailer("Root"))
    Set catalog = MPdfIndirectDictionary(context, rootRef)
    If Not catalog.Exists("Type") Then MPdfFail "Missing PDF catalog type."
    If Trim(catalog("Type")) <> "/Catalog" Then MPdfFail "The PDF root is not a catalog."
    If expectedPageCount > 0 Then
        If MPdfPageCount(context, catalog) <> expectedPageCount Then MPdfFail "PDF/JSON page count mismatch: PDF has " & MPdfPageCount(context, catalog) & " pages, JSON has " & expectedPageCount & ". Check the report's record source, filters and sorting."
    End If
    If catalog.Exists("Perms") Then MPdfFail "Certified PDFs are not supported; export a fresh Access report."
    Set names = CreateObject("Scripting.Dictionary")
    If catalog.Exists("Names") Then
        If Trim(catalog("Names")) <> "null" Then Set names = MPdfResolveDictionary(context, catalog("Names"))
    End If
    If names.Exists("EmbeddedFiles") Then
        If Trim(names("EmbeddedFiles")) <> "null" Then MPdfFail "This PDF already has attachments. Export a fresh report before attaching JSON."
    End If
    firstNew = context("Size")
    If CLng(rootRef(0)) >= firstNew Then MPdfFail "Invalid PDF object count."
    Set inputJson = CreateObject("ADODB.Stream")
    inputJson.Type = 1
    inputJson.Open
    inputJson.LoadFromFile jsonPath
    jsonSize = inputJson.Size
    fileName = fso.GetFileName(jsonPath)
    Set output = CreateObject("ADODB.Stream")
    output.Type = 1
    output.Open
    output.LoadFromFile pdfPath
    output.Position = output.Size
    MPdfWrite output, vbCrLf
    offsets(0) = output.Position
    MPdfWrite output, CStr(firstNew) & " 0 obj" & vbCrLf & _
        "<< /Type /EmbeddedFile /Subtype /application#2Fjson /Length " & CStr(jsonSize) & _
        " /Params << /Size " & CStr(jsonSize) & " >> >>" & vbCrLf & "stream" & vbCrLf
    inputJson.CopyTo output
    inputJson.Close
    MPdfWrite output, vbCrLf & "endstream" & vbCrLf & "endobj" & vbCrLf
    offsets(1) = output.Position
    MPdfWrite output, CStr(firstNew + 1) & " 0 obj" & vbCrLf & _
        "<< /Type /Filespec /F " & MPdfFileLiteral(fileName) & " /UF " & MPdfUnicodeString(fileName) & _
        " /EF << /F " & CStr(firstNew) & " 0 R /UF " & CStr(firstNew) & " 0 R >>" & _
        " /Desc (Monlam registration JSON) >>" & vbCrLf & "endobj" & vbCrLf
    offsets(2) = output.Position
    MPdfWrite output, CStr(firstNew + 2) & " 0 obj" & vbCrLf & "<< /Names [" & _
        MPdfUnicodeString(fileName) & " " & CStr(firstNew + 1) & " 0 R] >>" & vbCrLf & "endobj" & vbCrLf
    names("EmbeddedFiles") = CStr(firstNew + 2) & " 0 R"
    offsets(3) = output.Position
    MPdfWrite output, CStr(firstNew + 3) & " 0 obj" & vbCrLf & MPdfDictionaryText(names) & vbCrLf & "endobj" & vbCrLf
    catalog("Names") = CStr(firstNew + 3) & " 0 R"
    rootOffset = output.Position
    MPdfWrite output, CStr(rootRef(0)) & " " & CStr(rootRef(1)) & " obj" & vbCrLf & _
        MPdfDictionaryText(catalog) & vbCrLf & "endobj" & vbCrLf
    xrefOffset = output.Position
    MPdfWrite output, "xref" & vbCrLf & CStr(rootRef(0)) & " 1" & vbCrLf & MPdfXrefEntry(rootOffset, CLng(rootRef(1))) & _
        CStr(firstNew) & " 4" & vbCrLf
    For index = 0 To 3
        MPdfWrite output, MPdfXrefEntry(offsets(index), 0)
    Next index
    Set names = CreateObject("Scripting.Dictionary")
    names("Size") = CStr(firstNew + 4)
    names("Root") = CStr(rootRef(0)) & " " & CStr(rootRef(1)) & " R"
    names("Prev") = CStr(context("StartXref"))
    If trailer.Exists("Info") Then names("Info") = trailer("Info")
    If trailer.Exists("ID") Then names("ID") = trailer("ID")
    MPdfWrite output, "trailer" & vbCrLf & MPdfDictionaryText(names) & vbCrLf & _
        "startxref" & vbCrLf & CStr(xrefOffset) & vbCrLf & "%%EOF" & vbCrLf
    temporaryPath = pdfPath & "." & fso.GetTempName & ".pdf"
    backupPath = pdfPath & "." & fso.GetTempName & ".bak"
    output.SaveToFile temporaryPath, 1
    output.Close
    ' Re-read our own offsets before touching the original. Independent PDF
    ' readers are also used by the regression tests.
    Set context = MPdfContext(MPdfReadSource(temporaryPath))
    Set catalog = MPdfIndirectDictionary(context, MPdfReference(context("Trailer")("Root")))
    Set names = MPdfResolveDictionary(context, catalog("Names"))
    If Not names.Exists("EmbeddedFiles") Then MPdfFail "Attachment verification failed."
    fso.MoveFile pdfPath, backupPath
    originalMoved = True
    fso.MoveFile temporaryPath, pdfPath
    fso.DeleteFile backupPath
    Exit Sub
AttachmentFailed:
    failureNumber = Err.Number
    failureDescription = Err.Description
    If Not output Is Nothing Then
        If output.State <> 0 Then output.Close
    End If
    If Not inputJson Is Nothing Then
        If inputJson.State <> 0 Then inputJson.Close
    End If
    If originalMoved Then
        If Not fso.FileExists(pdfPath) Then fso.MoveFile backupPath, pdfPath
    End If
    If Len(temporaryPath) > 0 Then
        If fso.FileExists(temporaryPath) Then fso.DeleteFile temporaryPath
    End If
    Err.Raise failureNumber, "MonlamPdfAttachment.AttachMonlamJsonToPdf", failureDescription
End Sub

Private Function MPdfPageCount(ByVal context As Object, ByVal catalog As Object) As Long
    Dim pages As Object
    If Not catalog.Exists("Pages") Then MPdfFail "PDF page tree is missing."
    Set pages = MPdfResolveDictionary(context, catalog("Pages"))
    If Not pages.Exists("Count") Then MPdfFail "PDF page count is missing."
    MPdfPageCount = MPdfNumber(Trim(pages("Count")))
End Function

Private Sub MPdfFail(ByVal message As String)
    Err.Raise 513, "MonlamPdfAttachment", message
End Sub

Private Function MPdfReadSource(ByVal filePath As String) As String
    Dim stream As Object, byteCount As Long
    Set stream = CreateObject("ADODB.Stream")
    stream.Type = 1
    stream.Open
    stream.LoadFromFile filePath
    byteCount = stream.Size
    stream.Position = 0
    stream.Type = 2
    stream.Charset = "iso-8859-1"
    MPdfReadSource = stream.ReadText
    stream.Close
    If Len(MPdfReadSource) <> byteCount Then MPdfFail "Cannot map PDF bytes to character offsets."
    If Left(MPdfReadSource, 5) <> "%PDF-" Then MPdfFail "Not a PDF file."
End Function

Private Sub MPdfWrite(ByVal output As Object, ByVal value As String)
    Dim text As Object
    Set text = CreateObject("ADODB.Stream")
    text.Type = 2
    text.Charset = "iso-8859-1"
    text.Open
    text.WriteText value
    text.Position = 0
    text.Type = 1
    text.CopyTo output
    text.Close
End Sub

Private Function MPdfXrefEntry(ByVal offset As Long, ByVal generation As Long) As String
    MPdfXrefEntry = Right("0000000000" & CStr(offset), 10) & " " & Right("00000" & CStr(generation), 5) & " n" & vbCrLf
End Function

Private Function MPdfUnicodeString(ByVal value As String) As String
    Dim index As Long, code As Long, result As String
    result = "<FEFF"
    For index = 1 To Len(value)
        code = AscW(Mid(value, index, 1))
        If code < 0 Then code = code + 65536
        result = result & Right("0000" & Hex(code), 4)
    Next index
    MPdfUnicodeString = result & ">"
End Function

Private Function MPdfFileLiteral(ByVal value As String) As String
    Dim index As Long, code As Long
    For index = 1 To Len(value)
        code = AscW(Mid(value, index, 1))
        If code < 32 Or code > 126 Then value = "registration.json": Exit For
    Next index
    value = Replace(value, "\", "\\")
    value = Replace(value, "(", "\(")
    value = Replace(value, ")", "\)")
    MPdfFileLiteral = "(" & value & ")"
End Function

' PDF lexer: comments, escaped/balanced strings, hex strings, dictionaries,
' arrays and indirect references. Never search arbitrary stream bytes for obj.
Private Function MPdfWhite(ByVal character As String) As Boolean
    MPdfWhite = (Len(character) > 0 And InStr(1, Chr(0) & vbTab & vbLf & Chr(12) & vbCr & " ", character, vbBinaryCompare) > 0)
End Function

Private Function MPdfDelimiter(ByVal character As String) As Boolean
    MPdfDelimiter = (Len(character) = 0 Or InStr(1, "()<>[]{}/%", character, vbBinaryCompare) > 0)
End Function

Private Function MPdfToken(ByRef source As String, ByRef position As Long) As String
    Dim start As Long, character As String, depth As Long
    Do While position <= Len(source)
        character = Mid(source, position, 1)
        If MPdfWhite(character) Then
            position = position + 1
        ElseIf character = "%" Then
            Do While position <= Len(source)
                character = Mid(source, position, 1)
                position = position + 1
                If character = vbCr Or character = vbLf Then Exit Do
            Loop
        Else
            Exit Do
        End If
    Loop
    If position > Len(source) Then MPdfFail "Unexpected end of PDF syntax."
    start = position
    character = Mid(source, position, 1)
    position = position + 1
    Select Case character
        Case "("
            depth = 1
            Do While position <= Len(source) And depth > 0
                character = Mid(source, position, 1)
                If character = "\" Then
                    position = position + 2
                Else
                    If character = "(" Then depth = depth + 1
                    If character = ")" Then depth = depth - 1
                    position = position + 1
                End If
            Loop
            If depth <> 0 Then MPdfFail "Unterminated PDF string."
        Case "<"
            If Mid(source, position, 1) = "<" Then
                position = position + 1
            Else
                position = InStr(position, source, ">", vbBinaryCompare)
                If position = 0 Then MPdfFail "Unterminated PDF hex string."
                position = position + 1
            End If
        Case ">"
            If Mid(source, position, 1) <> ">" Then MPdfFail "Unexpected PDF delimiter."
            position = position + 1
        Case "[", "]"
            ' One-character tokens.
        Case Else
            Do While position <= Len(source)
                character = Mid(source, position, 1)
                If MPdfWhite(character) Or MPdfDelimiter(character) Then Exit Do
                position = position + 1
            Loop
    End Select
    MPdfToken = Mid(source, start, position - start)
End Function

Private Function MPdfUnsigned(ByVal value As String) As Boolean
    Dim index As Long, character As String
    MPdfUnsigned = False
    If Len(value) = 0 Then Exit Function
    For index = 1 To Len(value)
        character = Mid(value, index, 1)
        If character < "0" Or character > "9" Then Exit Function
    Next index
    MPdfUnsigned = True
End Function

Private Function MPdfNumber(ByVal value As String) As Long
    If Not MPdfUnsigned(value) Then MPdfFail "Expected a PDF integer."
    If CDbl(value) > 2147480000 Then MPdfFail "PDF offset/object count exceeds this VBA writer's limit."
    MPdfNumber = CLng(value)
End Function

Private Function MPdfValue(ByRef source As String, ByRef position As Long, ByVal depth As Long) As String
    Dim start As Long, saved As Long, token As String, nextToken As String, ignored As String
    If depth > 64 Then MPdfFail "PDF syntax nesting is too deep."
    token = MPdfToken(source, position)
    start = position - Len(token)
    If token = "<<" Then
        Do
            nextToken = MPdfToken(source, position)
            If nextToken = ">>" Then Exit Do
            If Left(nextToken, 1) <> "/" Then MPdfFail "Expected a PDF dictionary key."
            ignored = MPdfValue(source, position, depth + 1)
        Loop
    ElseIf token = "[" Then
        Do
            saved = position
            nextToken = MPdfToken(source, position)
            If nextToken = "]" Then Exit Do
            position = saved
            ignored = MPdfValue(source, position, depth + 1)
        Loop
    ElseIf MPdfUnsigned(token) Then
        saved = position
        nextToken = MPdfToken(source, position)
        If MPdfUnsigned(nextToken) Then
            nextToken = MPdfToken(source, position)
            If nextToken <> "R" Then position = saved
        Else
            position = saved
        End If
    ElseIf token = ">>" Or token = "]" Or token = ")" Then
        MPdfFail "Unexpected PDF value delimiter."
    End If
    MPdfValue = Trim(Mid(source, start, position - start))
End Function

Private Function MPdfDecodeName(ByVal token As String) As String
    Dim position As Long, character As String, result As String
    position = 2
    Do While position <= Len(token)
        character = Mid(token, position, 1)
        If character = "#" Then
            If position + 2 > Len(token) Then MPdfFail "Invalid PDF name escape."
            character = Chr(CLng("&H" & Mid(token, position + 1, 2)))
            position = position + 2
        End If
        result = result & character
        position = position + 1
    Loop
    MPdfDecodeName = result
End Function

Private Function MPdfDictionary(ByRef source As String, ByRef position As Long) As Object
    Dim result As Object, token As String, key As String
    Set result = CreateObject("Scripting.Dictionary")
    If MPdfToken(source, position) <> "<<" Then MPdfFail "Expected a PDF dictionary."
    Do
        token = MPdfToken(source, position)
        If token = ">>" Then Exit Do
        If Left(token, 1) <> "/" Then MPdfFail "Expected a PDF dictionary key."
        key = MPdfDecodeName(token)
        If result.Exists(key) Then MPdfFail "Duplicate PDF dictionary key."
        result(key) = MPdfValue(source, position, 0)
    Loop
    Set MPdfDictionary = result
End Function

Private Function MPdfDictionaryText(ByVal dictionary As Object) As String
    Dim key As Variant, index As Long, code As Long, name As String, character As String, result As String
    result = "<<"
    For Each key In dictionary.Keys
        name = ""
        For index = 1 To Len(CStr(key))
            character = Mid(CStr(key), index, 1)
            code = AscW(character)
            If code < 33 Or code > 126 Or character = "#" Or MPdfDelimiter(character) Then
                If code < 0 Or code > 255 Then MPdfFail "Unsupported PDF dictionary key encoding."
                name = name & "#" & Right("00" & Hex(code), 2)
            Else
                name = name & character
            End If
        Next index
        result = result & " /" & name & " " & dictionary(key) & vbCrLf
    Next key
    MPdfDictionaryText = result & ">>"
End Function

Private Function MPdfReference(ByVal value As String) As Variant
    Dim position As Long, number As Long, generation As Long
    position = 1
    number = MPdfNumber(MPdfToken(value, position))
    generation = MPdfNumber(MPdfToken(value, position))
    If MPdfToken(value, position) <> "R" Then MPdfFail "Expected an indirect PDF reference."
    If generation > 65535 Then MPdfFail "Invalid PDF object generation."
    MPdfReference = Array(number, generation)
End Function

Private Function MPdfContext(ByVal source As String) As Object
    Dim context As Object, entries As Object, seen As Object, trailer As Object, merged As Object
    Dim marker As Long, position As Long, current As Long, latest As Long, first As Long, count As Long
    Dim offset As Long, generation As Long, size As Long, index As Long, chainDepth As Long
    Dim token As String, flag As String, key As Variant
    Set context = CreateObject("Scripting.Dictionary")
    Set entries = CreateObject("Scripting.Dictionary")
    Set seen = CreateObject("Scripting.Dictionary")
    Set merged = CreateObject("Scripting.Dictionary")
    marker = InStrRev(source, "startxref", -1, vbBinaryCompare)
    If marker = 0 Then MPdfFail "PDF startxref is missing."
    position = marker + Len("startxref")
    latest = MPdfNumber(MPdfToken(source, position))
    If InStr(position, source, "%%EOF", vbBinaryCompare) = 0 Then MPdfFail "PDF end marker is missing."
    current = latest
    Do
        If seen.Exists(CStr(current)) Then MPdfFail "Cyclic PDF cross-reference chain."
        seen(CStr(current)) = True
        chainDepth = chainDepth + 1
        If chainDepth > 64 Then MPdfFail "Too many PDF incremental updates."
        If current < 0 Or current >= Len(source) Then MPdfFail "PDF cross-reference offset is outside the file."
        position = current + 1
        If MPdfToken(source, position) <> "xref" Then MPdfFail "Cross-reference stream PDFs are not supported. Export a fresh Access report PDF."
        Do
            token = MPdfToken(source, position)
            If token = "trailer" Then Exit Do
            first = MPdfNumber(token)
            count = MPdfNumber(MPdfToken(source, position))
            If count > 1000000 Or first > 2146480000 Then MPdfFail "PDF cross-reference table is too large."
            For index = 0 To count - 1
                offset = MPdfNumber(MPdfToken(source, position))
                generation = MPdfNumber(MPdfToken(source, position))
                flag = MPdfToken(source, position)
                If generation > 65535 Or (flag <> "n" And flag <> "f") Then MPdfFail "Invalid PDF cross-reference entry."
                key = CStr(first + index)
                If Not entries.Exists(key) Then entries(key) = Array(offset, generation, flag)
                If first + index + 1 > size Then size = first + index + 1
            Next index
        Loop
        Set trailer = MPdfDictionary(source, position)
        If trailer.Exists("XRefStm") Then
            ' The legacy Access sample has a trailing empty xref table pointing
            ' back to an already covered stream, before its previous classic xref.
            ' A new hybrid stream could override objects absent from this table;
            ' without decoding that stream, using older object offsets is unsafe.
            If Not trailer.Exists("Prev") Then MPdfFail "New hybrid cross-reference streams are not supported."
            If MPdfNumber(Trim(trailer("XRefStm"))) >= MPdfNumber(Trim(trailer("Prev"))) Then MPdfFail "New hybrid cross-reference streams are not supported."
        End If
        If trailer.Exists("Encrypt") Then
            If Trim(trailer("Encrypt")) <> "null" Then MPdfFail "Encrypted PDFs are not supported."
        End If
        If trailer.Exists("Size") Then
            index = MPdfNumber(Trim(trailer("Size")))
            If index > size Then size = index
        End If
        For Each key In trailer.Keys
            If Not merged.Exists(key) Then merged(key) = trailer(key)
        Next key
        If Not trailer.Exists("Prev") Then Exit Do
        current = MPdfNumber(Trim(trailer("Prev")))
    Loop
    If Not merged.Exists("Root") Then MPdfFail "PDF catalog reference is missing."
    context("Source") = source
    context("Size") = size
    context("StartXref") = latest
    Set context("Entries") = entries
    Set context("Trailer") = merged
    Set MPdfContext = context
End Function

Private Function MPdfIndirectDictionary(ByVal context As Object, ByVal reference As Variant) As Object
    Dim entry As Variant, position As Long, source As String, result As Object
    If Not context("Entries").Exists(CStr(reference(0))) Then MPdfFail "The required PDF object is compressed or missing."
    entry = context("Entries")(CStr(reference(0)))
    If entry(2) <> "n" Or CLng(entry(1)) <> CLng(reference(1)) Then MPdfFail "Invalid PDF object reference."
    source = context("Source")
    position = CLng(entry(0)) + 1
    If MPdfNumber(MPdfToken(source, position)) <> CLng(reference(0)) Then MPdfFail "PDF object offset mismatch."
    If MPdfNumber(MPdfToken(source, position)) <> CLng(reference(1)) Then MPdfFail "PDF object generation mismatch."
    If MPdfToken(source, position) <> "obj" Then MPdfFail "Missing PDF object header."
    Set result = MPdfDictionary(source, position)
    If MPdfToken(source, position) <> "endobj" Then MPdfFail "Expected an ordinary PDF dictionary object."
    Set MPdfIndirectDictionary = result
End Function

Private Function MPdfResolveDictionary(ByVal context As Object, ByVal value As String) As Object
    Dim position As Long, token As String
    position = 1
    token = MPdfToken(value, position)
    If token = "<<" Then
        position = 1
        Set MPdfResolveDictionary = MPdfDictionary(value, position)
    Else
        Set MPdfResolveDictionary = MPdfIndirectDictionary(context, MPdfReference(value))
    End If
End Function