API tools faq
paste
Advertisement
Guest User

Untitled

a guest
Mar 16th, 2024
19
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
VB.NET 8.88 KB | None | 0 0
raw download clone embed print report
  1. Option Explicit
  2. #If VBA7 Then
  3.   Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" ( _
  4.           ByVal CodePage As Long, _
  5.           ByVal dwFlags As Long, _
  6.           ByVal lpWideCharStr As LongPtr, _
  7.           ByVal cchWideChar As Long, _
  8.           ByVal lpMultiByteStr As String, _
  9.           ByVal cchMultiByte As Long, _
  10.           ByVal lpDefaultChar As LongPtr, _
  11.           ByVal lpUsedDefaultChar As LongPtr) As Long
  12.   Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" ( _
  13.           ByVal CodePage As Long, _
  14.           ByVal dwFlags As Long, _
  15.           ByVal lpMultiByteStr As String, _
  16.           ByVal cchMultiByte As Long, _
  17.           ByVal lpWideCharStr As LongPtr, _
  18.           ByVal cchWideChar As Long) As Long
  19.   Private Declare PtrSafe Function GetACP Lib "kernel32" () As Long
  20. #Else
  21.   Private Declare Function WideCharToMultiByte Lib "kernel32.dll" ( _
  22.           ByVal CodePage As Long, _
  23.           ByVal dwFlags As Long, _
  24.           ByVal lpWideCharStr As Long, _
  25.           ByVal cchWideChar As Long, _
  26.           ByVal lpMultiByteStr As String, _
  27.           ByVal cchMultiByte As Long, _
  28.           ByVal lpDefaultChar As Long, _
  29.           ByVal lpUsedDefaultChar As Long) As Long
  30.   Private Declare Function MultiByteToWideChar Lib "kernel32.dll" ( _
  31.           ByVal CodePage As Long, _
  32.           ByVal dwFlags As Long, _
  33.           ByVal lpMultiByteStr As String, _
  34.           ByVal cchMultiByte As Long, _
  35.           ByVal lpWideCharStr As Long, _
  36.           ByVal cchWideChar As Long) As Long
  37.   Private Declare Function GetACP Lib "kernel32" () As Long
  38. #End If
  39.  
  40.  
  41. Sub test()
  42. '
  43. ' test Makro
  44. '
  45. ' Klawisz skrótu: Ctrl+d
  46. '
  47. Dim api As String
  48. Dim id As String ' ID sesji
  49. Dim klucz As String 'klucz
  50. Dim odp As String
  51. Dim NIP As String
  52.  
  53.  
  54. api = ActiveSheet.Range("B1").Value
  55. klucz = ActiveSheet.Range("B2").Value
  56. NIP = ActiveSheet.Range("B3").Value
  57.  
  58. NIP = Replace(NIP, "-", "")
  59. 'If Len(NIP) <> 10 Then
  60. '    MsgBox ("Brak właściwego numeru NIP!")
  61. '    End
  62. 'End If
  63.  
  64. ' zalogowanie
  65. With CreateObject("winhttp.winhttprequest.5.1")
  66.         .Open "POST", api, False
  67.         .setRequestHeader "Content-Type", "application/soap+xml;charset=UTF-8;"
  68.         .send "" & _
  69.                 "<soap:Envelope xmlns:soap=""http://www.w3.org/2003/05/soap-envelope"" xmlns:ns=""http://CIS/BIR/PUBL/2014/07"">" & _
  70.                 "<soap:Header xmlns:wsa=""http://www.w3.org/2005/08/addressing"">" & _
  71.                 "<wsa:Action>http://CIS/BIR/PUBL/2014/07/IUslugaBIRzewnPubl/Zaloguj</wsa:Action>" & _
  72.                 "<wsa:To>" + api + "</wsa:To>" & _
  73.                 "</soap:Header>" & _
  74.                 "<soap:Body>" & _
  75.                 "<ns:Zaloguj>" & _
  76.                 "<ns:pKluczUzytkownika>" + klucz + "</ns:pKluczUzytkownika>" & _
  77.                 "</ns:Zaloguj>" & _
  78.                 "</soap:Body>" & _
  79.                 "</soap:Envelope>"
  80.                
  81. odp = .responseText
  82.  If Len(odp) = 0 Then
  83.     MsgBox ("Nie można uzyskać sesji z usługi sieciowej GUSu!")
  84.     End
  85.  End If
  86. id = Split(odp, "ZalogujResult>")(1)
  87. id = Left(id, Len(id) - 2)
  88. End With
  89.  
  90. ' pobierz po nipie
  91. With CreateObject("winhttp.winhttprequest.5.1")
  92.         .Open "POST", api, False
  93.         .setRequestHeader "Content-Type", "application/soap+xml; charset=UTF-8;"
  94.         .setRequestHeader "sid", id
  95.         .send "" & _
  96.                 "<soap:Envelope xmlns:soap=""http://www.w3.org/2003/05/soap-envelope"" xmlns:ns=""http://CIS/BIR/PUBL/2014/07"" xmlns:dat=""http://CIS/BIR/PUBL/2014/07/DataContract"">" & _
  97.                     "<soap:Header xmlns:wsa=""http://www.w3.org/2005/08/addressing"">" & _
  98.                         "<wsa:To>" + api + "</wsa:To>" & _
  99.                         "<wsa:Action>http://CIS/BIR/PUBL/2014/07/IUslugaBIRzewnPubl/DaneSzukajPodmioty</wsa:Action>" & _
  100.                     "</soap:Header>" & _
  101.                 "<soap:Body>" & _
  102.                     "<ns:DaneSzukajPodmioty>" & _
  103.                         "<ns:pParametryWyszukiwania>" & _
  104.                             "<dat:Regon>" + NIP + "</dat:Regon>" & _
  105.                         "</ns:pParametryWyszukiwania>" & _
  106.                     "</ns:DaneSzukajPodmioty>" & _
  107.                 "</soap:Body>" & _
  108.                 "</soap:Envelope>"
  109.  
  110. odp = VBA.Strings.StrConv(.responseBody, vbUnicode)
  111. odp = tekstCodePageToCodePage(odp, 65001, 1250) ' zmiana strony kodowej
  112. odp = Replace(odp, "&lt;", "<")
  113. odp = Replace(odp, "&gt;", ">")
  114. Dim a As String
  115. Debug.Print odp
  116. ' szukanie błędów
  117. If (InStr(odp, "ErrorCode")) Then
  118.     a = Split(odp, "ErrorCode>")(1)
  119.     a = Left(a, Len(a) - 2)
  120.     If (a) Then
  121.         Dim errorPl As String
  122.         Dim errorEN As String
  123.         Dim errorNIP As String
  124.         errorPl = Split(odp, "ErrorMessagePl>")(1)
  125.         errorPl = Left(errorPl, Len(errorPl) - 2)
  126.         errorEN = Split(odp, "ErrorMessageEn>")(1)
  127.         errorEN = Left(errorEN, Len(errorEN) - 2)
  128.         errorNIP = Split(odp, "Nip>")(1)
  129.         errorNIP = Left(errorNIP, Len(errorNIP) - 2)
  130.        
  131.         MsgBox (errorPl + Chr(13) + errorEN + Chr(13) + "NIP: " + errorNIP)
  132.         End
  133.     End If
  134. End If
  135. Debug.Print odp
  136. a = Split(odp, "DaneSzukajPodmiotyResult>")(1)
  137. a = Left(a, Len(a) - 2)
  138.  
  139. Dim sXml As String
  140. Dim dom As MSXML2.DOMDocument60
  141. Set dom = New MSXML2.DOMDocument60
  142. dom.LoadXML a
  143. Debug.Assert dom.parseError = 0
  144. Dim xmlSomeCData As MSXML2.IXMLDOMElement
  145.  
  146. Set xmlSomeCData = dom.SelectSingleNode("root/dane/StatusNip")
  147. ActiveSheet.Range("B5").Value = xmlSomeCData.Text
  148. Set xmlSomeCData = dom.SelectSingleNode("root/dane/Regon")
  149. ActiveSheet.Range("B6").Value = xmlSomeCData.Text
  150. Set xmlSomeCData = dom.SelectSingleNode("root/dane/Nazwa")
  151. ActiveSheet.Range("B7").Value = xmlSomeCData.Text
  152. Set xmlSomeCData = dom.SelectSingleNode("root/dane/Wojewodztwo")
  153. ActiveSheet.Range("B8").Value = xmlSomeCData.Text
  154. Set xmlSomeCData = dom.SelectSingleNode("root/dane/Powiat")
  155. ActiveSheet.Range("B9").Value = xmlSomeCData.Text
  156. Set xmlSomeCData = dom.SelectSingleNode("root/dane/Gmina")
  157. ActiveSheet.Range("B10").Value = xmlSomeCData.Text
  158. Set xmlSomeCData = dom.SelectSingleNode("root/dane/Miejscowosc")
  159. ActiveSheet.Range("B11").Value = xmlSomeCData.Text
  160. Set xmlSomeCData = dom.SelectSingleNode("root/dane/KodPocztowy")
  161. ActiveSheet.Range("B12").Value = xmlSomeCData.Text
  162. Set xmlSomeCData = dom.SelectSingleNode("root/dane/Ulica")
  163. ActiveSheet.Range("B13").Value = xmlSomeCData.Text
  164. Set xmlSomeCData = dom.SelectSingleNode("root/dane/NrNieruchomosci")
  165. ActiveSheet.Range("B14").Value = xmlSomeCData.Text
  166. Set xmlSomeCData = dom.SelectSingleNode("root/dane/NrLokalu")
  167. ActiveSheet.Range("B15").Value = xmlSomeCData.Text
  168. Set xmlSomeCData = dom.SelectSingleNode("root/dane/DataZakonczeniaDzialalnosci")
  169. ActiveSheet.Range("B16").Value = xmlSomeCData.Text
  170. Set xmlSomeCData = dom.SelectSingleNode("root/dane/MiejscowoscPoczty")
  171. ActiveSheet.Range("B17").Value = xmlSomeCData.Text
  172. Set xmlSomeCData = dom.SelectSingleNode("root/dane/Nip")
  173. ActiveSheet.Range("B18").Value = xmlSomeCData.Text
  174. End With
  175. ' wyloguj
  176. With CreateObject("winhttp.winhttprequest.5.1")
  177.         .Open "POST", "https://wyszukiwarkaregon.stat.gov.pl/wsBIR/UslugaBIRzewnPubl.svc", False
  178.         .setRequestHeader "Content-Type", "application/soap+xml;charset=UTF-8;"
  179.         .send "" & _
  180.                 "<soap:Envelope xmlns:soap=""http://www.w3.org/2003/05/soap-envelope"" xmlns:ns=""http://CIS/BIR/PUBL/2014/07"">" & _
  181.                 "<soap:Header xmlns:wsa=""http://www.w3.org/2005/08/addressing"">" & _
  182.                 "<wsa:Action>http://CIS/BIR/PUBL/2014/07/IUslugaBIRzewnPubl/Wyloguj</wsa:Action>" & _
  183.                 "<wsa:To>https://wyszukiwarkaregon.stat.gov.pl/wsBIR/UslugaBIRzewnPubl.svc</wsa:To>" & _
  184.                 "</soap:Header>" & _
  185.                 "<soap:Body>" & _
  186.                 "<ns:Wyloguj>" & _
  187.                 "<ns:pIdentyfikatorSesji>" + id + "</ns:pIdentyfikatorSesji>" & _
  188.                 "</ns:Wyloguj>" & _
  189.                 "</soap:Body>" & _
  190.                 "</soap:Envelope>"
  191.                
  192. odp = .responseText
  193. End With
  194. End Sub
  195.  
  196.  
  197.  
  198. Public Function tekstCodePageToCodePage(sStrIn As String, lFromCP As Long, lOutCP As Long) As String
  199.  
  200. Dim lLenStrOut  As Long
  201. Dim sAscii      As String
  202. Dim lLenAscii   As Long
  203. Dim lCurrentCP   As Long
  204.  
  205.   lCurrentCP = GetACP
  206.  
  207.   If lFromCP = lCurrentCP Then
  208.     sAscii = sStrIn
  209.   Else
  210.     lLenAscii = MultiByteToWideChar(lFromCP, 0&, sStrIn, Len(sStrIn), 0&, 0&)
  211.     sAscii = String$(lLenAscii, vbNullChar)
  212.     lLenAscii = MultiByteToWideChar(lFromCP, 0&, sStrIn, Len(sStrIn), StrPtr(sAscii), lLenAscii)
  213.   End If
  214.  
  215.   If lOutCP = lCurrentCP Then
  216.     tekstCodePageToCodePage = sAscii
  217.   Else
  218.     lLenStrOut = WideCharToMultiByte(lOutCP, 0&, StrPtr(sAscii), Len(sAscii), 0&, 0&, 0&, 0&)
  219.     tekstCodePageToCodePage = String$(lLenStrOut, vbNullChar)
  220.     lLenStrOut = WideCharToMultiByte(lOutCP, 0&, StrPtr(sAscii), Len(sAscii), tekstCodePageToCodePage, lLenStrOut, 0&, 0&)
  221.   End If
  222.  
  223. End Function
  224.  
  225.  
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!