Witam,
czy ktoś mógłby pomóc w dalszych pracach nad poniższym kodem?
Option Explicit
Dim key, strRequest, response As String
Private Declare Function ShellExecute _
Lib "shell32.dll" _
Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) _
As Long
Private Sub Command2_Click()
Dim request As New WinHttpRequest
key = "7FCE5545743BF77DCA43DEAA492BB78C5A5B56EB162087ABBD012038EED73BD4"
request.Option(4) = 13056
request.SetTimeouts 500000, 500000, 500000, 500000
100 request.Open "POST", "https://ksef-test.mf.gov.pl/api/"
102 request.SetRequestHeader "Content-Type", "application/json; charset=UTF-8"
request.SetRequestHeader "Accept", "application/json; charset=UTF-8"
104 request.SetRequestHeader "Authorization", "Bearer " + key
106 request.Send "{}"
108 response = request.ResponseText
110 Debug.Print response
If request.Status = 200 Then
Else
End If
120 Text3.Text = response
Exit Sub
Command2_Click_Err:
End Sub
Function GetHeader(headers As String, headerName As String) As String
Dim arr() As String
arr = Split(headers, vbCrLf)
For Each h In arr
If InStr(1, h, headerName & ":", vbTextCompare) = 1 Then
GetHeader = Trim(Mid(h, Len(headerName) + 2))
Exit Function
End If
Next h
GetHeader = ""
End Function
Private Sub Command3_Click()
'TOKEN
key = "31E31B790DC4F4602E04D71DB73AF0E06987AE4528DBE094171DF0879AF84***"
Dim klpubl As String
klpubl = "23406442688142992831583759844756089133712844262268877557835948537922690131301917528010472072980030525243164470704153404706424073919594735631248793604990149775500839426627798421278024993358446037655350061463757500035940998380555904273595946307684093782369149356087903235522664351435055995896215926900834823274455240788124709945700300545915276090426078078411011846599277153583946003396302217817245249811336711552038275781604699852026576581228046084296276086185170885235268125033156936166764556520982537544722946490123310277292524709687907821731708318317794956326577863648319840338909808057410474707559952504063561704659"
If Text8.Text <> "nip" Then _
Text4.Text = Replace$(Text4.Text, "1111111111", Text8.Text)
Command4.Enabled = True
'po wstepnej autoryzacji nip
'przycisk logowania tokenem = enabled
Dim url As String
url = Trim(Text2.Text) ' "https://ksef-test.mf.gov.pl/api/online/Session/AuthorisationChallenge" ' "https://ksef-test.mf.gov.pl/web/login/"
DoEvents
On Error Resume Next
Dim request As New WinHttpRequest
120 request.Option(4) = 13056
122 request.SetTimeouts 500000, 500000, 500000, 500000
DoEvents
Dim jsonData As String
jsonData = Trim$(Text4.Text)
DoEvents
request.Open Trim$(Text1.Text), url, False
DoEvents
request.SetRequestHeader "Content-Type", "application/json; charset=UTF-8"
request.SetRequestHeader "Accept", "application/json; charset=UTF-8"
DoEvents
request.Send jsonData '
DoEvents
Text3.Text = request.ResponseText
DoEvents
Dim reslt() As String
Dim reslt2() As String
reslt = Split(Text3.Text, ",")
reslt2 = Split(reslt(1), ":")
Text6.Text = Replace(Replace(reslt2(1), Chr(34), ""), "}", "")
Text4.Text = Text7.Text
'uzupelnia nip i challenge
If Text8.Text <> "nip" Then _
Text4.Text = Replace$(Text4.Text, "1111111111", Text8.Text)
Text4.Text = Replace$(Text4.Text, "20211001-CR-FFFFFFFFFF-FFFFFFFFFF-FF", Text6.Text)
End Sub
Private Sub Command4_Click()
'TOKEN tworzony na stronie ksef test
key = "31E31B790DC4F4602E04D71DB73AF0E06987AE4528DBE094171DF0879AF841CB"
Dim klpubl As String
klpubl = "23406442688142992831583759844756089133712844262268877557835948537922690131301917528010472072980030525243164470704153404706424073919594735631248793604990149775500839426627798421278024993358446037655350061463757500035940998380555904273595946307684093782369149356087903235522664351435055995896215926900834823274455240788124709945700300545915276090426078078411011846599277153583946003396302217817245249811336711552038275781604699852026576581228046084296276086185170885235268125033156936166764556520982537544722946490123310277292524709687907821731708318317794956326577863648319840338909808057410474707559952504063561704659"
Dim url As String
url = Trim(Text5.Text)
DoEvents
On Error Resume Next
Dim request As New WinHttpRequest
120 request.Option(4) = 13056
122 request.SetTimeouts 500000, 500000, 500000, 500000
DoEvents
Dim Code As String
Code = klpubl + ":" + key + "|" + Trim$(Text6.Text)
Dim BasicAuthentication As String
BasicAuthentication = Base64EncodeString(Code)
Dim jsonData As String
jsonData = Trim$(Text4.Text)
jsonData = Replace$(jsonData, ">%%%%%<", ">" + BasicAuthentication + "<")
Text4.Text = jsonData
DoEvents
request.Open Trim$(Text1.Text), url, False
DoEvents
request.SetRequestHeader "Content-Type", "application/octet-stream"
request.SetRequestHeader "Accept", "application/json"
DoEvents
request.Send jsonData '
DoEvents
Text3.Text = request.ResponseText
DoEvents
End Sub
Private Sub Form_Load()
100 key = ""
102 Text1.Text = "POST"
104 Text2.Text = "https://ksef-test.mf.gov.pl/api/online/Session/AuthorisationChallenge"
Exit Sub
End Sub
pozostala czesc kodu:
' A Base64 Encoder/Decoder.
'
' This module is used to encode and decode data in Base64 format as described in RFC 1521.
'
' Home page: www.source-code.biz.
' Copyright 2007: Christian d'Heureuse, Inventec Informatik AG, Switzerland.
'
' This module is multi-licensed and may be used under the terms
' of any of the following licenses:
'
' EPL, Eclipse Public License, V1.0 or later, http://www.eclipse.org/legal
' LGPL, GNU Lesser General Public License, V2.1 or later, http://www.gnu.org/licenses/lgpl.html
' GPL, GNU General Public License, V2 or later, http://www.gnu.org/licenses/gpl.html
' AGPL, GNU Affero General Public License V3 or later, http://www.gnu.org/licenses/agpl.html
' AL, Apache License, V2.0 or later, http://www.apache.org/licenses
' BSD, BSD License, http://www.opensource.org/licenses/bsd-license.php
' MIT, MIT License, http://www.opensource.org/licenses/MIT
'
' Please contact the author if you need another license.
' This module is provided "as is", without warranties of any kind.
Option Explicit
Private InitDone As Boolean
Private Map1(0 To 63) As Byte
Private Map2(0 To 127) As Byte
' Encodes a string into Base64 format.
' No blanks or line breaks are inserted.
' Parameters:
' S a String to be encoded.
' Returns: a String with the Base64 encoded data.
Public Function Base64EncodeString(ByVal s As String) As String
Base64EncodeString = Base64Encode(ConvertStringToBytes(s))
End Function
' Encodes a byte array into Base64 format.
' No blanks or line breaks are inserted.
' Parameters:
' InData an array containing the data bytes to be encoded.
' Returns: a string with the Base64 encoded data.
Public Function Base64Encode(InData() As Byte)
Base64Encode = Base64Encode2(InData, UBound(InData) - LBound(InData) + 1)
End Function
' Encodes a byte array into Base64 format.
' No blanks or line breaks are inserted.
' Parameters:
' InData an array containing the data bytes to be encoded.
' InLen number of bytes to process in InData.
' Returns: a string with the Base64 encoded data.
Public Function Base64Encode2(InData() As Byte, ByVal InLen As Long) As String
If Not InitDone Then Init
If InLen = 0 Then Base64Encode2 = "": Exit Function
Dim ODataLen As Long: ODataLen = (InLen * 4 + 2) \ 3 ' output length without padding
Dim OLen As Long: OLen = ((InLen + 2) \ 3) * 4 ' output length including padding
Dim Out() As Byte
ReDim Out(0 To OLen - 1) As Byte
Dim ip0 As Long: ip0 = LBound(InData)
Dim ip As Long
Dim op As Long
Do While ip < InLen
Dim i0 As Byte: i0 = InData(ip0 + ip): ip = ip + 1
Dim i1 As Byte: If ip < InLen Then i1 = InData(ip0 + ip): ip = ip + 1 Else i1 = 0
Dim i2 As Byte: If ip < InLen Then i2 = InData(ip0 + ip): ip = ip + 1 Else i2 = 0
Dim o0 As Byte: o0 = i0 \ 4
Dim o1 As Byte: o1 = ((i0 And 3) * &H10) Or (i1 \ &H10)
Dim o2 As Byte: o2 = ((i1 And &HF) * 4) Or (i2 \ &H40)
Dim o3 As Byte: o3 = i2 And &H3F
Out(op) = Map1(o0): op = op + 1
Out(op) = Map1(o1): op = op + 1
Out(op) = IIf(op < ODataLen, Map1(o2), Asc("=")): op = op + 1
Out(op) = IIf(op < ODataLen, Map1(o3), Asc("=")): op = op + 1
Loop
Base64Encode2 = ConvertBytesToString(Out)
End Function
' Decodes a string from Base64 format.
' Parameters:
' s a Base64 String to be decoded.
' Returns a String containing the decoded data.
Public Function Base64DecodeString(ByVal s As String) As String
If s = "" Then Base64DecodeString = "": Exit Function
Base64DecodeString = ConvertBytesToString(Base64Decode(s))
End Function
' Decodes a byte array from Base64 format.
' Parameters
' s a Base64 String to be decoded.
' Returns: an array containing the decoded data bytes.
Public Function Base64Decode(ByVal s As String) As Byte()
If Not InitDone Then Init
Dim IBuf() As Byte: IBuf = ConvertStringToBytes(s)
Dim iLen As Long: iLen = UBound(IBuf) + 1
If iLen Mod 4 <> 0 Then Err.Raise vbObjectError, , "Length of Base64 encoded input string is not a multiple of 4."
Do While iLen > 0
If IBuf(iLen - 1) <> Asc("=") Then Exit Do
iLen = iLen - 1
Loop
Dim OLen As Long: OLen = (iLen * 3) \ 4
Dim Out() As Byte
ReDim Out(0 To OLen - 1) As Byte
Dim ip As Long
Dim op As Long
Do While ip < iLen
Dim i0 As Byte: i0 = IBuf(ip): ip = ip + 1
Dim i1 As Byte: i1 = IBuf(ip): ip = ip + 1
Dim i2 As Byte: If ip < iLen Then i2 = IBuf(ip): ip = ip + 1 Else i2 = Asc("A")
Dim i3 As Byte: If ip < iLen Then i3 = IBuf(ip): ip = ip + 1 Else i3 = Asc("A")
If i0 > 127 Or i1 > 127 Or i2 > 127 Or i3 > 127 Then _
Err.Raise vbObjectError, , "Illegal character in Base64 encoded data."
Dim b0 As Byte: b0 = Map2(i0)
Dim b1 As Byte: b1 = Map2(i1)
Dim b2 As Byte: b2 = Map2(i2)
Dim b3 As Byte: b3 = Map2(i3)
If b0 > 63 Or b1 > 63 Or b2 > 63 Or b3 > 63 Then _
Err.Raise vbObjectError, , "Illegal character in Base64 encoded data."
Dim o0 As Byte: o0 = (b0 * 4) Or (b1 \ &H10)
Dim o1 As Byte: o1 = ((b1 And &HF) * &H10) Or (b2 \ 4)
Dim o2 As Byte: o2 = ((b2 And 3) * &H40) Or b3
Out(op) = o0: op = op + 1
If op < OLen Then Out(op) = o1: op = op + 1
If op < OLen Then Out(op) = o2: op = op + 1
Loop
Base64Decode = Out
End Function
Private Sub Init()
Dim c As Integer, i As Integer
' set Map1
i = 0
For c = Asc("A") To Asc("Z"): Map1(i) = c: i = i + 1: Next
For c = Asc("a") To Asc("z"): Map1(i) = c: i = i + 1: Next
For c = Asc("0") To Asc("9"): Map1(i) = c: i = i + 1: Next
Map1(i) = Asc("+"): i = i + 1
Map1(i) = Asc("/"): i = i + 1
' set Map2
For i = 0 To 127: Map2(i) = 255: Next
For i = 0 To 63: Map2(Map1(i)) = i: Next
InitDone = True
End Sub
Private Function ConvertStringToBytes(ByVal s As String) As Byte()
Dim b1() As Byte: b1 = s
Dim l As Long: l = (UBound(b1) + 1) \ 2
If l = 0 Then ConvertStringToBytes = b1: Exit Function
Dim b2() As Byte
ReDim b2(0 To l - 1) As Byte
Dim p As Long
For p = 0 To l - 1
Dim c As Long: c = b1(2 * p) + 256 * CLng(b1(2 * p + 1))
If c >= 256 Then c = Asc("?")
b2(p) = c
Next
ConvertStringToBytes = b2
End Function
Private Function ConvertBytesToString(b() As Byte) As String
Dim l As Long: l = UBound(b) - LBound(b) + 1
Dim b2() As Byte
ReDim b2(0 To (2 * l) - 1) As Byte
Dim p0 As Long: p0 = LBound(b)
Dim p As Long
For p = 0 To l - 1: b2(2 * p) = b(p0 + p): Next
Dim s As String: s = b2
ConvertBytesToString = s
End Function
faktury xml mam juz przygotowane zgodnie ze specyfikacją fa1
dolaczam projekt testowy
https://app.box.com/s/cu52k726mrtwbt7s3hkcc5ndkxk3muht