KSEF w VBA Excel

# LibGovPL - KSeF - Nawiazywanie sesji interaktywnej tokenem i pobranie faktury
try {
    # Tworzenie obiektu zaplecza
    $backend = New-Object -ComObject LibGovPL.lgcBackend

    # Tworzenie obiektu komunikacji KSeF
    $ksef = $backend.CreateKSeF()

    # Tworzenie obiektu klienta HTTP
    $ksef.HTTPClient = $backend.CreateHTTPClient('')

    # Tworzenie klucza RSA ze wskazanego pliku
    $ksef.RSAKeyTest = $backend.CreateRSAKey('', 'kseftest.pem')

    # Ustawiamy parametry polaczenia
    $ksef.Nip = '1111111111'
    $ksef.Token = '1111111111111112222222222222333333333333444444444445555555555666'
    $ksef.GateType = 2 # Rodzaj serwera KSeF: 0 - produkcja, 1 - demo, 2 - test
    $ksef.FormCode = 1 # Wersja struktury wysylanych plikow FA: 0 - FA(1), 1 - FA(2)

    # Nawiazywanie sesji interaktywnej tokenem
    $response = $ksef.SessionInitToken()

    # Napisz token sesji
    Write-Host 'Token sesji: ' $response.SessionToken().Token()
    # Napisz odpowiedz w postaci surowego JSON
    Write-Host 'Surowa odpowiedz JSON: ' $response.GetRawResponse()
    $response = $null

    # Odczekaj pare sekund po nawiazaniu sesji bo inaczej serwer odrzuci zadanie
    Write-Host 'Momencik...'
    Start-Sleep -Seconds 10

    # Pobierz fakture i zapisz do pliku
    $ksef.InvoiceGet('1111111111-20241127-333333333333-QQ', 'fa.xml')
    Write-Host 'Pobrano fakture'
}
catch {
    Write-Host -f Red "Blad: $_"
}

if ((Get-Variable -Name ksef -ErrorAction SilentlyContinue) -And ($ksef -ne $null)) {
    if ($ksef.SessionActive) {

        # Konczenie sesji KSeF
        $ksef.SessionTerminate(0)        

    }
    $ksef = $null
}

$backend = $null

# LibGovPL - KSeF - Nawiazywanie sesji interaktywnej certyfikatem i wyszukiwanie synchronicznie
try {
    # Tworzenie obiektu zaplecza
    $backend = New-Object -ComObject LibGovPL.lgcBackend
    
    # Tworzenie obiektu podpisu certyfikatem kwalifikowanym lub pieczecia
    $certSigner = $backend.CreateCertificateSigner('')

    # Wybierz certyfikat przez systemowe okienko wyboru certyfikatu
    $cert = $certSigner.UISelect()

    if ($cert -ne $null) {

        # Tworzymy obiekt obslugi podpisu XAdES
        $xades = $backend.CreateXAdES()
        # Ustawiamy obiekt obslugi podpisu certyfikatem
        $xades.Signer = $certSigner

        # Tworzenie obiektu komunikacji KSeF
        $ksef = $backend.CreateKSeF()

        # Tworzenie obiektu klienta HTTP
        $ksef.HTTPClient = $backend.CreateHTTPClient('')
        # Tworzenie klucza RSA ze wskazanego pliku bo uzyjemy dodatkowego szyfrowania AES
        $ksef.RSAKeyDemo = $backend.CreateRSAKey('', 'ksefdemo.pem')
        # Ustawiamy obiekt sygnatury XAdES
        $ksef.XAdES = $xades
        # Uzywamy wybranego certyfikatu
        $ksef.Certificate = $cert

        # Ustawiamy parametry polaczenia
        $ksef.Nip = '1111111111'
        $ksef.GateType = 1 # Rodzaj serwera KSeF: 0 - produkcja, 1 - demo, 2 - test
        $ksef.Encryption = $true # Wlacz dodatkowe szyfrowanie dokumentow algorytmem AES
        $ksef.FormCode = 1 # Wersja struktury wysylanych plikow FA: 0 - FA(1), 1 - FA(2)

        # Czyscimy informacje o ostatnim bledzie
        $backend.ClearLastError()
        $aborted = $false
        try {
            # Nawiazywanie sesji interaktywnej wybranym certyfikatem
            $response = $ksef.SessionInitSigned()
        }
        catch {
            $aborted = $true
            # Sprawdz, czy anulowano wprowadzanie PIN
            if (($backend.LastError -ne $null) -And ($backend.LastError.ExceptionClass -eq 'EAbort')) {
                Write-Host -f Yellow 'Anulowano wprowadzanie nr PIN'
            }
            else {
                Write-Host -f Red "Blad: $_"
            }
        }

        if ($aborted -eq $false) {

            # Napisz token sesji
            Write-Host 'Token sesji: ' $response.SessionToken().Token()
            # Napisz odpowiedz w postaci surowego JSON
            Write-Host 'Surowa odpowiedz JSON: ' $response.GetRawResponse()

            # Odczekaj pare sekund po nawiazaniu sesji bo inaczej serwer odrzuci zadanie
            Write-Host 'Momencik...'
            Start-Sleep -Seconds 10

            # Tworzenie obiektu kryteriow zapytania
            $criteria = $ksef.CreateKSeFObject('TKSeFQueryCriteriaInvoiceDetail')
            # Wyszukaj faktury sprzedazowe (gdzie w fa wystepujamy jako "Podmiot1")
            $criteria.SubjectType = 0 # 0 - subject1, 1 - subject2, 2 - subject3, ...
            # Okres wystawienia wysukiwanych faktur
            $criteria.InvoicingDateFrom = (Get-Date).AddDays(-30)
            $criteria.InvoicingDateTo = Get-Date
            # Tylko wystawione w walucie PLN i EUR
            $criteria.CurrencyCodesStr = 'PLN,EUR'

            # Tworzymy obiekt zapytania o faktury
            $request = $ksef.CreateKSeFObject('TKSeFQueryInvoiceRequest')
            # Ustawiamy obiekt kryteriow
            $request.QueryCriteria = $criteria
            Write-Host 'Surowe zadanie: ' $request.GetAsJSON()

            # Zapytaj o faktury synchronicznie (10 na stronie, offset 0)
            $response = $ksef.QueryInvoiceSync($request, 10, 0)
            Write-Host 'Surowe odpowiedz: ' $response.GetRawResponse()
            Write-Host 'Ilosc faktur: ' $response.InvoiceHeaderList().Count()

            for ($i = 0; $i -lt $response.InvoiceHeaderList().Count(); $i++) {
                # Wypisz numery znalezionych faktur
                Write-Host $response.InvoiceHeaderList().Item($i).InvoiceReferenceNumber()
            }
        }
    }
    else {
        Write-Host -f Yellow 'Anulowano wybor certyfikatu'
    }
}
catch {
    Write-Host -f Red "Blad: $_"
}

if ((Get-Variable -Name ksef -ErrorAction SilentlyContinue) -And ($ksef -ne $null)) {
    if ($ksef.SessionActive) {

        # Konczenie sesji KSeF
        $ksef.SessionTerminate(0)        

    }
    $ksef = $null
}

$xades = $null
$cert = $null
$certSigner = $null
$backend = $null

Option Explicit
'========================================================
'  KONFIGURACJA
'========================================================
Const URL_BASE As String = "https://api-test.ksef.mf.gov.pl/"
Const NIP As String = "5555555555"
Const PUBLIC_KEY_KSEF As String = _
"MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAtCVoNVHGeaOwmzuFMiScJozTbh+ULVtQYmRNTON+20ilBOqkHrJRUZCtXUg0w+ztYMvWFr4U74ykGMnEYODT7l2F8JGuJeE9YGK8hKqaY5h0YYxJW7fWybZOxQJhwXzuasjKt/OHYWrI6SmL96bSanr6MwGNr6yiNQV3R6EFB/wpZ4scwh8ZfEs0kk29uIgZVEbkq+9n/xRQjbAtaQs6eiDb4AUOBd7nm4+Uis5goHkjTtJwmhcpQq5Vw7lug3FUsn7/luNyCVhaR4BkpB3NVexxepYSByJneFrOgOh/3GilK2a47WPAEVG3hRQAiGBUR0m7Ev7WYboQtA1TI7hc6wIDAQAB"
Const TOKEN_KSEF As String = _
"20251209-EC-2166C68000-949554F3BB-89|nip-5555555555|72ccfc3ea32643e0b55c8d182b622ebefecc979f8ec14729b681525328fab75d"
'========================================================
'  FUNKCJE POMOCNICZE
'========================================================
Function EscapeJSON(ByVal s As String) As String
    s = Replace(s, "\", "\\")
    s = Replace(s, """", "\""")
    EscapeJSON = s
End Function

Function ParseJSONValue(json As String, key As String) As String
    Dim p1 As Long, p2 As Long
    p1 = InStr(json, """" & key & """:")
    If p1 = 0 Then Exit Function
    p1 = InStr(p1, json, ":") + 1
    If Mid(json, p1, 1) = """" Then
        p1 = p1 + 1
        p2 = InStr(p1, json, """")
    Else
        p2 = InStr(p1, json, ",")
        If p2 = 0 Then p2 = InStr(p1, json, "}")
    End If
    ParseJSONValue = Mid(json, p1, p2 - p1)
End Function


Function KSeF_IsoToTimestampMs(iso As String) As String
    Dim d As Date, base As Date, msStr As String, ms As Long
    Dim dotPos As Long, plusPos As Long, totalMs As Double
    On Error GoTo ErrHandler

    d = CDate(Replace(Left$(iso, 19), "T", " "))
    dotPos = InStr(iso, ".")
    If dotPos > 0 Then
        plusPos = InStr(dotPos, iso, "+")
        If plusPos = 0 Then plusPos = Len(iso) + 1
        msStr = Mid$(iso, dotPos + 1, plusPos - dotPos - 1)
        If Len(msStr) > 3 Then msStr = Left$(msStr, 3)
        ms = CLng(msStr)
    End If

    base = DateSerial(1970, 1, 1)
    totalMs = (d - base) * 86400000# + ms
    KSeF_IsoToTimestampMs = CStr(Fix(totalMs))
    Exit Function
ErrHandler:
    KSeF_IsoToTimestampMs = ""
End Function

'========================================================
'  KROK 1 - POBRANIE CHALLENGE
'========================================================
Sub KSeF_GetChallenge()
    Dim xmlhttp As Object, Param As String, resp As String
    Set xmlhttp = CreateObject("MSXML2.XMLHTTP.6.0")
    Param = "{""contextIdentifier"":{""type"":""NIP"",""identifier"":""" & NIP & """}}"
    xmlhttp.Open "POST", URL_BASE & "api/v2/auth/challenge", False
    xmlhttp.setRequestHeader "Content-Type", "application/json"
    xmlhttp.setRequestHeader "Accept", "application/json"
    xmlhttp.send Param
    resp = xmlhttp.responseText
    If xmlhttp.status <> 200 Then
        MsgBox "? Challenge error " & xmlhttp.status & vbCrLf & resp, vbCritical
        Exit Sub
    End If
    Range("A1:H1").Value = Array("Challenge", "TimestampISO", "Token|TS", "Encrypted", "AuthResponse", "JWT", "StatusResp", "ValidUntil")
    Range("A2").Value = ParseJSONValue(resp, "challenge")
    Range("B2").Value = ParseJSONValue(resp, "timestamp")
    MsgBox "? Challenge OK"
End Sub
'========================================================
'  SZYFROWANIE RSA-OAEP-SHA256
'========================================================
Function Encrypt_RSA_OAEP_SHA256(pubKeyB64 As String, textToEncrypt As String) As String
    Dim fso As Object, shell As Object, file As Object, psScript As String, output As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set shell = CreateObject("WScript.Shell")
    psScript = Environ("TEMP") & "\rsa_enc_ksef.ps1"

    Set file = fso.CreateTextFile(psScript, True)
    file.WriteLine ("$pub=[Convert]::FromBase64String('" & pubKeyB64 & "')")
    file.WriteLine ("$rsa=[Security.Cryptography.RSACng]::new()")
    file.WriteLine ("$rsa.ImportSubjectPublicKeyInfo($pub,[ref]0)")
    file.WriteLine ("$data=[Text.Encoding]::UTF8.GetBytes('" & textToEncrypt & "')")
    file.WriteLine ("$enc=$rsa.Encrypt($data,[Security.Cryptography.RSAEncryptionPadding]::OaepSHA256)")
    file.WriteLine ("[Convert]::ToBase64String($enc)")
    file.Close

    Set output = shell.Exec("powershell -ExecutionPolicy Bypass -File """ & psScript & """")
    Encrypt_RSA_OAEP_SHA256 = Trim(output.StdOut.ReadAll)
End Function
'========================================================
'  KROK 2 - AUTORYZACJA TOKENEM
'========================================================
Sub KSeF_Auth_ByToken()
    Dim xmlhttp As Object
    Dim challengeVal As String, tsIso As String
    Dim tsMs As String, plainText As String, encrypted As String, Param As String
    Dim referenceNumber As String
    Dim resp As String

    challengeVal = Trim(Range("A2").Value)
    tsIso = Trim(Range("B2").Value)

    If challengeVal = "" Or tsIso = "" Then
        MsgBox "Najpierw wykonaj KSeF_GetChallenge.", vbExclamation
        Exit Sub
    End If

    ' ?? obliczamy timestamp raz i zapisujemy na arkusz, by użyć w obu miejscach
    tsMs = KSeF_IsoToTimestampMs(tsIso)
    Range("B3").Value = tsMs        ' jeden i ten sam timestamp w całym procesie

    ' ?? budujemy tekst do szyfrowania - tu używamy TEGO SAMEGO tsMs
    plainText = TOKEN_KSEF & "|" & tsMs
    Range("C2").Value = plainText   ' wgląd

    ' ?? szyfrowanie
    encrypted = Encrypt_RSA_OAEP_SHA256(PUBLIC_KEY_KSEF, plainText)
    encrypted = Replace(encrypted, vbCrLf, "")
    encrypted = Replace(encrypted, vbLf, "")
    encrypted = Replace(encrypted, vbCr, "")
    encrypted = Trim(encrypted)
    encrypted = EscapeJSON(encrypted)
    ActiveSheet.Range("F4").Value = encrypted

    ' ?? JSON wysyłany - ten sam tsMs
    Param = "{""challenge"":""" & challengeVal & """,""timestamp"":" & tsMs & _
         ",""contextIdentifier"":{""type"":""NIP"",""Value"":""" & NIP & """},""encryptedToken"":""" & encrypted & """}"
    Range("E3").Value = Param

    ' ?? wysyłka
    Set xmlhttp = CreateObject("MSXML2.XMLHTTP.6.0")
    With xmlhttp
    .Open "POST", URL_BASE & "api/v2/auth/ksef-token", False
    .setRequestHeader "Content-Type", "application/json"
    .setRequestHeader "Accept", "application/json"
    .send Param
    Range("E2").Value = xmlhttp.responseText
    resp = xmlhttp.responseText
    Range("I2").Value = ParseJSONValue(resp, "referenceNumber")
    MsgBox "HTTP " & xmlhttp.status & vbCrLf & xmlhttp.responseText
    End With
    
End Sub
'========================================================
'  KROK 3 - STATUS AUTORYZACJI
'========================================================
Sub KSeF_AuthStatus_ByReference()
    Dim xmlhttp As Object, ref As String, resp As String
    ref = Range("E2").Value
    If ref = "" Then
        MsgBox "Brak referenceNumber w odpowiedzi (E2).", vbInformation
        Exit Sub
    End If
    Set xmlhttp = CreateObject("MSXML2.XMLHTTP.6.0")
    xmlhttp.Open "GET", URL_BASE & "api/v2/auth/" & ref, False
    xmlhttp.setRequestHeader "Accept", "application/json"
    xmlhttp.send
    resp = xmlhttp.responseText
    Range("G2").Value = resp
    If xmlhttp.status = 200 Then
        Range("F2").Value = ParseJSONValue(resp, "token")
        MsgBox "? JWT pobrany.", vbInformation
   ElseIf xmlhttp.status = 202 Then
        MsgBox "? Nadal 202 - spróbuj ponownie za kilka sekund.", vbInformation
    Else
        MsgBox "? Błąd " & xmlhttp.status & vbCrLf & resp, vbCritical
    End If
End Sub
'========================================================
'  KROK 4 - STATUS TOKENA JWT
'========================================================
Sub KSeF_CheckAuthStatus()
    Dim xmlhttp As Object, resp As String, referenceNumber As String
    
    ' Aktualizuj numer referencyjny przed użyciem
    referenceNumber = Trim(Range("I2").Value)
    If referenceNumber = "" Then
        MsgBox "Brak tokena referenceNumber - pobierz go KSeF_AuthStatus_ByReference.", vbExclamation
        Exit Sub
    End If

    Set xmlhttp = CreateObject("MSXML2.XMLHTTP.6.0")
    xmlhttp.Open "GET", URL_BASE & "api/v2/auth/status", False
    xmlhttp.setRequestHeader "Authorization", "Bearer " & referenceNumber
    xmlhttp.setRequestHeader "Accept", "application/json"
    xmlhttp.send

    resp = xmlhttp.responseText
    Range("G2").Value = resp ' Aktualizuj odpowiedź w G2

    If xmlhttp.status = 200 Then
        Range("H2").Value = ParseJSONValue(resp, "validUntil")
        MsgBox "? Token aktywny." & vbCrLf & "Ważny do: " & Range("H2").Value, vbInformation
    Else
        MsgBox "? Błąd statusu: " & xmlhttp.status & vbCrLf & resp, vbCritical
    End If
End Sub
'========================================================
'  GŁÓWNY PRZEPŁYW - PEŁNA SEKWENCJA
'========================================================
Sub KSeF_FullAuthSequence()
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Application.StatusBar = "Autoryzacja KSeF..."
    Call KSeF_GetChallenge
    Call KSeF_Auth_ByToken
    Dim i As Integer
    For i = 1 To 5
        DoEvents
        Application.Wait (Now + TimeValue("0:00:03"))
        Call KSeF_AuthStatus_ByReference
        If Trim(Range("F2").Value) <> "" Then Exit For
    Next i
    Call KSeF_CheckAuthStatus
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox "? Pełna sekwencja KSeF wykonana.", vbInformation
    Exit Sub
ErrHandler:
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox "Błąd: " & Err.Description, vbCritical
End Sub
'========================================================