Repository: krijnsent/crypto_vba Branch: master Commit: e74ccd9b95ab Files: 34 Total size: 293.1 KB Directory structure: gitextract__zi_j_oj/ ├── .gitignore ├── ImmediateReporter.cls ├── JsonConverter.bas ├── LICENSE ├── ModExchBinance.bas ├── ModExchBitVavo.bas ├── ModExchBitfinex.bas ├── ModExchBitmex.bas ├── ModExchBitstamp.bas ├── ModExchBittrex.bas ├── ModExchBybit.bas ├── ModExchCoinbase.bas ├── ModExchCoinbasePro.bas ├── ModExchCoinone.bas ├── ModExchCoinspot.bas ├── ModExchHitBTC.bas ├── ModExchHuobi.bas ├── ModExchIDEX.bas ├── ModExchKraken.bas ├── ModExchKucoin.bas ├── ModExchOKEx.bas ├── ModExchPoloniex.bas ├── ModFunctions.bas ├── ModHash.bas ├── ModJSON.bas ├── ModSrcCoinGecko.bas ├── ModSrcCryptocompare.bas ├── ModWeb.bas ├── TestCase.cls ├── TestSuite.cls ├── WorkbookReporter.cls ├── _config.yml ├── crypto_vba_example.xlsm └── readme.md ================================================ FILE CONTENTS ================================================ ================================================ FILE: .gitignore ================================================ ~$crypto_vba_example.xlsm crypto_vba_example_dev.xlsm ================================================ FILE: ImmediateReporter.cls ================================================ VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "ImmediateReporter" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = True '' ' ImmediateReporter v2.0.0-beta.3 ' (c) Tim Hall - https://github.com/VBA-tools/VBA-TDD ' ' Report results to Immediate Window ' ' @class ImmediateReporter ' @author tim.hall.engr@gmail.com ' @license MIT (https://opensource.org/licenses/MIT) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Option Explicit ' --------------------------------------------- ' ' Constants and Private Variables ' --------------------------------------------- ' Private WithEvents pSuite As TestSuite Attribute pSuite.VB_VarHelpID = -1 Private Finished As Boolean ' ============================================= ' ' Public Methods ' ============================================= ' '' ' Listen to given TestSuite ' ' @method ListenTo ' @param {TestSuite} Suite '' Public Sub ListenTo(Suite As TestSuite) If Not pSuite Is Nothing Then Done End If Debug.Print "===" & IIf(Suite.Description <> "", " " & Suite.Description & " ===", "") Set pSuite = Suite Finished = False End Sub '' ' Finish report for SpecSuite ' ' @method Done '' Public Function Done() Finished = True Debug.Print "= " & Summary & " = " & Now & " =" & vbNewLine End Function ' ============================================= ' ' Private Functions ' ============================================= ' Private Function ResultTypeToString(ResultType As TestResultType) As String Select Case ResultType Case TestResultType.Pass ResultTypeToString = "+" Case TestResultType.Fail ResultTypeToString = "X" Case TestResultType.Pending ResultTypeToString = "." End Select End Function Private Function Summary() As String Dim total As Long Dim Passed As Long Dim Failed As Long Dim Pending As Long Dim Skipped As Long total = pSuite.Tests.Count Passed = pSuite.PassedTests.Count Failed = pSuite.FailedTests.Count Pending = pSuite.PendingTests.Count Skipped = pSuite.SkippedTests.Count Dim SummaryMessage As String If Failed > 0 Then SummaryMessage = "FAIL (" & Failed & " of " & total & " failed" Else SummaryMessage = "PASS (" & Passed & " of " & total & " passed" End If If Pending > 0 Then SummaryMessage = SummaryMessage & ", " & Pending & " pending" End If If Skipped > 0 Then SummaryMessage = SummaryMessage & ", " & Skipped & " skipped)" Else SummaryMessage = SummaryMessage & ")" End If Summary = SummaryMessage End Function Private Sub pSuite_Result(Test As TestCase) If Test.Result = TestResultType.Skipped Then Exit Sub End If Debug.Print ResultTypeToString(Test.Result) & " " & Test.Name If Test.Result = TestResultType.Fail Then Dim Failure As Variant For Each Failure In Test.Failures Debug.Print " " & Failure Next Failure End If End Sub Private Sub Class_Terminate() If Not Finished Then Done End If End Sub ================================================ FILE: JsonConverter.bas ================================================ Attribute VB_Name = "JsonConverter" 'Attribute VB_Name = "JsonConverter" '' ' VBA-JSON v2.3.1 ' (c) Tim Hall - https://github.com/VBA-tools/VBA-JSON ' ' JSON Converter for VBA ' ' Errors: ' 10001 - JSON parse error ' ' @class JsonConverter ' @author tim.hall.engr@gmail.com ' @license MIT (http://www.opensource.org/licenses/mit-license.php) '' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' ' ' Based originally on vba-json (with extensive changes) ' BSD license included below ' ' JSONLib, http://code.google.com/p/vba-json/ ' ' Copyright (c) 2013, Ryo Yokoyama ' All rights reserved. ' ' Redistribution and use in source and binary forms, with or without ' modification, are permitted provided that the following conditions are met: ' * Redistributions of source code must retain the above copyright ' notice, this list of conditions and the following disclaimer. ' * Redistributions in binary form must reproduce the above copyright ' notice, this list of conditions and the following disclaimer in the ' documentation and/or other materials provided with the distribution. ' * Neither the name of the nor the ' names of its contributors may be used to endorse or promote products ' derived from this software without specific prior written permission. ' ' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ' ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ' WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE ' DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY ' DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ' (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ' LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ' ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ' (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ' SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Option Explicit ' === VBA-UTC Headers #If Mac Then #If VBA7 Then ' 64-bit Mac (2016) Private Declare PtrSafe Function utc_popen Lib "/usr/lib/libc.dylib" Alias "popen" _ (ByVal utc_Command As String, ByVal utc_Mode As String) As LongPtr Private Declare PtrSafe Function utc_pclose Lib "/usr/lib/libc.dylib" Alias "pclose" _ (ByVal utc_File As LongPtr) As LongPtr Private Declare PtrSafe Function utc_fread Lib "/usr/lib/libc.dylib" Alias "fread" _ (ByVal utc_Buffer As String, ByVal utc_Size As LongPtr, ByVal utc_Number As LongPtr, ByVal utc_File As LongPtr) As LongPtr Private Declare PtrSafe Function utc_feof Lib "/usr/lib/libc.dylib" Alias "feof" _ (ByVal utc_File As LongPtr) As LongPtr #Else ' 32-bit Mac Private Declare Function utc_popen Lib "libc.dylib" Alias "popen" _ (ByVal utc_Command As String, ByVal utc_Mode As String) As Long Private Declare Function utc_pclose Lib "libc.dylib" Alias "pclose" _ (ByVal utc_File As Long) As Long Private Declare Function utc_fread Lib "libc.dylib" Alias "fread" _ (ByVal utc_Buffer As String, ByVal utc_Size As Long, ByVal utc_Number As Long, ByVal utc_File As Long) As Long Private Declare Function utc_feof Lib "libc.dylib" Alias "feof" _ (ByVal utc_File As Long) As Long #End If #ElseIf VBA7 Then ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724421.aspx ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724949.aspx ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms725485.aspx Private Declare PtrSafe Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long Private Declare PtrSafe Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long Private Declare PtrSafe Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long #Else Private Declare Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long Private Declare Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long Private Declare Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long #End If #If Mac Then #If VBA7 Then Private Type utc_ShellResult utc_Output As String utc_ExitCode As LongPtr End Type #Else Private Type utc_ShellResult utc_Output As String utc_ExitCode As Long End Type #End If #Else Private Type utc_SYSTEMTIME utc_wYear As Integer utc_wMonth As Integer utc_wDayOfWeek As Integer utc_wDay As Integer utc_wHour As Integer utc_wMinute As Integer utc_wSecond As Integer utc_wMilliseconds As Integer End Type Private Type utc_TIME_ZONE_INFORMATION utc_Bias As Long utc_StandardName(0 To 31) As Integer utc_StandardDate As utc_SYSTEMTIME utc_StandardBias As Long utc_DaylightName(0 To 31) As Integer utc_DaylightDate As utc_SYSTEMTIME utc_DaylightBias As Long End Type #End If ' === End VBA-UTC Private Type json_Options ' VBA only stores 15 significant digits, so any numbers larger than that are truncated ' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits ' See: http://support.microsoft.com/kb/269370 ' ' By default, VBA-JSON will use String for numbers longer than 15 characters that contain only digits ' to override set `JsonConverter.JsonOptions.UseDoubleForLargeNumbers = True` UseDoubleForLargeNumbers As Boolean ' The JSON standard requires object keys to be quoted (" or '), use this option to allow unquoted keys AllowUnquotedKeys As Boolean ' The solidus (/) is not required to be escaped, use this option to escape them as \/ in ConvertToJson EscapeSolidus As Boolean End Type Public JsonOptions As json_Options ' ============================================= ' ' Public Methods ' ============================================= ' '' ' Convert JSON string to object (Dictionary/Collection) ' ' @method ParseJson ' @param {String} json_String ' @return {Object} (Dictionary or Collection) ' @throws 10001 - JSON parse error '' Public Function ParseJson(ByVal JsonString As String) As Object Dim json_Index As Long json_Index = 1 ' Remove vbCr, vbLf, and vbTab from json_String JsonString = VBA.Replace(VBA.Replace(VBA.Replace(JsonString, VBA.vbCr, ""), VBA.vbLf, ""), VBA.vbTab, "") json_SkipSpaces JsonString, json_Index Select Case VBA.Mid$(JsonString, json_Index, 1) Case "{" Set ParseJson = json_ParseObject(JsonString, json_Index) Case "[" Set ParseJson = json_ParseArray(JsonString, json_Index) Case Else ' Error: Invalid JSON string Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(JsonString, json_Index, "Expecting '{' or '['") End Select End Function '' ' Convert object (Dictionary/Collection/Array) to JSON ' ' @method ConvertToJson ' @param {Variant} JsonValue (Dictionary, Collection, or Array) ' @param {Integer|String} Whitespace "Pretty" print json with given number of spaces per indentation (Integer) or given string ' @return {String} '' Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitespace As Variant, Optional ByVal json_CurrentIndentation As Long = 0) As String Dim json_Buffer As String Dim json_BufferPosition As Long Dim json_BufferLength As Long Dim json_Index As Long Dim json_LBound As Long Dim json_UBound As Long Dim json_IsFirstItem As Boolean Dim json_Index2D As Long Dim json_LBound2D As Long Dim json_UBound2D As Long Dim json_IsFirstItem2D As Boolean Dim json_Key As Variant Dim json_Value As Variant Dim json_DateStr As String Dim json_Converted As String Dim json_SkipItem As Boolean Dim json_PrettyPrint As Boolean Dim json_Indentation As String Dim json_InnerIndentation As String json_LBound = -1 json_UBound = -1 json_IsFirstItem = True json_LBound2D = -1 json_UBound2D = -1 json_IsFirstItem2D = True json_PrettyPrint = Not IsMissing(Whitespace) Select Case VBA.VarType(JsonValue) Case VBA.vbNull ConvertToJson = "null" Case VBA.vbDate ' Date json_DateStr = ConvertToIso(VBA.CDate(JsonValue)) ConvertToJson = """" & json_DateStr & """" Case VBA.vbString ' String (or large number encoded as string) If Not JsonOptions.UseDoubleForLargeNumbers And json_StringIsLargeNumber(JsonValue) Then ConvertToJson = JsonValue Else ConvertToJson = """" & json_Encode(JsonValue) & """" End If Case VBA.vbBoolean If JsonValue Then ConvertToJson = "true" Else ConvertToJson = "false" End If Case VBA.vbArray To VBA.vbArray + VBA.vbByte If json_PrettyPrint Then If VBA.VarType(Whitespace) = VBA.vbString Then json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) json_InnerIndentation = VBA.String$(json_CurrentIndentation + 2, Whitespace) Else json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) json_InnerIndentation = VBA.Space$((json_CurrentIndentation + 2) * Whitespace) End If End If ' Array json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength On Error Resume Next json_LBound = LBound(JsonValue, 1) json_UBound = UBound(JsonValue, 1) json_LBound2D = LBound(JsonValue, 2) json_UBound2D = UBound(JsonValue, 2) If json_LBound >= 0 And json_UBound >= 0 Then For json_Index = json_LBound To json_UBound If json_IsFirstItem Then json_IsFirstItem = False Else ' Append comma to previous line json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength End If If json_LBound2D >= 0 And json_UBound2D >= 0 Then ' 2D Array If json_PrettyPrint Then json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength End If json_BufferAppend json_Buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength For json_Index2D = json_LBound2D To json_UBound2D If json_IsFirstItem2D Then json_IsFirstItem2D = False Else json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength End If json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2) ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null If json_Converted = "" Then ' (nest to only check if converted = "") If json_IsUndefined(JsonValue(json_Index, json_Index2D)) Then json_Converted = "null" End If End If If json_PrettyPrint Then json_Converted = vbNewLine & json_InnerIndentation & json_Converted End If json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength Next json_Index2D If json_PrettyPrint Then json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength End If json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength json_IsFirstItem2D = True Else ' 1D Array json_Converted = ConvertToJson(JsonValue(json_Index), Whitespace, json_CurrentIndentation + 1) ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null If json_Converted = "" Then ' (nest to only check if converted = "") If json_IsUndefined(JsonValue(json_Index)) Then json_Converted = "null" End If End If If json_PrettyPrint Then json_Converted = vbNewLine & json_Indentation & json_Converted End If json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength End If Next json_Index End If On Error GoTo 0 If json_PrettyPrint Then json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength If VBA.VarType(Whitespace) = VBA.vbString Then json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) Else json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) End If End If json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) ' Dictionary or Collection Case VBA.vbObject If json_PrettyPrint Then If VBA.VarType(Whitespace) = VBA.vbString Then json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) Else json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) End If End If ' Dictionary If VBA.TypeName(JsonValue) = "Dictionary" Then json_BufferAppend json_Buffer, "{", json_BufferPosition, json_BufferLength For Each json_Key In JsonValue.Keys ' For Objects, undefined (Empty/Nothing) is not added to object json_Converted = ConvertToJson(JsonValue(json_Key), Whitespace, json_CurrentIndentation + 1) If json_Converted = "" Then json_SkipItem = json_IsUndefined(JsonValue(json_Key)) Else json_SkipItem = False End If If Not json_SkipItem Then If json_IsFirstItem Then json_IsFirstItem = False Else json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength End If If json_PrettyPrint Then json_Converted = vbNewLine & json_Indentation & """" & json_Key & """: " & json_Converted Else json_Converted = """" & json_Key & """:" & json_Converted End If json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength End If Next json_Key If json_PrettyPrint Then json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength If VBA.VarType(Whitespace) = VBA.vbString Then json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) Else json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) End If End If json_BufferAppend json_Buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength ' Collection ElseIf VBA.TypeName(JsonValue) = "Collection" Then json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength For Each json_Value In JsonValue If json_IsFirstItem Then json_IsFirstItem = False Else json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength End If json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1) ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null If json_Converted = "" Then ' (nest to only check if converted = "") If json_IsUndefined(json_Value) Then json_Converted = "null" End If End If If json_PrettyPrint Then json_Converted = vbNewLine & json_Indentation & json_Converted End If json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength Next json_Value If json_PrettyPrint Then json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength If VBA.VarType(Whitespace) = VBA.vbString Then json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) Else json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) End If End If json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength End If ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal ' Number (use decimals for numbers) ConvertToJson = VBA.Replace(JsonValue, ",", ".") Case Else ' vbEmpty, vbError, vbDataObject, vbByte, vbUserDefinedType ' Use VBA's built-in to-string On Error Resume Next ConvertToJson = JsonValue On Error GoTo 0 End Select End Function ' ============================================= ' ' Private Functions ' ============================================= ' Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Dictionary Dim json_Key As String Dim json_NextChar As String Set json_ParseObject = New Dictionary json_SkipSpaces json_String, json_Index If VBA.Mid$(json_String, json_Index, 1) <> "{" Then Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '{'") Else json_Index = json_Index + 1 Do json_SkipSpaces json_String, json_Index If VBA.Mid$(json_String, json_Index, 1) = "}" Then json_Index = json_Index + 1 Exit Function ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then json_Index = json_Index + 1 json_SkipSpaces json_String, json_Index End If json_Key = json_ParseKey(json_String, json_Index) json_NextChar = json_Peek(json_String, json_Index) If json_NextChar = "[" Or json_NextChar = "{" Then Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) Else json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) End If Loop End If End Function Private Function json_ParseArray(json_String As String, ByRef json_Index As Long) As Collection Set json_ParseArray = New Collection json_SkipSpaces json_String, json_Index If VBA.Mid$(json_String, json_Index, 1) <> "[" Then Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '['") Else json_Index = json_Index + 1 Do json_SkipSpaces json_String, json_Index If VBA.Mid$(json_String, json_Index, 1) = "]" Then json_Index = json_Index + 1 Exit Function ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then json_Index = json_Index + 1 json_SkipSpaces json_String, json_Index End If json_ParseArray.Add json_ParseValue(json_String, json_Index) Loop End If End Function Private Function json_ParseValue(json_String As String, ByRef json_Index As Long) As Variant json_SkipSpaces json_String, json_Index Select Case VBA.Mid$(json_String, json_Index, 1) Case "{" Set json_ParseValue = json_ParseObject(json_String, json_Index) Case "[" Set json_ParseValue = json_ParseArray(json_String, json_Index) Case """", "'" json_ParseValue = json_ParseString(json_String, json_Index) Case Else If VBA.Mid$(json_String, json_Index, 4) = "true" Then json_ParseValue = True json_Index = json_Index + 4 ElseIf VBA.Mid$(json_String, json_Index, 5) = "false" Then json_ParseValue = False json_Index = json_Index + 5 ElseIf VBA.Mid$(json_String, json_Index, 4) = "null" Then json_ParseValue = Null json_Index = json_Index + 4 ElseIf VBA.InStr("+-0123456789", VBA.Mid$(json_String, json_Index, 1)) Then json_ParseValue = json_ParseNumber(json_String, json_Index) Else Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['") End If End Select End Function Private Function json_ParseString(json_String As String, ByRef json_Index As Long) As String Dim json_Quote As String Dim json_Char As String Dim json_Code As String Dim json_Buffer As String Dim json_BufferPosition As Long Dim json_BufferLength As Long json_SkipSpaces json_String, json_Index ' Store opening quote to look for matching closing quote json_Quote = VBA.Mid$(json_String, json_Index, 1) json_Index = json_Index + 1 Do While json_Index > 0 And json_Index <= Len(json_String) json_Char = VBA.Mid$(json_String, json_Index, 1) Select Case json_Char Case "\" ' Escaped string, \\, or \/ json_Index = json_Index + 1 json_Char = VBA.Mid$(json_String, json_Index, 1) Select Case json_Char Case """", "\", "/", "'" json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength json_Index = json_Index + 1 Case "b" json_BufferAppend json_Buffer, vbBack, json_BufferPosition, json_BufferLength json_Index = json_Index + 1 Case "f" json_BufferAppend json_Buffer, vbFormFeed, json_BufferPosition, json_BufferLength json_Index = json_Index + 1 Case "n" json_BufferAppend json_Buffer, vbCrLf, json_BufferPosition, json_BufferLength json_Index = json_Index + 1 Case "r" json_BufferAppend json_Buffer, vbCr, json_BufferPosition, json_BufferLength json_Index = json_Index + 1 Case "t" json_BufferAppend json_Buffer, vbTab, json_BufferPosition, json_BufferLength json_Index = json_Index + 1 Case "u" ' Unicode character escape (e.g. \u00a9 = Copyright) json_Index = json_Index + 1 json_Code = VBA.Mid$(json_String, json_Index, 4) json_BufferAppend json_Buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength json_Index = json_Index + 4 End Select Case json_Quote json_ParseString = json_BufferToString(json_Buffer, json_BufferPosition) json_Index = json_Index + 1 Exit Function Case Else json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength json_Index = json_Index + 1 End Select Loop End Function Private Function json_ParseNumber(json_String As String, ByRef json_Index As Long) As Variant Dim json_Char As String Dim json_Value As String Dim json_IsLargeNumber As Boolean json_SkipSpaces json_String, json_Index Do While json_Index > 0 And json_Index <= Len(json_String) json_Char = VBA.Mid$(json_String, json_Index, 1) If VBA.InStr("+-0123456789.eE", json_Char) Then ' Unlikely to have massive number, so use simple append rather than buffer here json_Value = json_Value & json_Char json_Index = json_Index + 1 Else ' Excel only stores 15 significant digits, so any numbers larger than that are truncated ' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits ' See: http://support.microsoft.com/kb/269370 ' ' Fix: Parse -> String, Convert -> String longer than 15/16 characters containing only numbers and decimal points -> Number ' (decimal doesn't factor into significant digit count, so if present check for 15 digits + decimal = 16) json_IsLargeNumber = IIf(InStr(json_Value, "."), Len(json_Value) >= 17, Len(json_Value) >= 16) If Not JsonOptions.UseDoubleForLargeNumbers And json_IsLargeNumber Then json_ParseNumber = json_Value Else ' VBA.Val does not use regional settings, so guard for comma is not needed json_ParseNumber = VBA.Val(json_Value) End If Exit Function End If Loop End Function Private Function json_ParseKey(json_String As String, ByRef json_Index As Long) As String ' Parse key with single or double quotes If VBA.Mid$(json_String, json_Index, 1) = """" Or VBA.Mid$(json_String, json_Index, 1) = "'" Then json_ParseKey = json_ParseString(json_String, json_Index) ElseIf JsonOptions.AllowUnquotedKeys Then Dim json_Char As String Do While json_Index > 0 And json_Index <= Len(json_String) json_Char = VBA.Mid$(json_String, json_Index, 1) If (json_Char <> " ") And (json_Char <> ":") Then json_ParseKey = json_ParseKey & json_Char json_Index = json_Index + 1 Else Exit Do End If Loop Else Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '""' or '''") End If ' Check for colon and skip if present or throw if not present json_SkipSpaces json_String, json_Index If VBA.Mid$(json_String, json_Index, 1) <> ":" Then Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting ':'") Else json_Index = json_Index + 1 End If End Function Private Function json_IsUndefined(ByVal json_Value As Variant) As Boolean ' Empty / Nothing -> undefined Select Case VBA.VarType(json_Value) Case VBA.vbEmpty json_IsUndefined = True Case VBA.vbObject Select Case VBA.TypeName(json_Value) Case "Empty", "Nothing" json_IsUndefined = True End Select End Select End Function Private Function json_Encode(ByVal json_Text As Variant) As String ' Reference: http://www.ietf.org/rfc/rfc4627.txt ' Escape: ", \, /, backspace, form feed, line feed, carriage return, tab Dim json_Index As Long Dim json_Char As String Dim json_AscCode As Long Dim json_Buffer As String Dim json_BufferPosition As Long Dim json_BufferLength As Long For json_Index = 1 To VBA.Len(json_Text) json_Char = VBA.Mid$(json_Text, json_Index, 1) json_AscCode = VBA.AscW(json_Char) ' When AscW returns a negative number, it returns the twos complement form of that number. ' To convert the twos complement notation into normal binary notation, add 0xFFF to the return result. ' https://support.microsoft.com/en-us/kb/272138 If json_AscCode < 0 Then json_AscCode = json_AscCode + 65536 End If ' From spec, ", \, and control characters must be escaped (solidus is optional) Select Case json_AscCode Case 34 ' " -> 34 -> \" json_Char = "\""" Case 92 ' \ -> 92 -> \\ json_Char = "\\" Case 47 ' / -> 47 -> \/ (optional) If JsonOptions.EscapeSolidus Then json_Char = "\/" End If Case 8 ' backspace -> 8 -> \b json_Char = "\b" Case 12 ' form feed -> 12 -> \f json_Char = "\f" Case 10 ' line feed -> 10 -> \n json_Char = "\n" Case 13 ' carriage return -> 13 -> \r json_Char = "\r" Case 9 ' tab -> 9 -> \t json_Char = "\t" Case 0 To 31, 127 To 65535 ' Non-ascii characters -> convert to 4-digit hex json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4) End Select json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength Next json_Index json_Encode = json_BufferToString(json_Buffer, json_BufferPosition) End Function Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String ' "Peek" at the next number of characters without incrementing json_Index (ByVal instead of ByRef) json_SkipSpaces json_String, json_Index json_Peek = VBA.Mid$(json_String, json_Index, json_NumberOfCharacters) End Function Private Sub json_SkipSpaces(json_String As String, ByRef json_Index As Long) ' Increment index to skip over spaces Do While json_Index > 0 And json_Index <= VBA.Len(json_String) And VBA.Mid$(json_String, json_Index, 1) = " " json_Index = json_Index + 1 Loop End Sub Private Function json_StringIsLargeNumber(json_String As Variant) As Boolean ' Check if the given string is considered a "large number" ' (See json_ParseNumber) Dim json_Length As Long Dim json_CharIndex As Long json_Length = VBA.Len(json_String) ' Length with be at least 16 characters and assume will be less than 100 characters If json_Length >= 16 And json_Length <= 100 Then Dim json_CharCode As String json_StringIsLargeNumber = True For json_CharIndex = 1 To json_Length json_CharCode = VBA.Asc(VBA.Mid$(json_String, json_CharIndex, 1)) Select Case json_CharCode ' Look for .|0-9|E|e Case 46, 48 To 57, 69, 101 ' Continue through characters Case Else json_StringIsLargeNumber = False Exit Function End Select Next json_CharIndex End If End Function Private Function json_ParseErrorMessage(json_String As String, ByRef json_Index As Long, ErrorMessage As String) ' Provide detailed parse error message, including details of where and what occurred ' ' Example: ' Error parsing JSON: ' {"abcde":True} ' ^ ' Expecting 'STRING', 'NUMBER', null, true, false, '{', or '[' Dim json_StartIndex As Long Dim json_StopIndex As Long ' Include 10 characters before and after error (if possible) json_StartIndex = json_Index - 10 json_StopIndex = json_Index + 10 If json_StartIndex <= 0 Then json_StartIndex = 1 End If If json_StopIndex > VBA.Len(json_String) Then json_StopIndex = VBA.Len(json_String) End If json_ParseErrorMessage = "Error parsing JSON:" & VBA.vbNewLine & _ VBA.Mid$(json_String, json_StartIndex, json_StopIndex - json_StartIndex + 1) & VBA.vbNewLine & _ VBA.Space$(json_Index - json_StartIndex) & "^" & VBA.vbNewLine & _ ErrorMessage End Function Private Sub json_BufferAppend(ByRef json_Buffer As String, _ ByRef json_Append As Variant, _ ByRef json_BufferPosition As Long, _ ByRef json_BufferLength As Long) ' VBA can be slow to append strings due to allocating a new string for each append ' Instead of using the traditional append, allocate a large empty string and then copy string at append position ' ' Example: ' Buffer: "abc " ' Append: "def" ' Buffer Position: 3 ' Buffer Length: 5 ' ' Buffer position + Append length > Buffer length -> Append chunk of blank space to buffer ' Buffer: "abc " ' Buffer Length: 10 ' ' Put "def" into buffer at position 3 (0-based) ' Buffer: "abcdef " ' ' Approach based on cStringBuilder from vbAccelerator ' http://www.vbaccelerator.com/home/VB/Code/Techniques/RunTime_Debug_Tracing/VB6_Tracer_Utility_zip_cStringBuilder_cls.asp ' ' and clsStringAppend from Philip Swannell ' https://github.com/VBA-tools/VBA-JSON/pull/82 Dim json_AppendLength As Long Dim json_LengthPlusPosition As Long json_AppendLength = VBA.Len(json_Append) json_LengthPlusPosition = json_AppendLength + json_BufferPosition If json_LengthPlusPosition > json_BufferLength Then ' Appending would overflow buffer, add chunk ' (double buffer length or append length, whichever is bigger) Dim json_AddedLength As Long json_AddedLength = IIf(json_AppendLength > json_BufferLength, json_AppendLength, json_BufferLength) json_Buffer = json_Buffer & VBA.Space$(json_AddedLength) json_BufferLength = json_BufferLength + json_AddedLength End If ' Note: Namespacing with VBA.Mid$ doesn't work properly here, throwing compile error: ' Function call on left-hand side of assignment must return Variant or Object Mid$(json_Buffer, json_BufferPosition + 1, json_AppendLength) = CStr(json_Append) json_BufferPosition = json_BufferPosition + json_AppendLength End Sub Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_BufferPosition As Long) As String If json_BufferPosition > 0 Then json_BufferToString = VBA.Left$(json_Buffer, json_BufferPosition) End If End Function '' ' VBA-UTC v1.0.6 ' (c) Tim Hall - https://github.com/VBA-tools/VBA-UtcConverter ' ' UTC/ISO 8601 Converter for VBA ' ' Errors: ' 10011 - UTC parsing error ' 10012 - UTC conversion error ' 10013 - ISO 8601 parsing error ' 10014 - ISO 8601 conversion error ' ' @module UtcConverter ' @author tim.hall.engr@gmail.com ' @license MIT (http://www.opensource.org/licenses/mit-license.php) '' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' ' (Declarations moved to top) ' ============================================= ' ' Public Methods ' ============================================= ' '' ' Parse UTC date to local date ' ' @method ParseUtc ' @param {Date} UtcDate ' @return {Date} Local date ' @throws 10011 - UTC parsing error '' Public Function ParseUtc(utc_UtcDate As Date) As Date On Error GoTo utc_ErrorHandling #If Mac Then ParseUtc = utc_ConvertDate(utc_UtcDate) #Else Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION Dim utc_LocalDate As utc_SYSTEMTIME utc_GetTimeZoneInformation utc_TimeZoneInfo utc_SystemTimeToTzSpecificLocalTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_UtcDate), utc_LocalDate ParseUtc = utc_SystemTimeToDate(utc_LocalDate) #End If Exit Function utc_ErrorHandling: Err.Raise 10011, "UtcConverter.ParseUtc", "UTC parsing error: " & Err.Number & " - " & Err.Description End Function '' ' Convert local date to UTC date ' ' @method ConvertToUrc ' @param {Date} utc_LocalDate ' @return {Date} UTC date ' @throws 10012 - UTC conversion error '' Public Function ConvertToUtc(utc_LocalDate As Date) As Date On Error GoTo utc_ErrorHandling #If Mac Then ConvertToUtc = utc_ConvertDate(utc_LocalDate, utc_ConvertToUtc:=True) #Else Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION Dim utc_UtcDate As utc_SYSTEMTIME utc_GetTimeZoneInformation utc_TimeZoneInfo utc_TzSpecificLocalTimeToSystemTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_LocalDate), utc_UtcDate ConvertToUtc = utc_SystemTimeToDate(utc_UtcDate) #End If Exit Function utc_ErrorHandling: Err.Raise 10012, "UtcConverter.ConvertToUtc", "UTC conversion error: " & Err.Number & " - " & Err.Description End Function '' ' Parse ISO 8601 date string to local date ' ' @method ParseIso ' @param {Date} utc_IsoString ' @return {Date} Local date ' @throws 10013 - ISO 8601 parsing error '' Public Function ParseIso(utc_IsoString As String) As Date On Error GoTo utc_ErrorHandling Dim utc_Parts() As String Dim utc_DateParts() As String Dim utc_TimeParts() As String Dim utc_OffsetIndex As Long Dim utc_HasOffset As Boolean Dim utc_NegativeOffset As Boolean Dim utc_OffsetParts() As String Dim utc_Offset As Date utc_Parts = VBA.Split(utc_IsoString, "T") utc_DateParts = VBA.Split(utc_Parts(0), "-") ParseIso = VBA.DateSerial(VBA.CInt(utc_DateParts(0)), VBA.CInt(utc_DateParts(1)), VBA.CInt(utc_DateParts(2))) If UBound(utc_Parts) > 0 Then If VBA.InStr(utc_Parts(1), "Z") Then utc_TimeParts = VBA.Split(VBA.Replace(utc_Parts(1), "Z", ""), ":") Else utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "+") If utc_OffsetIndex = 0 Then utc_NegativeOffset = True utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "-") End If If utc_OffsetIndex > 0 Then utc_HasOffset = True utc_TimeParts = VBA.Split(VBA.Left$(utc_Parts(1), utc_OffsetIndex - 1), ":") utc_OffsetParts = VBA.Split(VBA.Right$(utc_Parts(1), Len(utc_Parts(1)) - utc_OffsetIndex), ":") Select Case UBound(utc_OffsetParts) Case 0 utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), 0, 0) Case 1 utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), 0) Case 2 ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), Int(VBA.Val(utc_OffsetParts(2)))) End Select If utc_NegativeOffset Then: utc_Offset = -utc_Offset Else utc_TimeParts = VBA.Split(utc_Parts(1), ":") End If End If Select Case UBound(utc_TimeParts) Case 0 ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), 0, 0) Case 1 ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), 0) Case 2 ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), Int(VBA.Val(utc_TimeParts(2)))) End Select ParseIso = ParseUtc(ParseIso) If utc_HasOffset Then ParseIso = ParseIso - utc_Offset End If End If Exit Function utc_ErrorHandling: Err.Raise 10013, "UtcConverter.ParseIso", "ISO 8601 parsing error for " & utc_IsoString & ": " & Err.Number & " - " & Err.Description End Function '' ' Convert local date to ISO 8601 string ' ' @method ConvertToIso ' @param {Date} utc_LocalDate ' @return {Date} ISO 8601 string ' @throws 10014 - ISO 8601 conversion error '' Public Function ConvertToIso(utc_LocalDate As Date) As String On Error GoTo utc_ErrorHandling ConvertToIso = VBA.Format$(ConvertToUtc(utc_LocalDate), "yyyy-mm-ddTHH:mm:ss.000Z") Exit Function utc_ErrorHandling: Err.Raise 10014, "UtcConverter.ConvertToIso", "ISO 8601 conversion error: " & Err.Number & " - " & Err.Description End Function ' ============================================= ' ' Private Functions ' ============================================= ' #If Mac Then Private Function utc_ConvertDate(utc_Value As Date, Optional utc_ConvertToUtc As Boolean = False) As Date Dim utc_ShellCommand As String Dim utc_Result As utc_ShellResult Dim utc_Parts() As String Dim utc_DateParts() As String Dim utc_TimeParts() As String If utc_ConvertToUtc Then utc_ShellCommand = "date -ur `date -jf '%Y-%m-%d %H:%M:%S' " & _ "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & "' " & _ " +'%s'` +'%Y-%m-%d %H:%M:%S'" Else utc_ShellCommand = "date -jf '%Y-%m-%d %H:%M:%S %z' " & _ "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & " +0000' " & _ "+'%Y-%m-%d %H:%M:%S'" End If utc_Result = utc_ExecuteInShell(utc_ShellCommand) If utc_Result.utc_Output = "" Then Err.Raise 10015, "UtcConverter.utc_ConvertDate", "'date' command failed" Else utc_Parts = Split(utc_Result.utc_Output, " ") utc_DateParts = Split(utc_Parts(0), "-") utc_TimeParts = Split(utc_Parts(1), ":") utc_ConvertDate = DateSerial(utc_DateParts(0), utc_DateParts(1), utc_DateParts(2)) + _ TimeSerial(utc_TimeParts(0), utc_TimeParts(1), utc_TimeParts(2)) End If End Function Private Function utc_ExecuteInShell(utc_ShellCommand As String) As utc_ShellResult #If VBA7 Then Dim utc_File As LongPtr Dim utc_Read As LongPtr #Else Dim utc_File As Long Dim utc_Read As Long #End If Dim utc_Chunk As String On Error GoTo utc_ErrorHandling utc_File = utc_popen(utc_ShellCommand, "r") If utc_File = 0 Then: Exit Function Do While utc_feof(utc_File) = 0 utc_Chunk = VBA.Space$(50) utc_Read = CLng(utc_fread(utc_Chunk, 1, Len(utc_Chunk) - 1, utc_File)) If utc_Read > 0 Then utc_Chunk = VBA.Left$(utc_Chunk, CLng(utc_Read)) utc_ExecuteInShell.utc_Output = utc_ExecuteInShell.utc_Output & utc_Chunk End If Loop utc_ErrorHandling: utc_ExecuteInShell.utc_ExitCode = CLng(utc_pclose(utc_File)) End Function #Else Private Function utc_DateToSystemTime(utc_Value As Date) As utc_SYSTEMTIME utc_DateToSystemTime.utc_wYear = VBA.Year(utc_Value) utc_DateToSystemTime.utc_wMonth = VBA.Month(utc_Value) utc_DateToSystemTime.utc_wDay = VBA.Day(utc_Value) utc_DateToSystemTime.utc_wHour = VBA.Hour(utc_Value) utc_DateToSystemTime.utc_wMinute = VBA.Minute(utc_Value) utc_DateToSystemTime.utc_wSecond = VBA.Second(utc_Value) utc_DateToSystemTime.utc_wMilliseconds = 0 End Function Private Function utc_SystemTimeToDate(utc_Value As utc_SYSTEMTIME) As Date utc_SystemTimeToDate = DateSerial(utc_Value.utc_wYear, utc_Value.utc_wMonth, utc_Value.utc_wDay) + _ TimeSerial(utc_Value.utc_wHour, utc_Value.utc_wMinute, utc_Value.utc_wSecond) End Function #End If ================================================ FILE: LICENSE ================================================ MIT License Copyright (c) 2017 Koen Rijnsent Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ================================================ FILE: ModExchBinance.bas ================================================ Attribute VB_Name = "ModExchBinance" Sub TestBinance() 'Source: https://github.com/krijnsent/crypto_vba 'Documentation: https://github.com/binance/binance-spot-api-docs/blob/master/rest-api.md 'Remember to create a new API key for excel/VBA Dim Apikey As String Dim secretKey As String Apikey = "your api key here" secretKey = "your secret key here" 'Remove these 2 lines, unless you define 2 constants somewhere ( Public Const secretkey_btce = "the key to use everywhere" etc ) Apikey = apikey_binance2 secretKey = secretkey_binance2 'Put the credentials in a dictionary Dim Cred As New Dictionary Cred.Add "apiKey", Apikey Cred.Add "secretKey", secretKey ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModExchBinance" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestBinancePublic") 'Error, unknown command TestResult = PublicBinance("AnUnknownCommand", "GET") Test.IsOk InStr(TestResult, "error") > 0, "test UnknownCommand 1a failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 404, "test UnknownCommand 1b failed, result: ${1}" 'Error, command without parameters TestResult = PublicBinance("depth", "GET") Test.IsOk InStr(TestResult, "error") > 0, "test MissingParams 1a failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 400, "test MissingParams 1b failed, result: ${1}" 'OK request TestResult = PublicBinance("time", "GET") '{"serverTime":1513605418615} Test.IsOk InStr(TestResult, "serverTime") > 0, "test Time 1a failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("serverTime") > 1510000000000#, "test Time 1b failed, result: ${1}" 'Put parameters/options in a dictionary Dim Params As New Dictionary Params.Add "symbol", "ETHBTC" TestResult = PublicBinance("ticker/24hr", "GET", Params) '{"symbol":"ETHBTC","priceChange":"-0.00022700","priceChangePercent":"-0.633","weightedAvgPrice":"0.03538261","prevClosePrice":"0.03586800","lastPrice":"0.03564100","lastQty":"0.14000000","bidPrice":"0.03564100","bidQty":"0.22300000","askPrice":"0.03564800","askQty":"0.43200000","openPrice":"0.03586800","highPrice":"0.03600300","lowPrice":"0.03410000","volume":"380396.97600000","quoteVolume":"13459.43958266","openTime":1551288592637,"closeTime":1551374992637,"firstId":109505628,"lastId":109773015,"count":267388} Test.IsOk InStr(TestResult, "priceChange") > 0, "test Ticker 1a failed, result: ${1}" Test.IsOk InStr(TestResult, "closeTime") > 0, "test Ticker 1b failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("symbol"), "ETHBTC", "test Ticker 1c failed, result: ${1}" Test.IsOk JsonResult("lastPrice") > 0, "test Ticker 1d failed, result: ${1}" TestResult = GetBinanceTime() 'e.g. 1516565004894 Test.IsOk TestResult > 1510000000000#, "test GetTime failed, result: ${1}" 'Unix time period: t1 = DateToUnixTime("1/1/2014") t2 = DateToUnixTime("1/1/2018") Set Test = Suite.Test("TestBinancePrivate GET") 'Binance always requires a timestamp parameter, first test without TestResult = PrivateBinance("api/v3/account", "GET", Cred) '{"code":-1102,"msg":"Mandatory parameter 'timestamp' was not sent, was empty/null, or malformed."} Test.IsOk InStr(TestResult, "code") > 0, "test Private GET 1a failed, result: ${1}" Test.IsOk InStr(TestResult, "Mandatory parameter") > 0, "test Private GET 1b failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("response_txt")("code"), -1102, "test Private GET 1c failed, result: ${1}" 'Add timestamp to the parameters and try again Dim Params2 As New Dictionary Params2.Add "timestamp", GetBinanceTime() TestResult = PrivateBinance("api/v3/account", "GET", Cred, Params2) '{"makerCommission":10,"takerCommission":10,"buyerCommission":0,"sellerCommission":0,"canTrade":true,"canWithdraw":true,"canDeposit":true,"updateTime":1512476238993,"balances":[{"asset":"BTC","free":"0.00000000","locked":"0.00000000"},{"asset":"LTC","free":"0.00000000","locked":"0.00000000"},{"asset":"ETH","free":"0.00000000","locked":"0.00000000"},{"asset":"NEO","free":"0.00000000","locked":"0.00000000"},{"asset":"BNB","free":"0.00000000","locked":"0.00000000"},{"asset":"QTUM","free":"0.00000000","locked":"0.00000000"},{"asset":"EOS","free":"0.00000000","locked":"0.00000000"},{"asset":"SNT","free":"0.00000000","locked":"0.00000000"},{"asset":"BNT","free":"0.00000000","locked":"0.00000000"},{"asset":"GAS","free":"0.00000000","locked":"0.00000000"},{"asset":"BCC","free":"0.00000000","locked":"0.00000000"},{"asset":"USDT","free":"0.00000000","locked":"0.00000000"},{"asset":"HSR","free":"0.00000000","locked":"0.00000000"},{"asset":"OAX","free":"0.00000000","locked":"0.00000000"},{... Test.IsOk InStr(TestResult, "takerCommission") > 0, "test Private GET 1d failed, result: ${1}" Test.IsOk InStr(TestResult, "locked") > 0, "test Private GET 1e failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("takerCommission") > 0, "test Private GET 1f failed, result: ${1}" Test.IsOk JsonResult("balances").Count > 10, "test Private GET 1g failed, result: ${1}" Set Test = Suite.Test("TestBinancePrivate POST/DELETE") 'Test a test order Dim Params3 As New Dictionary Params3.Add "symbol", "LTCBTC" Params3.Add "side", "BUY" Params3.Add "type", "LIMIT" Params3.Add "price", 0.01 Params3.Add "quantity", 1 Params3.Add "timeInForce", "GTC" Params3.Add "timestamp", GetBinanceTime() TestResult = PrivateBinance("api/v3/order/test", "POST", Cred, Params3) Test.IsEqual TestResult, "{}", "test Private POST order 1a failed, result: ${1}" 'Delete a non-existing order Dim Params4 As New Dictionary Params4.Add "symbol", "LTCBTC" Params4.Add "orderId", 987654 Params4.Add "timestamp", GetBinanceTime() TestResult = PrivateBinance("api/v3/order", "DELETE", Cred, Params4) '{"error_nr":400,"error_txt":"HTTP-Bad Request","response_txt":{"code":-2011,"msg":"Unknown order sent."}} Test.IsOk InStr(TestResult, "code") > 0, "test Private DELETE order 1a failed, result: ${1}" Test.IsOk InStr(TestResult, "Unknown order") > 0, "test Private DELETE order 1b failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("response_txt")("code"), -2011, "test Private DELETE order 1c failed, result: ${1}" 'Use the Wallet end point Dim Params5 As New Dictionary Params5.Add "timestamp", GetBinanceTime() TestResult = PrivateBinance("sapi/v1/system/status", "GET", Cred, Params5) '{"status":0,"msg":"normal"} Test.IsOk InStr(TestResult, "msg") > 0, "test Private System Status 1a failed, result: ${1}" Test.IsOk InStr(TestResult, "status") > 0, "test Private System Status 1b failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("msg"), "normal", "test Private System Status 1c failed, result: ${1}" Dim Params6 As New Dictionary Params6.Add "timestamp", GetBinanceTime() TestResult = PrivateBinance("sapi/v1/capital/withdraw/history", "GET", Cred, Params6) 'e.g. [] (none) or 'e.g. [{"address":"0x94df8b352de7f46f64b01d3666bf6e936e44ce60","amount":"8.91000000","applyTime":"2019-10-1211:12:02","coin":"USDT","id":"b6ae22b3aa844210a7041aee7589627c","withdrawOrderId":"WITHDRAWtest123",//willnotbereturnedifthere'snowithdrawOrderIdforthiswithdraw."network":"ETH","transferType":0,//1forinternaltransfer,0forexternaltransfer"status":6,"transactionFee":"0.004","txId":"0xb5ef8c13b968a406cc62a93a8bd80f9e9a906ef1b3fcf20a2e48573c17659268"},{"address":"1FZdVHtiBqMrWdjPyRPULCUceZPJ2WLCsB","amount":"0.00150000","applyTime":"2019-09-2412:43:45","coin":"BTC","id":"156ec387f49b41df8724fa744fa82719","network":"BTC","status":6,"transactionFee":"0.004","transferType":0,//1forinternaltransfer,0forexternaltransfer"txId":"60fd9007ebfddc753455f95fafa808c4302c836e4d1eebc5a132c36c1d8ac354"}] If TestResult = "[]" Then 'Empty result, OK Test.IsEqual TestResult, "[]", "test Private Withdraw History 1a failed, result: ${1}" Else Test.IsOk InStr(TestResult, "address") > 0, "test Private Withdraw History 1b failed, result: ${1}" Test.IsOk InStr(TestResult, "coin") > 0, "test Private Withdraw History 1c failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult(1)("amount") * 1 > 0, "test Private Withdraw History 1d failed, result: ${1}" End If End Sub Function PublicBinance(Method As String, ReqType As String, Optional ParamDict As Dictionary) As String Dim url As String PublicApiSite = "https://api.binance.com" MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams urlPath = "/api/v1/" & Method & MethodParams url = PublicApiSite & urlPath PublicBinance = WebRequestURL(url, ReqType) End Function Function PrivateBinance(Method As String, ReqType As String, Credentials As Dictionary, Optional ParamDict As Dictionary) As String Dim NonceUnique As String Dim TimeCorrection As Long Dim url As String TradeApiSite = "https://api.binance.com/" MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "&" & MethodParams APIsign = ComputeHash_C("SHA256", MethodParams, Credentials("secretKey"), "STRHEX") url = TradeApiSite & Method & "?" & MethodParams & "&signature=" & APIsign Dim UrlHeaders As New Dictionary UrlHeaders.Add "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)" UrlHeaders.Add "Content-Type", "application/x-www-form-urlencoded" UrlHeaders.Add "X-MBX-APIKEY", Credentials("apiKey") PrivateBinance = WebRequestURL(url, ReqType, UrlHeaders) End Function Function GetBinanceTime() As Double Dim JsonResponse As String Dim Json As Object 'PublicBinance time JsonResponse = PublicBinance("time", "GET") Set Json = JsonConverter.ParseJson(JsonResponse) GetBinanceTime = Json("serverTime") Set Json = Nothing End Function ================================================ FILE: ModExchBitVavo.bas ================================================ Attribute VB_Name = "ModExchBitVavo" Sub TestBitVavo() 'Source: https://github.com/krijnsent/crypto_vba 'Documentation: https://docs.bitvavo.com/ 'Remember to create a new API key for excel/VBA Dim Apikey As String Dim secretKey As String Apikey = "your api key here" secretKey = "your secret key here" 'Remove these 2 lines, unless you define 2 constants somewhere ( Public Const secretkey_btce = "the key to use everywhere" etc ) Apikey = apikey_bitvavo secretKey = secretkey_bitvavo 'Put the credentials in a dictionary Dim Cred As New Dictionary Cred.Add "apiKey", Apikey Cred.Add "secretKey", secretKey ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModExchBitVavo" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestBitVavoPublic") 'Error, unknown command TestResult = PublicBitVavo("AnUnknownCommand", "GET") '{"error_nr":404,"error_txt":"HTTP-Not Found","response_txt":{"errorCode":110,"error":"Invalid endpoint. Please check url and HTTP method."}} Test.IsOk InStr(TestResult, "error") > 0, "test error 1a failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 404, "test error 1b failed, result: ${1}" 'Error, parameter missing TestResult = PublicBitVavo("BTC-EUR/candles", "GET") '{"error_nr":400,"error_txt":"HTTP-Bad Request","response_txt":{"errorCode":203,"error":"interval parameter is required."}} Test.IsOk InStr(TestResult, "error") > 0, "test error 2a failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 400, "test error 2b failed, result: ${1}" Test.IsEqual JsonResult("response_txt")("error"), "interval parameter is required.", "test error 2c failed, result: ${1}" 'OK simple time request TestResult = PublicBitVavo("time", "GET") 'e.g. {"time":1617720826734} Test.IsOk InStr(TestResult, "time") > 0, "test time 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("time") > 1600000000000#, "test time 2 failed, result: ${1}" 'OK request with parameter Dim Params As New Dictionary Params.Add "interval", "1d" Params.Add "limit", 10 TestResult = PublicBitVavo("BTC-EUR/candles", "GET", Params) '[[1617667200000,"49950","50300","48547","49010","455.91371112"],[1617580800000,"49590","50200","48500","49870","555.41905353"], etc. 'returns: time, OHLCV Test.IsOk InStr(TestResult, "error") = 0, "test candles 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) For N = 1 To JsonResult.Count Test.IsOk JsonResult(N)(1) > 1600000000000#, "test candles 2-" & N & " failed, result: ${1}" 'check time of record Test.IsOk JsonResult(N)(2) > 0, "test candles 3-" & N & " failed, result: ${1}" 'check Open of record Next N Set Test = Suite.Test("TestBitVavoPrivate") TestResult = PrivateBitVavo("account", "GET", Cred) 'e.g. {"fees":{"taker":"0.0025","maker":"0.0015","volume":"0.00"}} Test.IsOk InStr(TestResult, "fees") > 0, "test private account 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("fees")("taker") >= 0, "test private account 2 failed, result: ${1}" 'Private GET request that requires a parameter TestResult = PrivateBitVavo("deposit", "GET", Cred) '{"error_nr":400,"error_txt":"HTTP-Bad Request","response_txt":{"errorCode":203,"error":"symbol parameter is required."}} Test.IsOk InStr(TestResult, "error_txt") > 0, "test private deposit 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("response_txt")("error"), "symbol parameter is required.", "test private deposit 2 failed, result: ${1}" Dim Params2 As New Dictionary Params2.Add "symbol", "ETH" TestResult = PrivateBitVavo("deposit", "GET", Cred, Params2) '{"errorCode":412,"error":"crypto_bank_required."} - no deposit address set 'Or {"address": "CryptoCurrencyAddress","paymentId": "10002653"} - deposit address set AddrSet = False If InStr(TestResult, "address") > 0 Then AddrSet = True Set JsonResult = JsonConverter.ParseJson(TestResult) If AddrSet Then Test.IsOk JsonResult("address") <> "", "test private deposit 3b failed, result: ${1}" Else Test.IsEqual JsonResult("response_txt")("error"), "crypto_bank_required.", "test private deposit 3a failed, result: ${1}" End If 'Sign test case from API docs TestMsgToSign = "1548172481125POST/v2/order{""market"":""BTC-EUR"",""side"":""buy"",""price"":""5000"",""amount"":""1.23"",""orderType"":""limit""}" TestSign = ComputeHash_C("SHA256", TestMsgToSign, "bitvavo", "STRHEX") Test.IsEqual TestSign, "44d022723a20973a18f7ee97398b9fdd405d2d019c8d39e24b8cc0dcb39ca016", "test sign failed, result: ${1}" 'Buy order, buying 1 BTC for 100 EUR/BTC Dim Params3 As New Dictionary Params3.Add "market", "BTC-EUR" Params3.Add "side", "buy" Params3.Add "orderType", "limit" Params3.Add "amount", 1 Params3.Add "price", 100 Params3.Add "timeInForce", "FOK" TestResult = PrivateBitVavo("order", "POST", Cred, Params3) '{"error_nr":400,"error_txt":"HTTP-Bad Request","response_txt":{"errorCode":216,"error":"You do not have sufficient balance to complete this operation."}} Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 400, "test private order 1 failed, result: ${1}" Test.IsEqual JsonResult("response_txt")("errorCode"), 216, "test private order 2 failed, result: ${1}" 'Deleting not existing order Dim Params4 As New Dictionary Params4.Add "market", "ETH-EUR" Params4.Add "orderId", "ff403e21-e270-4584-bc9e-9c4b18461465" TestResult = PrivateBitVavo("order", "DELETE", Cred, Params4) '{"error_nr":404,"error_txt":"HTTP-Not Found","response_txt":{"errorCode":240,"error":"No order found. Please be aware that simultaneously updating the same order may return this error."}} Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 404, "test private delete order 1 failed, result: ${1}" Test.IsEqual JsonResult("response_txt")("errorCode"), 240, "test private delete order 2 failed, result: ${1}" 'Test by default switched off... Deletes all open orders... 'Dim Params5 As New Dictionary 'TestResult = PrivateBitVavo("orders", "DELETE", Cred, Params5) 'TestResult = "{""orderId"": ""2e7ce7fc-44e2-4d80-a4a7-d079c4750b61""}" 'If InStr(TestResult, "orderId") > 0 Then ' 'has some results ' 'e.g.: {"orderId": "2e7ce7fc-44e2-4d80-a4a7-d079c4750b61"} ' Test.IsOk InStr(TestResult, "orderId") > 0 ' Set JsonResult = JsonConverter.ParseJson(TestResult) ' For Each k In JsonResult.Keys() ' Test.IsOk Len(JsonResult(k)) >= 10 ' Next k 'Else ' 'no results ' 'Empty: [] ' Test.IsEqual TestResult, "[]" 'End If End Sub Function PublicBitVavo(Method As String, ReqType As String, Optional ParamDict As Dictionary) As String Dim url As String PublicApiSite = "https://api.bitvavo.com" MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams urlPath = "/v2/" & Method & MethodParams url = PublicApiSite & urlPath PublicBitVavo = WebRequestURL(url, ReqType) End Function Function PrivateBitVavo(Method As String, ReqType As String, Credentials As Dictionary, Optional ParamDict As Dictionary) As String Dim NonceUnique As String Dim MethodParams As String Dim postdata As String Dim url As String TradeApiSite = "https://api.bitvavo.com" ApiEndPoint = "/v2/" & Method postdata = "" NonceUnique = GetBitVavoTime If UCase(ReqType) = "POST" Then 'For POST request, all query parameters need to be included in the request body with JSON. (e.g. {"currency":"BTC"}). postdata = JsonConverter.ConvertToJson(ParamDict) If postdata = "{}" Then postdata = "" ElseIf UCase(ReqType) = "GET" Or UCase(ReqType) = "DELETE" Or UCase(ReqType) = "PUT" Then MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams ApiEndPoint = ApiEndPoint & MethodParams End If StrToHash = NonceUnique & ReqType & ApiEndPoint & postdata APIsign = ComputeHash_C("SHA256", StrToHash, Credentials("secretKey"), "STRHEX") url = TradeApiSite & ApiEndPoint Dim UrlHeaders As New Dictionary UrlHeaders.Add "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)" UrlHeaders.Add "Content-Type", "application/json" UrlHeaders.Add "BITVAVO-ACCESS-TIMESTAMP", NonceUnique UrlHeaders.Add "BITVAVO-ACCESS-KEY", Credentials("apiKey") UrlHeaders.Add "BITVAVO-ACCESS-SIGNATURE", APIsign PrivateBitVavo = WebRequestURL(url, ReqType, UrlHeaders, postdata) End Function Function GetBitVavoTime() As Double Dim JsonResponse As String Dim Json As Object 'PublicBinance time JsonResponse = PublicBitVavo("time", "GET") Set Json = JsonConverter.ParseJson(JsonResponse) GetBitVavoTime = Json("time") Set Json = Nothing End Function ================================================ FILE: ModExchBitfinex.bas ================================================ Attribute VB_Name = "ModExchBitfinex" Sub TestBitfinex() 'Source: https://github.com/krijnsent/crypto_vba 'Documentation: https://docs.bitfinex.com/docs/rest-auth 'Note: there are two versions, v1 and v2, v2 is in Beta and does not have all functions 'Remember to create a new API key for excel/VBA Dim Apikey As String Dim secretKey As String Apikey = "your api key here" secretKey = "your secret key here" 'Remove these 2 lines, unless you define 2 constants somewhere ( Public Const secretkey_bitfinex = "the key to use everywhere" etc ) Apikey = apikey_bitfinex secretKey = secretkey_bitfinex 'Put the credentials in a dictionary Dim Cred As New Dictionary Cred.Add "apiKey", Apikey Cred.Add "secretKey", secretKey ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModExchBitfinex" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestBitfinexPublic v1") 'Error, unknown command TestResult = PublicBitfinex1("AnUnknownCommand", "GET") '{"error_nr":404,"error_txt":"HTTP-Not Found","response_txt":0} Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 404 'Error, wrong parameter TestResult = PublicBitfinex1("ticker/bogus_here", "GET") '{"error_nr":400,"error_txt":"HTTP-Bad Request","response_txt":{"message":"Unknown symbol"}} Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 400 Test.IsEqual JsonResult("response_txt")("message"), "Unknown symbol" 'OK request TestResult = PublicBitfinex1("symbols", "GET") '["btcusd","ltcusd","ltcbtc","ethusd","ethbtc","etcbtc", Test.IsOk InStr(TestResult, "ethbtc") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult(1), "btcusd" 'OK request with details TestResult = PublicBitfinex1("stats/BTCUSD", "GET") '[{"period":1,"volume":"6815.19360556"},{"period":7,"volume":"98002.43336128"},{"period":30,"volume":"387511.06628926"}] Test.IsOk InStr(TestResult, "volume") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult(1)("period"), 1 Test.IsOk JsonResult(1)("volume") > 0 Set Test = Suite.Test("TestBitfinexPrivate v1 Balances") TestResult = PrivateBitfinex1("balances", "POST", Cred) '[{"type":"exchange","currency":"btc","amount":"5.15334045","available":"5.15334045"},{"type":"exchange","currency":"eos","amount":"15.0","available":"15.0"}] Test.IsOk InStr(TestResult, "currency") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk InStr(JsonResult(1)("type"), "exchange") + InStr(JsonResult(1)("type"), "margin") + InStr(JsonResult(1)("type"), "funding") > 0 Test.IsOk Len(JsonResult(1)("currency")) >= 3 Test.IsOk Len(JsonResult(1)("amount")) >= 0 Set Test = Suite.Test("TestBitfinexPrivate v1 Orders") Dim Params1o As New Dictionary Params1o.Add "symbol", "BTCUSD" Params1o.Add "amount", "1.33" Params1o.Add "price", "9" Params1o.Add "side", "buy" Params1o.Add "type", "fill-or-kill" TestResult = PrivateBitfinex1("order/new", "POST", Cred, Params1o) 'e.g. {"error_nr":403,"error_txt":"HTTP-Forbidden","response_txt":{"message":"This API key does not have permission for this action"}} 'or: {"id":448364249,"symbol":"btcusd","exchange":"bitfinex",etc. If InStr(TestResult, "error") > 0 Then Test.IsOk InStr(TestResult, "message") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 403 Else Test.IsOk InStr(TestResult, "symbol") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("id") > 0 Test.IsEqual JsonResult("symbol"), "btcusd" End If Set Test = Suite.Test("TestBitfinexPublic v2") 'Error, unknown command TestResult = PublicBitfinex2("AnUnknownCommand", "GET") '{"error_nr":404,"error_txt":"HTTP-Not Found","response_txt":0} Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 404 'Error, wrong parameter TestResult = PublicBitfinex2("ticker/bogus_here", "GET") '{"error_nr":500,"error_txt":"HTTP-","response_txt":["error",10020,"symbol: invalid"]} Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 500 Test.IsEqual JsonResult("response_txt")(2), 10020 'OK request TestResult = PublicBitfinex2("platform/status", "GET") '[1] -> 1 = active, 0=maintenance Test.IsOk InStr(TestResult, "]") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult(1), 1 'OK request with parameters Dim Params As New Dictionary Params.Add "symbols", "tBTCUSD,tNEOETH" TestResult = PublicBitfinex2("tickers", "GET", Params) '[["tBTCUSD",3907.1,34.68474518,3907.2,84.93216888,-24.5,-0.0062,3907.2,6790.69338403,3949,3838.89411809],["tNEOETH",0.065716,3437.62864427,0.06589,2087.26914816,0.000835,0.0129,0.065611,4944.19962337,0.068214,0.064699]] Test.IsOk InStr(TestResult, "tNEOETH") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult(1)(1), "tBTCUSD" Test.IsOk JsonResult(1)(2) > 100 Set Test = Suite.Test("TestBitfinexPublic v2 POST") 'OK POST request with parameters, no credentials needed Dim Params2 As New Dictionary Params2.Add "symbol", "tBTCUSD" Params2.Add "amount", "-2.5" TestResult = PublicBitfinex2("calc/trade/avg", "POST", Params2) '[3905,-2.5] Test.IsOk InStr(TestResult, "]") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult(1) > 100 Test.IsEqual JsonResult(2), -2.5 Set Test = Suite.Test("TestBitfinexPrivate v2 Wallets") TestResult = PrivateBitfinex2("auth/r/wallets", "POST", Cred) 'e.g. [["exchange","BTC",5.15334045,0,null],["exchange","EOS",15,0,null]] Test.IsOk InStr(TestResult, "]]") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) 'Test first result for being one of three types exchange, margin, funding Test.IsOk InStr(JsonResult(1)(1), "exchange") + InStr(JsonResult(1)(1), "margin") + InStr(JsonResult(1)(1), "funding") > 0 Test.IsOk Len(JsonResult(1)(2)) >= 3 Test.IsOk Len(JsonResult(1)(3)) >= 0 Set Test = Suite.Test("TestBitfinexPrivate v2 Trades") 'Unix time period (add 3 zeros for ms): t1 = DateToUnixTime("1/1/2016") & "000" t2 = DateToUnixTime("1/1/2018") & "000" Dim Params3 As New Dictionary Params3.Add "start", t1 Params3.Add "end", t2 Params3.Add "limit", 25 TestResult = PrivateBitfinex2("auth/r/ledgers/BTC/hist", "POST", Cred, Params3) '[] for empty or [[ID,CURRENCY,null,TIMESTAMP_MILLI,null,AMOUNT,BALANCE,null,Description]] Test.IsOk InStr(TestResult, "]") > 0 If Len(TestResult) > 2 Then 'Results, some more tests Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult(1)(1) > 0 Test.IsOk Len(JsonResult(1)(2)) >= 3 Test.IsOk JsonResult(1)(4) > 1400000000000# End If End Sub 'Version 2 APIs below Function PublicBitfinex1(Method As String, ReqType As String, Optional ParamDict As Dictionary) As String Dim url As String PublicApiSite = "https://api.bitfinex.com" MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams urlPath = "/v1/" & Method & MethodParams url = PublicApiSite & urlPath PublicBitfinex1 = WebRequestURL(url, ReqType) End Function Function PrivateBitfinex1(Method As String, ReqType As String, Credentials As Dictionary, Optional ParamDict As Dictionary) As String 'Thanks to balin77! Dim NonceUnique As String Dim TimeCorrection As Long Dim url As String NonceUnique = CreateNonce(15) TradeApiSite = "https://api.bitfinex.com" ApiPath = "/v1/" & Method MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams Set PayloadDict = New Dictionary PayloadDict("request") = ApiPath PayloadDict("nonce") = NonceUnique If Not ParamDict Is Nothing Then For Each key In ParamDict.Keys PayloadDict(key) = ParamDict(key) Next key End If Json = Replace(ConvertToJson(PayloadDict), "/", "\/") payload = Base64Encode(Json) APIsign = ComputeHash_C("SHA384", payload, Credentials("secretKey"), "STRHEX") url = TradeApiSite & ApiPath Dim UrlHeaders As New Dictionary UrlHeaders.Add "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)" UrlHeaders.Add "Content-Type", "application/x-www-form-urlencoded" UrlHeaders.Add "X-BFX-APIKEY", Credentials("apiKey") UrlHeaders.Add "X-BFX-PAYLOAD", payload UrlHeaders.Add "X-BFX-SIGNATURE", APIsign PrivateBitfinex1 = WebRequestURL(url, ReqType, UrlHeaders) End Function Function PublicBitfinex2(Method As String, ReqType As String, Optional ParamDict As Dictionary) As String Dim url As String PublicApiSite = "https://api-pub.bitfinex.com" MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams urlPath = "/v2/" & Method & MethodParams url = PublicApiSite & urlPath PublicBitfinex2 = WebRequestURL(url, ReqType) End Function Function PrivateBitfinex2(Method As String, ReqType As String, Credentials As Dictionary, Optional ParamDict As Dictionary) As String Dim NonceUnique As String Dim TimeCorrection As Long Dim url As String NonceUnique = CreateNonce(15) TradeApiSite = "https://api.bitfinex.com/" ApiPath = "v2/" & Method MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams ToSign = "/api/" & ApiPath & NonceUnique APIsign = ComputeHash_C("SHA384", ToSign, Credentials("secretKey"), "STRHEX") url = TradeApiSite & ApiPath & MethodParams Dim UrlHeaders As New Dictionary UrlHeaders.Add "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)" UrlHeaders.Add "Content-Type", "application/x-www-form-urlencoded" UrlHeaders.Add "bfx-nonce", NonceUnique UrlHeaders.Add "bfx-apikey", Credentials("apiKey") UrlHeaders.Add "bfx-signature", APIsign PrivateBitfinex2 = WebRequestURL(url, ReqType, UrlHeaders) End Function ================================================ FILE: ModExchBitmex.bas ================================================ Attribute VB_Name = "ModExchBitmex" Sub TestBitmex() 'Source: https://github.com/krijnsent/crypto_vba 'Documentation: https://www.bitmex.com/app/restAPI 'Commands: https://www.bitmex.com/api/explorer/ 'VBA example: https://github.com/BitMEX/api-connectors/tree/master/official-http/vba 'Remember to create a new API key for excel/VBA Dim Apikey As String Dim secretKey As String Apikey = "your api key here" secretKey = "your secret key here" 'Remove these 2 lines, unless you define 2 constants somewhere ( Public Const secretkey_btce = "the key to use everywhere" etc ) Apikey = apikey_bitmex secretKey = secretkey_bitmex 'Put the credentials in a dictionary Dim Cred As New Dictionary Cred.Add "apiKey", Apikey Cred.Add "secretKey", secretKey ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModExchBitmex" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestBitmexPublic") 'Error, unknown command TestResult = PublicBitmex("AnUnknownCommand", "GET") '{"error_nr":404,"error_txt":"HTTP-Not Found","response_txt":{"error":{"message":"Not Found","name":"HTTPError"}}} Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 404 'Error, command without parameters TestResult = PublicBitmex("orderBook/L2", "GET") '{"error_nr":400,"error_txt":"HTTP-Bad Request","response_txt":{"error":{"message":"'symbol' is a required arg.","name":"HTTPError"}}} Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 400 'OK request TestResult = PublicBitmex("stats", "GET") '[{"rootSymbol":"A50","currency":"XBt","volume24h":0,"turnover24h":0,"openInterest":0,"openValue":0},{"rootSymbol":"ADA","currency":"XBt","volume24h":28782927,"turnover24h":17393857814,"openInterest":54769214,"openValue":33902143466},{"rootSymbol":"BCH","currency":"XBt","volume24h":3642,"turnover24h":9362243000,"openInterest":24992,"openValue":64404384000},{"rootSymbol":"BFX","currency":"XBt","volume24h":0,"turnover24h":0,"openInterest":0,"openValue":0},{"rootSymbol":"BLOCKS","currency":"XBt","volume24h":0,"turnover24h":0,"openInterest":0,"openValue":0},{"rootSymbol":"BVOL","currency":"XBt","volume24h":0,"turnover24h":0,"openInterest":0,"openValue":0},{"rootSymbol":"COIN","currency":"XBt","volume24h":0,"turnover24h":0,"openInterest":0,"openValue":0},{"rootSymbol":"DAO","currency":"XBt","volume24h":0,"turnover24h":0,"openInterest":0,"openValue":0},{"rootSymbol":"DASH","currency":"XBt","volume24h":0,"turnover24h":0,"openInterest":0,"openValue":0} etc. Test.IsOk InStr(TestResult, "ETH") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) For N = 1 To JsonResult.Count Test.IsEqual JsonResult(N)("currency"), "XBt" If JsonResult(N)("rootSymbol") <> "Total" Then Test.IsOk JsonResult(N)("volume24h") >= 0 Next N 'Put parameters/options in a dictionary Dim Params As New Dictionary Params.Add "symbol", "XBT" Params.Add "depth", 5 TestResult = PublicBitmex("orderBook/L2", "GET", Params) '[{"symbol":"XBTUSD","id":8799115700,"side":"Sell","size":65300,"price":8843},{"symbol":"XBTUSD","id":8799115750,"side":"Sell","size":58655,"price":8842.5},{"symbol":"XBTUSD","id":8799115800,"side":"Sell","size":88599,"price":8842},{"symbol":"XBTUSD","id":8799115850,"side":"Sell","size":5368,"price":8841.5},{"symbol":"XBTUSD","id":8799115900,"side":"Sell","size":1436605,"price":8841},{"symbol":"XBTUSD","id":8799115950,"side":"Buy","size":2230982,"price":8840.5},{"symbol":"XBTUSD","id":8799116000,"side":"Buy","size":30155,"price":8840},{"symbol":"XBTUSD","id":8799116050,"side":"Buy","size":61062,"price":8839.5},{"symbol":"XBTUSD","id":8799116100,"side":"Buy","size":78279,"price":8839},{"symbol":"XBTUSD","id":8799116150,"side":"Buy","size":81493,"price":8838.5}] Test.IsOk InStr(TestResult, "symbol") > 0 Test.IsOk InStr(TestResult, "side") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult(1)("symbol"), "XBTUSD" Test.IsOk JsonResult(1)("id") > 0 Test.IsOk JsonResult(1)("size") > 0 Test.IsOk JsonResult(1)("price") > 0 'GET private API Set Test = Suite.Test("TestBitmexPrivate GET") 'Use TESTNET 'Test an invalid command Dim Params2 As New Dictionary Params2.Add "testnet", 1 TestResult = PrivateBitmex("not_a_command", "GET", Cred, Params2) '{"error_nr":404,"error_txt":"HTTP-Not Found","response_txt":{"error":{"message":"Not Found","name":"HTTPError"}}} Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 404 'Simple GET without parameters Dim Params3 As New Dictionary Params3.Add "testnet", 1 TestResult = PrivateBitmex("user", "GET", Cred, Params3) '{"id":30219,"ownerId":null,"lastname":"Rijnsent","username":"rijnsent","email":"rijnsent",etc..} Test.IsOk InStr(TestResult, "lastname") > 0 Test.IsOk InStr(TestResult, "username") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("id") > 0 'Simple GET without parameters Dim Params4 As New Dictionary Params4.Add "testnet", 1 Params4.Add "currency", "XBt" Params4.Add "count", 5 TestResult = PrivateBitmex("user/walletHistory", "GET", Cred, Params4) '[{"transactID":"db7925ad-b54156-baff28-baf7","account":3210,"currency":"XBt","transactType":"Transfer","amount":1000000,"fee":null,"transactStatus":"Completed","address":"0","tx":"9ddad751-507a-81ca-0b55-13cd08b7063f","text":"Signup bonus","transactTime":"2020-06-01T18:14:33.791Z","walletBalance":1000000,"marginBalance":null,"timestamp":"2020-06-01T18:14:33.791Z"}] Test.IsOk InStr(TestResult, "transactID") > 0 Test.IsOk InStr(TestResult, "currency") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult(1)("amount") > 0 Set Test = Suite.Test("TestBitmexPrivate POST/DELETE") 'Test delete all orders Dim Params5 As New Dictionary Params5.Add "testnet", 1 TestResult = PrivateBitmex("order/all", "DELETE", Cred, Params5) Test.IsEqual TestResult, "[]" 'Test delete all orders Dim Params6 As New Dictionary Params6.Add "testnet", 1 Params6.Add "symbol", "XBTUSD" Params6.Add "price", 2 Params6.Add "orderQty", 0.00000002 Params6.Add "clOrdID", "MyTestOrderIDHere" TestResult = PrivateBitmex("order", "POST", Cred, Params6) '{"error_nr":403,"error_txt":"HTTP-Forbidden","response_txt":{"error":{"message":"Access Denied","name":"HTTPError"}}} Test.IsOk InStr(TestResult, "error_nr") > 0 Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 403 End Sub Function PublicBitmex(Method As String, ReqType As String, Optional ParamDict As Dictionary) As String Dim url As String PublicApiSite = "https://www.bitmex.com" MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams urlPath = "/api/v1/" & Method & MethodParams url = PublicApiSite & urlPath PublicBitmex = WebRequestURL(url, ReqType) End Function Function PrivateBitmex(Method As String, ReqType As String, Credentials As Dictionary, Optional ParamDict As Dictionary) As String Dim NonceUnique As String Dim MethodParams As String Dim postdata As String Dim url As String TradeApiSite = "https://www.bitmex.com" If Not ParamDict Is Nothing Then If ParamDict.Exists("testnet") Then ParamDict.Remove "testnet" TradeApiSite = "https://testnet.bitmex.com" End If End If ApiEndPoint = "/api/v1/" & Method postdata = "" NonceUnique = CreateNonce(13) If UCase(ReqType) = "POST" Then 'For POST request, all query parameters need to be included in the request body with JSON. (e.g. {"currency":"BTC"}). postdata = JsonConverter.ConvertToJson(ParamDict) ElseIf UCase(ReqType) = "GET" Then MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams ApiEndPoint = ApiEndPoint & MethodParams End If StrToHash = ReqType & ApiEndPoint & NonceUnique & postdata APIsign = ComputeHash_C("SHA256", StrToHash, Credentials("secretKey"), "STRHEX") url = TradeApiSite & ApiEndPoint Dim UrlHeaders As New Dictionary UrlHeaders.Add "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)" UrlHeaders.Add "Content-Type", "application/x-www-form-urlencoded" UrlHeaders.Add "api-nonce", NonceUnique 'NOT USED ANYMORE UrlHeaders.Add "api-key", Credentials("apiKey") UrlHeaders.Add "api-signature", APIsign PrivateBitmex = WebRequestURL(url, ReqType, UrlHeaders, postdata) End Function ================================================ FILE: ModExchBitstamp.bas ================================================ Attribute VB_Name = "ModExchBitstamp" Sub TestBitstamp() 'Source: https://github.com/krijnsent/crypto_vba 'Documentation: https://Bitstamp.com/home/api 'Remember to create a new API key for excel/VBA Dim Apikey As String Dim secretKey As String Apikey = "your api key here" secretKey = "your secret key here" customerID = "your customer id here" 'Remove these 3 lines, unless you define 3 constants somewhere ( Public Const secretkey_btce = "the key to use everywhere" etc ) Apikey = apikey_bitstamp secretKey = secretkey_bitstamp customerID = customer_id_bitstamp 'Put the credentials in a dictionary Dim Cred As New Dictionary Cred.Add "apiKey", Apikey Cred.Add "secretKey", secretKey Cred.Add "customerID", customerID ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModExchBitstamp" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestBitstampPublic") 'Error, unknown command TestResult = PublicBitstamp("AnUnknownCommand", "GET") '{"error_nr":404,"error_txt":"HTTP-Not Found","response_txt":0} Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 404 'Error, parameter missing TestResult = PublicBitstamp("v2/ticker_hour/", "GET") '{"error_nr":404,"error_txt":"HTTP-NOT FOUND","response_txt":0} Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 404 'Request without parameters TestResult = PublicBitstamp("ticker/", "GET") '{"high": "3806.90000000", "last": "3707.22", "timestamp": "1551731354", "bid": "3707.14", "vwap": "3724.51", "volume": "6515.58124105", "low": "3670.00000000", "ask": "3707.22", "open": 3789.70} Test.IsOk InStr(TestResult, "timestamp") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("timestamp") * 1 >= 1510000000 Test.IsOk JsonResult("bid") >= 0 'Put variables in TestResult = PublicBitstamp("v2/ticker_hour/btceur/", "GET") '{"high": "3282.58", "last": "3277.18", "timestamp": "1551731355", "bid": "3276.00", "vwap": "3276.05", "volume": "24.42762265", "low": "3270.77", "ask": "3276.08", "open": "3275.17"} Test.IsOk InStr(TestResult, "timestamp") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("timestamp") * 1 >= 1510000000 Test.IsOk JsonResult("bid") >= 0 'Unix time period: Set Test = Suite.Test("TestBitstampPrivate") TestResult = PrivateBitstamp("balance/", "POST", Cred) '{"xrp_available": "0.00000000", "eur_available": "0.00", "usd_reserved": "0.00", "eur_balance": "0.00", "btc_balance": "0.00000000", "usd_available": "0.00", "btc_reserved": "0.00000000", "fee": "0.2500", "btc_available": "0.00000000", "eur_reserved": "0.00", "xrp_reserved": "0.00000000", "xrp_balance": "0.00000000", "usd_balance": "0.00"} Test.IsOk InStr(TestResult, "eur_balance") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("eur_balance") >= 0 Test.IsOk JsonResult("usd_balance") >= 0 TestResult = PrivateBitstamp("v2/balance/", "POST", Cred) '{"bch_available": "0.00000000", "bch_balance": "0.00000000", "bch_reserved": "0.00000000", "bchbtc_fee": "0.25", "bcheur_fee": "0.25", "bchusd_fee": "0.25", "btc_available": "0.00000000", "btc_balance": "0.00000000", "btc_reserved": "0.00000000", "btceur_fee": "0.25", "btcusd_fee": "0.25", "eth_available": "0.00000000", "eth_balance": "0.00000000", "eth_reserved": "0.00000000", "ethbtc_fee": "0.25", "etheur_fee": "0.25", "ethusd_fee": "0.25", "eur_available": "0.00", "eur_balance": "0.00", "eur_reserved": "0.00", "eurusd_fee": "0.25", "ltc_available": "0.00000000", "ltc_balance": "0.00000000", "ltc_reserved": "0.00000000", "ltcbtc_fee": "0.25", "ltceur_fee": "0.25", "ltcusd_fee": "0.25", "usd_available": "0.00", "usd_balance": "0.00", "usd_reserved": "0.00", "xrp_available": "0.00000000", "xrp_balance": "0.00000000", "xrp_reserved": "0.00000000", "xrpbtc_fee": "0.25", "xrpeur_fee": "0.25", "xrpusd_fee": "0.25"} Test.IsOk InStr(TestResult, "btc_balance") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("bch_balance") >= 0 Test.IsOk JsonResult("eth_balance") >= 0 TestResult = PrivateBitstamp("order_status/", "POST", Cred) '{"error": "Missing id POST param"} Test.IsOk InStr(TestResult, "Missing") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error"), "Missing id POST param" 'Put the parameters in a dictionary Dim Params As New Dictionary Params.Add "id", 12345 TestResult = PrivateBitstamp("order_status/", "POST", Cred, Params) '{"error": "Order not found"} Test.IsOk InStr(TestResult, "found") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error"), "Order not found" 'Set a buy order, put the parameters in a dictionary Dim Params2 As New Dictionary Params2.Add "amount", 1 Params2.Add "price", 3 Params2.Add "ioc_order", True TestResult = PrivateBitstamp("v2/buy/etheur/", "POST", Cred, Params2) '{"status": "error", "reason": {"__all__": ["Minimum order size is 5.0 EUR."]}} Test.IsOk InStr(TestResult, "Minimum order size") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("status"), "error" End Sub Function PublicBitstamp(Method As String, ReqType As String, Optional ParamDict As Dictionary) As String Dim url As String PublicApiSite = "https://www.bitstamp.net" MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams urlPath = "/api/" & Method & MethodParams url = PublicApiSite & urlPath PublicBitstamp = WebRequestURL(url, ReqType) End Function Function PrivateBitstamp(Method As String, ReqType As String, Credentials As Dictionary, Optional ParamDict As Dictionary) As String Dim NonceUnique As String Dim message As String Dim PostMsg As String Dim url As String Dim PayloadDict As Dictionary 'Get a Nonce NonceUnique = CreateNonce() TradeApiSite = "https://www.bitstamp.net/api/" message = NonceUnique & Credentials("customerID") & Credentials("apiKey") APIsign = UCase(ComputeHash_C("SHA256", message, Credentials("secretKey"), "STRHEX")) Set PayloadDict = New Dictionary PayloadDict("key") = Credentials("apiKey") PayloadDict("signature") = APIsign PayloadDict("nonce") = NonceUnique If Not ParamDict Is Nothing Then For Each key In ParamDict.Keys PayloadDict(key) = ParamDict(key) Next key End If PostMsg = DictToString(PayloadDict, "URLENC") Dim headerDict As New Dictionary headerDict.Add "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)" headerDict.Add "Content-Type", "application/x-www-form-urlencoded" url = TradeApiSite & Method PrivateBitstamp = WebRequestURL(url, ReqType, headerDict, PostMsg) End Function ================================================ FILE: ModExchBittrex.bas ================================================ Attribute VB_Name = "ModExchBittrex" Sub TestBittrex() 'Source: https://github.com/krijnsent/crypto_vba 'Documentation: https://bittrex.com/home/api 'v3 - https://bittrex.github.io/api/v3 'Remember to create a new API key for excel/VBA Dim Apikey As String Dim secretKey As String Apikey = "your api key here" secretKey = "your secret key here" 'Remove these 2 lines, unless you define 2 constants somewhere ( Public Const secretkey_btce = "the key to use everywhere" etc ) Apikey = apikey_bittrex secretKey = secretkey_bittrex 'Put the credentials in a dictionary Dim Cred As New Dictionary Cred.Add "apiKey", Apikey Cred.Add "secretKey", secretKey ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModExchBittrex" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestBittrexPublic") 'Error, unknown/wrong command TestResult = PublicBittrex("AnUnknownCommand", "GET") '{"error_nr":404,"error_txt":"HTTP-Not Found","response_txt":{"code":"NOT_FOUND"}} Test.IsOk InStr(TestResult, "error") > 0, "test error 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 404, "test error 2 failed, result: ${1}" 'Request without parameters TestResult = PublicBittrex("markets", "GET") '[{"symbol":"4ART-BTC","baseCurrencySymbol":"4ART","quoteCurrencySymbol":"BTC","minTradeSize":"10.00000000","precision":8,"status":"ONLINE","createdAt":"2020-06-10T15:05:29.833Z","notice":"","prohibitedIn":["US"],"associatedTermsOfService":[]},{"symbol":"4ART-USDT","baseCurrencySymbol":"4ART","quoteCurrencySymbol":"USDT","minTradeSize":"10.00000000","precision":5,"status":"ONLINE","createdAt":"2020-06-10T15:05:40.98Z", etc. Test.IsOk InStr(TestResult, "quoteCurrencySymbol") > 0, "test markets 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult(1)("quoteCurrencySymbol"), "BTC", "test markets 2 failed, result: ${1}" Test.IsOk JsonResult(1)("precision") > 0, "test markets 3 failed, result: ${1}" 'Put parameters/options in a dictionary for a summary of one coin, wrong input Dim Params As New Dictionary Params.Add "market", "BTC-DOGE" TestResult = PublicBittrex("markets", "GET", Params) '{"error_nr":404,"error_txt":"HTTP-Not Found","response_txt":{"code":"MARKET_NAME_REVERSED","detail":"The provided market symbol appears to be reversed. Please retry with the market symbol provided in data.NewMarketSymbol.","data":{"newMarketSymbol":"DOGE-BTC"}}} Test.IsOk InStr(TestResult, "error") > 0, "test error2 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 404, "test error2 2 failed, result: ${1}" 'Parameter in a dictionary Dim Params2 As New Dictionary Params2.Add "market", "DOGE-BTC" TestResult = PublicBittrex("markets", "GET", Params2) '{"symbol":"DOGE-BTC","baseCurrencySymbol":"DOGE","quoteCurrencySymbol":"BTC","minTradeSize":"1000.00000000","precision":8,"status":"ONLINE","createdAt":"2014-02-13T00:00:00Z","prohibitedIn":[],"associatedTermsOfService":[]} Test.IsOk InStr(TestResult, "baseCurrencySymbol") > 0, "test markets detail 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("quoteCurrencySymbol"), "BTC", "test markets detail 2 failed, result: ${1}" Test.IsEqual JsonResult("precision"), 8, "test markets detail 3 failed, result: ${1}" Test.IsEqual JsonResult("baseCurrencySymbol"), "DOGE", "test markets detail 4 failed, result: ${1}" 'Parameters in a dictionary get '/markets/{marketSymbol}/candles/{candleInterval}/recent Dim Params3 As New Dictionary Params3.Add "market", "ETH-BTC" Params3.Add "type1", "candles" Params3.Add "candleInterval", "HOUR_1" Params3.Add "type2", "recent" TestResult = PublicBittrex("markets", "GET", Params3) '[{"startsAt":"2020-08-13T15:00:00Z","open":"0.03405607","high":"0.03412946","low":"0.03393712","close":"0.03411082","volume":"224.62409851","quoteVolume":"7.64110651"},{"startsAt":"2020-08-13T16:00:00Z","open":"0.03411095","high":"0.03418634","low":"0.03387446","close":"0.03402789","volume":"303.55027355","quoteVolume":"10.33201616"},{"startsAt":"2020-08-13T17:00:00Z","open":"0.03403607","high":"0.03407806","low":"0.03389236","close":"0.03403147","volume":"487.61617145","quoteVolume":"16.57089220"},{"startsAt":"2020-08-13T18:00:00Z","open":"0.03403252","high":"0.03413220","low":"0.03403252","close":"0.03410964","volume":"388.13757692","quoteVolume":"13.22881730"},{"startsAt":"2020-08-13T19:00:00Z","open":"0.03408765","high":"0.03425485","low":"0.03408765","close":"0.03422712","volume":"312.75229144","quoteVolume":"10.69620756"}, etc... Test.IsOk InStr(TestResult, "startsAt") > 0, "test candles 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult(1)("open") > 0, "test candles 2 failed, result: ${1}" Test.IsOk JsonResult(1)("high") > 0, "test candles 3 failed, result: ${1}" Test.IsOk JsonResult(1)("low") > 0, "test candles 4 failed, result: ${1}" 'Get bittrex time from ping Set Test = Suite.Test("TestBittrexTime") TestResult = GetBittrexTime() Test.IsOk TestResult > 0, "test time 2 failed, result: ${1}" 'Test private API Set Test = Suite.Test("TestBittrexPrivate") TestResult = PrivateBittrex("balances", "GET", Cred) '[{"currencySymbol":"BCH","total":"0.00001733","available":"0.00001733","updatedAt":"2001-01-01T00:00:00Z"},{"currencySymbol":"BTC","total":"0.01500039","available":"0.01500039","updatedAt":"2001-01-01T00:00:00Z"},{"currencySymbol":"BTXCRD","total":"0.00000000","available":"0.00000000","updatedAt":"2019-10-23T04:16:31.1Z"},{"currencySymbol":"XLM","total":"0","available":"0","updatedAt":"2020-09-13T16:02:42.84307Z"}], etc... Test.IsOk InStr(TestResult, "currencySymbol") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk Len(JsonResult(1)("currencySymbol")) >= 3 Test.IsOk JsonResult(1)("Balance") >= 0 Dim Params4 As New Dictionary Params4.Add "marketSymbol", "XRP-BTC" TestResult = PrivateBittrex("orders/open", "GET", Cred, Params4) '[] (assuming no open orders DOGE-BTC, why would you have any...? Test.IsEqual TestResult, "[]" 'Buy 1 BTC for a crazy low price of 0.1 USD :-) Dim Params5 As New Dictionary Params5.Add "marketSymbol", "BTC-USD" Params5.Add "direction", "BUY" Params5.Add "type", "LIMIT" Params5.Add "timeInForce", "FILL_OR_KILL" Params5.Add "quantity", 1 Params5.Add "limit", 0.1 TestResult = PrivateBittrex("orders", "POST", Cred, Params5) Debug.Print TestResult If InStr(TestResult, "error_nr") Then 'e.g. {"error_nr":400,"error_txt":"HTTP-Bad Request","response_txt":{"code":"SOURCE_OF_FUNDS_REQUIRED"}} Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("error_nr") >= 400 Else 'or OK: {"id": "string (uuid)","marketSymbol": "string","direction": "string","type": "string","quantity": "number (double)","limit": "number (double)","ceiling": "number (double)","timeInForce": "string","clientOrderId": "string (uuid)","fillQuantity": "number (double)","commission": "number (double)","proceeds": "number (double)","status": "string","createdAt": "string (date-time)","updatedAt": "string (date-time)","closedAt": "string (date-time)","orderToCancel": { "type": "string", "id": "string (uuid)"}} Test.IsOk InStr(TestResult, "marketSymbol") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("direction"), "BUY" End If 'Cancel order with id Dim Params6 As New Dictionary Params6.Add "uuid", "orderid-bla" TestResult = PrivateBittrex("orders", "DELETE", Cred, Params6) '{"error_nr":404,"error_txt":"HTTP-Not Found","response_txt":{"code":"NOT_FOUND"}} Test.IsOk InStr(TestResult, "error_nr") > 0 Test.IsOk InStr(TestResult, "NOT_FOUND") > 0 End Sub Function PublicBittrex(Method As String, ReqType As String, Optional ParamDict As Dictionary) As String Dim url As String PublicApiSite = "https://api.bittrex.com" MethodParams = "" If Not ParamDict Is Nothing Then For Each itm In ParamDict MethodParams = MethodParams & ParamDict(itm) & "/" Next itm End If urlPath = "/v3/" & Method & "/" & MethodParams url = PublicApiSite & urlPath PublicBittrex = WebRequestURL(url, ReqType) End Function Function PrivateBittrex(Method As String, ReqType As String, Credentials As Dictionary, Optional ParamDict As Dictionary) As String Dim NonceUnique As String Dim postdata As String Dim url As String Dim Uri As String 'Get a 13-digit Nonce from the server time NonceUnique = GetBittrexTime TradeApiSite = "https://api.bittrex.com/v3/" url = TradeApiSite & Method postdata = "" If ReqType = "DELETE" Then For Each itm In ParamDict url = url & "/" & ParamDict(itm) Next itm ElseIf ReqType = "GET" And Not ParamDict Is Nothing Then url = url & "?" & DictToString(ParamDict, "URLENC") ElseIf ReqType = "POST" Then postdata = JsonConverter.ConvertToJson(ParamDict) End If contentHash = ComputeHash_C("SHA512", postdata, "", "STRHEX") preSign = NonceUnique & url & ReqType & contentHash APIsign = ComputeHash_C("SHA512", preSign, Credentials("secretKey"), "STRHEX") Dim headerDict As New Dictionary headerDict.Add "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)" headerDict.Add "Content-Type", "application/json" headerDict.Add "Api-Key", Credentials("apiKey") headerDict.Add "Api-Timestamp", NonceUnique headerDict.Add "Api-Content-Hash", contentHash headerDict.Add "Api-Signature", APIsign 'Debug.Print url, postdata PrivateBittrex = WebRequestURL(url, ReqType, headerDict, postdata) End Function Function GetBittrexTime() As Double Dim JsonResponse As String Dim Json As Object 'GetBittrexTime time from ping JsonResponse = PublicBittrex("ping", "GET") Set Json = JsonConverter.ParseJson(JsonResponse) GetBittrexTime = Json("serverTime") NonceUnique = CreateNonce(13) If GetBittrexTime = 0 Then TimeCorrection = -3600 GetBittrexTime = DateDiff("s", "1/1/1970", Now) GetBittrexTime = Trim(Str((Val(GetBittrexTime) + TimeCorrection)) & Right(Int(Timer * 100), 2) & "0") End If Set Json = Nothing End Function ================================================ FILE: ModExchBybit.bas ================================================ Attribute VB_Name = "ModExchBybit" Sub TestBybit() 'Source: https://github.com/krijnsent/crypto_vba 'https://doc.Bybit.co.kr/#section/V2-version 'Remember to create a new API key for excel/VBA Dim Apikey As String Dim secretKey As String Apikey = "your api key here" secretKey = "your secret key here" 'Remove these 2 lines, unless you define 2 constants somewhere ( Public Const secretkey_btce = "the key to use everywhere" etc ) Apikey = apikey_bybit secretKey = secretkey_bybit 'Put the credentials in a dictionary Dim Cred As New Dictionary Cred.Add "apiKey", Apikey Cred.Add "secretKey", secretKey ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModExchBybit" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestBybitPublic") 'Error, unknown command TestResult = PublicBybit("AnUnknownCommand", "GET") '{"error_nr":404,"error_txt":"HTTP-Not Found","response_txt":0} Test.IsOk InStr(TestResult, "error") > 0, "unknowncommand 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_txt"), "HTTP-Not Found", "unknowncommand 2 failed, result: ${1}" Test.IsEqual JsonResult("error_nr"), 404, "unknowncommand 3 failed, result: ${1}" 'OK request TestResult = PublicBybit("time", "GET") 'e.g. {"ret_code":0,"ret_msg":"OK","ext_code":"","ext_info":"","result":{},"time_now":"1572094930.589837"} Test.IsOk InStr(TestResult, "time_now") > 0, "time 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("ret_msg"), "OK", "time 1 failed, result: ${1}" Test.IsOk Val(JsonResult("time_now")) > 1500000000#, "time 1 failed, result: ${1}" 'GET with parameter for orderBook Dim Params1 As New Dictionary Params1.Add "symbol", "BTCUSD" TestResult = PublicBybit("orderBook/L2", "GET", Params1) 'e.g {"ret_code":0,"ret_msg":"OK","ext_code":"","ext_info":"","result":[{"symbol":"BTCUSD","price":"9094","size":214217,"side":"Buy"},{"symbol":"BTCUSD","price":"9093","size":208793,"side":"Buy"},{"symbol":"BTCUSD","price":"9092","size":208793,"side":"Buy"},{"symbol":"BTCUSD","price":"9086","size":1,"side":"Buy"},{"symbol":"BTCUSD","price":"9077","size":3855,"side":"Buy"},{"symbol":"BTCUSD","price":"9076","size":2500,"side":"Buy"},{"symbol":"BTCUSD","price":"9075","size":1515,"side":"Buy"},{"symbol":"BTCUSD","price":"9074","size":11419,"side":"Buy"},{"symbol":"BTCUSD","price":"9073","size":500,"side":"Buy"},{"symbol":"BTCUSD","price":"9070.5","size":727,"side":"Buy"},{"symbol":"BTCUSD","price":"9070","size":6786,"side":"Buy"},{"symbol":"BTCUSD","price":"9068","size":10057,"side":"Buy"},{"symbol":"BTCUSD","price":"9067.5","size":5200,"side":"Buy"},{"symbol":"BTCUSD","price":"9067","size":50,"side":"Buy"},{"symbol":"BTCUSD","price":"9066.5","size":433,"side":"Buy"}, Test.IsEqual JsonResult("ret_msg"), "OK", "orderbook 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("result").Count > 0, "orderbook 2 failed, result: ${1}" Test.IsEqual JsonResult("result")(1)("symbol"), "BTCUSD", "orderbook 3 failed, result: ${1}" Test.Includes Array("Buy", "Sell"), JsonResult("result")(1)("side"), "orderbook 4 failed, result: ${1}" 'GET all tickers -> add a parameter like above to only get one TestResult = PublicBybit("tickers", "GET") 'e.g. {"ret_code":0,"ret_msg":"OK","ext_code":"","ext_info":"","result":[{"symbol":"BTCUSD","bid_price":"9176","ask_price":"9176.5","last_price":"9176.00","last_tick_direction":"MinusTick","prev_price_24h":"7624.50","price_24h_pcnt":"0.203488","high_price_24h":"10558.00","low_price_24h":"7624.00","prev_price_1h":"9250.50","price_1h_pcnt":"-0.008053","mark_price":"9174.56","index_price":"9174.02","open_interest":98256174,"open_value":"10936.65","total_turnover":"11422803.74","turnover_24h":"476498.44","total_volume":106760806255,"volume_24h":4369471987,"funding_rate":"0.000168","predicted_funding_rate":"0.000352","next_funding_time":"2019-10-26T16:00:00Z","countdown_hour":3},{"symbol":"ETHUSD","bid_price":"180.2","ask_price":"180.25","last_price":"180.20","last_tick_direction":"MinusTick","prev_price_24h":"166.60","price_24h_pcnt":"0.081632","high_price_24h":"199.85","low_price_24h":"166.50","prev_price_1h":"181.65","price_1h_pcnt":"-0.007982","mark_price":"180.49","index_price":"180.48", Test.IsEqual JsonResult("ret_msg"), "OK", "tickers 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("result").Count > 0, "tickers 2 failed, result: ${1}" Test.IsOk Val(JsonResult("result")(1)("bid_price")) > 0, "tickers 3 failed, result: ${1}" Test.IsOk Val(JsonResult("result")(1)("prev_price_24h")) > 0, "tickers 4 failed, result: ${1}" Dim Params1a As New Dictionary Dim LimitTime As Double Dim ResTime As Long Params1a.Add "symbol", "BTCUSD" Params1a.Add "interval", 60 'TimeFrame in minutes Params1a.Add "limit", 2 LimitTime = Round(GetBybitTime() / 1000, 0) - 60 * 60 * 2 'GetByBitTime returns time in ms (microseconds, 13 digits), and this function takes seconds (10 digits) 'In order to get the past 2 hours, deduct that time in seconds: interval*limit*60 Params1a.Add "from", LimitTime TestResult = PublicBybit("kline/list", "GET", Params1a) Test.IsEqual JsonResult("ret_msg"), "OK", "kline 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("result").Count > 0, "kline 2 failed, result: ${1}" Test.IsEqual JsonResult("result")(1)("symbol"), "BTCUSD", "kline 3 failed, result: ${1}" Test.IsOk Val(JsonResult("result")(1)("high")) > 0, "kline 4 failed, result: ${1}" 'ResTime = JsonResult("result")(1)("open_time") 'Debug.Print ResTime, UnixTimeToDate(ResTime) 'ResTime = JsonResult("result")(2)("open_time") 'Debug.Print ResTime, UnixTimeToDate(ResTime) ' Create a new test Set Test = Suite.Test("TestBybitTime") TestResult = GetBybitTime() Test.IsOk TestResult > 1500000000000#, "bybit time 1 failed, result: ${1}" Test.IsOk TestResult < 1600000000000#, "bybit time 2 failed, result: ${1}" Set Test = Suite.Test("TestBybitPrivate") 'Api key properties TestResult = PrivateBybit("open-api/api-key", "GET", Cred) 'e.g. {"ret_code":0,"ret_msg":"ok","ext_code":"","result":[{"api_key":"Tc5aI32WaSqSD","user_id":619,"ips":["192.168.1.1"],"note":"ExcelBybit","permissions":["Order","Position"],"created_at":"2019-10-26T10:16:38.000Z","read_only":false}],"ext_info":null,"time_now":"1572103275.354790","rate_limit_status":99,"rate_limit_reset":1572103275} Test.IsOk InStr(TestResult, "ret_msg") > 0 'Debug.Print TestResult Set JsonResult = JsonConverter.ParseJson(TestResult) If JsonResult("ret_msg") = "ok" Then Test.IsOk Len(JsonResult("result")(1)("api_key")) >= 10 Test.IsOk JsonResult("result")(1)("user_id") > 0 Else 'E.g. IP-address block Test.IsEqual Left(JsonResult("ret_msg"), 12), "unmatched IP" Test.IsUndefined JsonResult("result") End If 'Example set leverage Dim Params2 As New Dictionary Params2.Add "symbol", "ETHUSD" Params2.Add "leverage", 1 TestResult = PrivateBybit("user/leverage/save", "POST", Cred, Params2) 'Debug.Print TestResult 'e.g. {"ret_code":0,"ret_msg":"ok","ext_code":"","result":2,"ext_info":null,"time_now":"1572104006.055933","rate_limit_status":74,"rate_limit_reset":1572104006} 'or {"ret_code":34015,"ret_msg":"cannot set leverage which is same to the old leverage","ext_code":"","result":null,"ext_info":null,"time_now":"1572103987.614015","rate_limit_status":72,"rate_limit_reset":1572103987} Test.IsOk InStr(TestResult, "ret_msg") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) If JsonResult("ret_msg") = "ok" Then Test.IsEqual JsonResult("ret_msg"), "ok" Test.IsEqual JsonResult("result"), 1 'same as input leverage Else 'Assume leverage is the same as before Test.IsEqual JsonResult("ret_msg"), "cannot set leverage which is same to the old leverage" Test.IsUndefined JsonResult("result") End If 'Example set leverage Tm = GetBybitTime() 'e.g. 1583401823000 -> milliseconds Hrs = 24 Dim Params3 As New Dictionary Params3.Add "symbol", "ETHUSD" Params3.Add "limit", 1 Params3.Add "start_time", Tm - 3600000 * Hrs TestResult = PrivateBybit("v2/private/execution/list", "GET", Cred, Params3) 'Debug.Print Tm 'Debug.Print TestResult '{"ret_code":0,"ret_msg":"OK","ext_code":"","ext_info":"","result":{"order_id":"","trade_list":null},"time_now":"1583400361.063716","rate_limit_status":119,"rate_limit_reset_ms":1583400361061,"rate_limit":120} '/v2/private/execution/list End Sub Function PublicBybit(Method As String, ReqType As String, Optional ParamDict As Dictionary) As String Dim url As String PublicApiSite = "https://api.bybit.com/v2/public/" 'symbols, orderBook/L2 +symbol , time, tickers (+symbol) MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams urlPath = Method & MethodParams url = PublicApiSite & urlPath PublicBybit = WebRequestURL(url, ReqType) End Function Function PrivateBybit(Method As String, ReqType As String, Credentials As Dictionary, Optional ParamDict As Dictionary) As String Dim NonceUnique As String Dim postdata As String Dim postdataUrl As String Dim postdataJSON As String Dim url As String 'Get a 10-digit Nonce NonceUnique = GetBybitTime() TradeApiSite = "https://api.bybit.com/" url = TradeApiSite & Method Dim PostDict As New Dictionary PostDict.Add "api_key", Credentials("apiKey") PostDict.Add "timestamp", NonceUnique If Not ParamDict Is Nothing Then For Each key In ParamDict.Keys PostDict(key) = ParamDict(key) Next key End If 'Sort alphabetically Call SortDictByKey(PostDict) 'All parameters are in the PostDict dictionary, merge them to a string MsgToSign = DictToString(PostDict, "URLENC") APIsign = ComputeHash_C("SHA256", MsgToSign, Credentials("secretKey"), "STRHEX") PostDict.Add "sign", APIsign If UCase(ReqType) = "GET" Then MethodParams = DictToString(PostDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams contentFormat = "application/x-www-form-urlencoded" ElseIf UCase(ReqType) = "POST" Then postdataJSON = JsonConverter.ConvertToJson(ParamDict) contentFormat = "application/json" MethodParams = "" Else 'Wrong Method, error out Exit Function End If Dim headerDict As New Dictionary headerDict.Add "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)" headerDict.Add "Content-Type", contentFormat url = TradeApiSite & Method & MethodParams PrivateBybit = WebRequestURL(url, ReqType, headerDict, postdataJSON) End Function Function GetBybitTime() As Double Dim BybitTime As String Dim ValBybitTime As Double Dim JsonResponse As String Dim Json As Object 'PublicBybit time, 13 digit (ms) JsonResponse = PublicBybit("time", "GET") Set Json = JsonConverter.ParseJson(JsonResponse) BybitTime = Left(Json("time_now"), InStr(Json("time_now"), ".") - 1) & "000" If Len(BybitTime) = 0 Then TimeCorrection = -3600 ValBybitTime = DateDiff("s", "1/1/1970", Now) + TimeCorrection BybitTime = Trim(Str(ValBybitTime) & Right(Int(Timer * 100), 2) & "0") End If 'Debug.Print BybitTime GetBybitTime = Val(BybitTime) Set Json = Nothing End Function ================================================ FILE: ModExchCoinbase.bas ================================================ Attribute VB_Name = "ModExchCoinbase" Sub TestCoinbase() 'Standard Coinbase, for CoinbasePro (formerly known as GDAX), see that Module 'https://developers.coinbase.com/api/v2#introduction 'Source: https://github.com/krijnsent/crypto_vba 'Remember to create a new API key for excel/VBA Dim Apikey As String Dim secretKey As String Apikey = "your api key here" secretKey = "your secret key here" 'Remove these 3 lines, unless you define 3 constants somewhere ( Public Const secretkey_gdax = "the key to use everywhere" etc ) Apikey = apikey_coinbase secretKey = secretkey_coinbase 'Put the credentials in a dictionary Dim Cred As New Dictionary Cred.Add "apiKey", Apikey Cred.Add "secretKey", secretKey ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModExchCoinbase" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestCoinbasePublic") 'Error, unknown command TestResult = PublicCoinbase("AnUnknownCommand", "GET") '{"error_nr":404,"error_txt":"HTTP-Not Found","response_txt":{"errors":[{"id":"not_found","message":"Not found"}]}} Test.IsOk InStr(TestResult, "error") > 0, "test UnknownCommand 1a failed, result: ${1}" Test.IsOk InStr(TestResult, "not_found") > 0, "test UnknownCommand 1b failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 404, "test UnknownCommand 1c failed, result: ${1}" 'Request wrong parameter Dim Params As New Dictionary Params.Add "currency", "XY" TestResult = PublicCoinbase("exchange-rates", "GET", Params) '{"error_nr":400,"error_txt":"HTTP-Bad Request","response_txt":{"errors":[{"id":"invalid_request","message":"Invalid currency (X)"}]}} Test.IsOk InStr(TestResult, "error") > 0, "test Rates 1a failed, result: ${1}" Test.IsOk InStr(TestResult, "invalid_request") > 0, "test Rates 1b failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 400, "test Rates 1c failed, result: ${1}" 'Simpel request without parameters TestResult = PublicCoinbase("currencies", "GET") '{"data":[{"id":"AED","name":"United Arab Emirates Dirham","min_size":"0.01000000"},{"id":"AFN","name":"Afghan Afghani","min_size":"0.01000000"},{"id":"ALL","name":"Albanian Lek","min_size":"0.01000000"}, Test.IsOk InStr(TestResult, "min_size") > 0, "test Currencies 1a failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("data").Count >= 20, "test Currencies 1b failed, result: ${1}" Test.IsEqual JsonResult("data")(1)("id"), "AED", "test Currencies 1c failed, result: ${1}" Test.IsEqual JsonResult("data")(1)("name"), "United Arab Emirates Dirham", "test Currencies 1d failed, result: ${1}" Test.IsEqual Val(JsonResult("data")(1)("min_size")), 0.01, "test Currencies 1e failed, result: ${1}" 'Request with parameter Dim Params2 As New Dictionary Params2.Add "currency", "ETH" TestResult = PublicCoinbase("exchange-rates", "GET", Params2) '{"data":{"currency":"ETH","rates":{"AED":"503.843775","AFN":"10260.72100155","ALL":"15205.84875","AMD":"66996.080561325","ANG":"250.3323036", etc Test.IsOk InStr(TestResult, "EUR") > 0, "test Rates 2a failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("data")("currency"), "ETH", "test Rates 2b failed, result: ${1}" Test.IsEqual Val(JsonResult("data")("rates")("ETH")), 1, "test Rates 2c failed, result: ${1}" Test.IsOk Val(JsonResult("data")("rates")("USD")) > 0, "test Rates 2d failed, result: ${1}" 'Coinbase time TestResult = GetCoinbaseTime Test.IsOk TestResult > 1550000000, "test Time failed, result: ${1}" Set Test = Suite.Test("TestCoinbasePrivate") TestResult = PrivateCoinbase("accounts", "GET", Cred) 'Debug.Print TestResult '{"pagination":{"ending_before":null,"starting_after":null,"limit":25,"order":"desc","previous_uri":null,"next_uri":null},"data":[{"id":"0cdbaac7-da83-5b85-0fe555be0b48","name":"EUR-wallet","primary":false,"type":"fiat","currency":{"code":"EUR","name":"Euro","color":"#0066cf","sort_index":0,"exponent":2,"type":"fiat"},"balance":{"amount":"0.00","currency":"EUR"},"created_at":"2017-12-27T16:57:41Z","updated_at":"2017-12-27T16:57:41Z","resource":"account","resource_path":"/v2/accounts/0cdbaac7-da83-5b85-b647-0fe402be0b48","allow_deposits":true,"allow_withdrawals":true},{"id":"0a3c2dfc-1c62-190b-abef-fbba3102c89b","name":"LTC-wallet","primary":true,"type":"wallet", etc... Test.IsOk InStr(TestResult, "currency") > 0 Test.IsOk InStr(TestResult, "warnings") > 0 Test.IsOk InStr(TestResult, "balance") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("pagination")("limit"), 74 Test.IsOk JsonResult("data").Count >= 1 Test.IsEqual JsonResult("warnings")(1)("id"), "missing_version" 'user with CB-VERSION (API client version you can add to your requests to make sure you have the same version as you checked online, but no response is given 'Request with CB-VERSION Dim Params3 As New Dictionary Params3.Add "CB-VERSION", "2005-05-05" TestResult = PrivateCoinbase("user", "GET", Cred, Params3) '{"data":{"id":"3c7-12505bcbf174","name":"Koen Rijnsent","username":null,"profile_location":null,"profile_bio":null,"profile_url":null,"avatar_url":"https://res.cloudinary.com/coinbase/image/upload/c_fill,h_128,w_128/heg.png","resource":"user","resource_path":"/v2/user","email":"donotmailthis@here.com","time_zone":"Pacific Time (US \u0026 Canada)","native_currency":"EUR","bitcoin_unit":"BTC","state":null,"country":{"code":"NL","name":"Netherlands","is_in_europe":true},"region_supports_fiat_transfers":true,"region_supports_crypto_to_crypto_transfers":true,"created_at":"2008-01-01T16:51:09Z","tiers":{"completed_description":"Level 1","upgrade_button_text":null,"header":null,"body":null},"referral_money":{"amount":"8.90","currency":"EUR","currency_symbol":""}}} Test.IsEqual InStr(TestResult, "warnings"), 0 Test.IsOk InStr(TestResult, "profile_location") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk Len(JsonResult("data")("id")) > 10 Test.IsOk Len(JsonResult("data")("native_currency")) >= 3 'Update the default currency to EUR Dim Params4 As New Dictionary Params4.Add "CB-VERSION", "2005-05-05" Params4.Add "native_currency", "EUR" TestResult = PrivateCoinbase("user", "PUT", Cred, Params4) '{"data":{"id":"3c7-12505bcbf174","name":"Koen Rijnsent","username":null,"profile_location":null,"profile_bio":null,"profile_url":null,"avatar_url":"https://res.cloudinary.com/coinbase/image/upload/c_fill,h_128,w_128/heg.png","resource":"user","resource_path":"/v2/user","email":"donotmailthis@here.com","time_zone":"Pacific Time (US \u0026 Canada)","native_currency":"EUR","bitcoin_unit":"BTC","state":null,"country":{"code":"NL","name":"Netherlands","is_in_europe":true},"region_supports_fiat_transfers":true,"region_supports_crypto_to_crypto_transfers":true,"created_at":"2008-01-01T16:51:09Z","tiers":{"completed_description":"Level 1","upgrade_button_text":null,"header":null,"body":null},"referral_money":{"amount":"8.90","currency":"EUR","currency_symbol":""}}} Test.IsEqual InStr(TestResult, "warnings"), 0 Test.IsOk InStr(TestResult, "profile_location") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk Len(JsonResult("data")("id")) > 10 Test.IsEqual JsonResult("data")("referral_money")("currency"), "EUR" 'Buy order that errors out Dim Params5 As New Dictionary Params5.Add "CB-VERSION", "2005-05-05" Params5.Add "amount", 3 Params5.Add "currency", "BTC" Params5.Add "quote", "true" TestResult = PrivateCoinbase("accounts/the_right_account_here/buys", "POST", Cred, Params5) 'error with account: {"error_nr":400,"error_txt":"HTTP-Bad Request","response_txt":{"errors":[{"id":"invalid_request","message":"Can't buy with this account"}]}} 'unknown account id: {"error_nr":404,"error_txt":"HTTP-Not Found","response_txt":{"errors":[{"id":"not_found","message":"Not found"}]}} Test.IsOk InStr(TestResult, "errors") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("response_txt")("errors").Count >= 1 End Sub Function PublicCoinbase(Method As String, ReqType As String, Optional ParamDict As Dictionary) As String Dim url As String PublicApiSite = "https://api.coinbase.com" MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams urlPath = "/v2/" & Method & MethodParams url = PublicApiSite & urlPath PublicCoinbase = WebRequestURL(url, ReqType) End Function Function PrivateCoinbase(Method As String, ReqType As String, Credentials As Dictionary, Optional ParamDict As Dictionary) As String Dim NonceUnique As String Dim url As String Dim CBVersion As String Dim MethodParams As String 'Get a 10-digit Nonce NonceUnique = GetCoinbaseTime TradeApiSite = "https://api.coinbase.com/v2/" 'If a CB-VERSION is present, put it in a variable and remove it from the Parameter dictionary CBVersion = "" MethodParams = "" If Not ParamDict Is Nothing Then If ParamDict.Exists("CB-VERSION") Then CBVersion = ParamDict("CB-VERSION") ParamDict.Remove "CB-VERSION" End If 'Change the rest of the parameters to JSON MethodParams = JsonConverter.ConvertToJson(ParamDict) If MethodParams = "{}" Then MethodParams = "" End If SignMsg = NonceUnique & UCase(ReqType) & "/v2/" & Method & MethodParams APIsign = ComputeHash_C("SHA256", SignMsg, Credentials("secretKey"), "STRHEX") Dim headerDict As New Dictionary headerDict.Add "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)" headerDict.Add "Content-Type", "application/json" headerDict.Add "CB-ACCESS-KEY", Credentials("apiKey") headerDict.Add "CB-ACCESS-SIGN", APIsign headerDict.Add "CB-ACCESS-TIMESTAMP", NonceUnique If CBVersion <> "" Then headerDict.Add "CB-VERSION", CBVersion End If url = TradeApiSite & Method PrivateCoinbase = WebRequestURL(url, ReqType, headerDict, MethodParams) End Function Function GetCoinbaseTime() As Double Dim JsonResponse As String Dim Json As Object JsonResponse = PublicCoinbase("time", "GET") Set Json = JsonConverter.ParseJson(JsonResponse) GetCoinbaseTime = Int(Json("data")("epoch")) If GetCoinbaseTime = 0 Then TimeCorrection = -3600 GetCoinbaseTime = CreateNonce(10) GetCoinbaseTime = Trim(Str((Val(GetCoinbaseTime) + TimeCorrection)) & Right(Int(Timer * 100), 2) & "0") End If Set Json = Nothing End Function ================================================ FILE: ModExchCoinbasePro.bas ================================================ Attribute VB_Name = "ModExchCoinbasePro" Sub TestCoinbasePro() 'CoinbasePro, formerly known as GDAX 'For normal Coinbase, see the Coinbase API 'API docs: https://docs.pro.coinbase.com/ 'Source: https://github.com/krijnsent/crypto_vba 'Remember to create a new API key for excel/VBA Dim Apikey As String Dim secretKey As String Dim passphrase As String Apikey = "your api key here" secretKey = "your secret key here" passphrase = "your passphrase here" 'Remove these 3 lines, unless you define 3 constants somewhere ( Public Const secretkey_gdax = "the key to use everywhere" etc ) Apikey = apikey_coinbase_pro secretKey = secretkey_coinbase_pro passphrase = passphrase_coinbase_pro 'Put the credentials in a dictionary Dim Cred As New Dictionary Cred.Add "apiKey", Apikey Cred.Add "secretKey", secretKey Cred.Add "Passphrase", passphrase ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModExchCoinbasePro" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestCoinbaseProPublic") 'Error, unknown command TestResult = PublicCoinbasePro("AnUnknownCommand", "GET") '{"error_nr":401,"error_txt":"HTTP-Unauthorized","response_txt":{"message":"CB-ACCESS-KEY header is required"}} Test.IsOk InStr(TestResult, "message") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 401 Test.IsEqual JsonResult("response_txt")("message"), "Unauthorized." 'Request wrong parameters Dim Params As New Dictionary Params.Add "level", 5 TestResult = PublicCoinbasePro("products/BTC-USD/book", "GET", Params) '{"error_nr":400,"error_txt":"HTTP-Bad Request","response_txt":{"message":"Bad Request"}} Test.IsOk InStr(TestResult, "message") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 400 Test.IsEqual JsonResult("response_txt")("message"), "unexpected level: _" 'Request with parameter Dim Params2 As New Dictionary Params2.Add "level", 1 TestResult = PublicCoinbasePro("products/ETH-EUR/book", "GET", Params2) '{"sequence":2052119022,"bids":[["118.04","200.16128756",5]],"asks":[["118.05","30.06104554",4]]} Test.IsOk InStr(TestResult, "asks") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("sequence") > 1 Test.IsEqual JsonResult("bids").Count, 1 Test.IsEqual JsonResult("asks").Count, 1 'Coinbase time TestResult = GetCoinbaseProTime Test.IsOk TestResult > 1550000000 Set Test = Suite.Test("TestCoinbaseProPrivate") TestResult = PrivateCoinbasePro("accounts", "GET", Cred) '[{"id":"8a06fcff-f233-4b2a-b333-ec2ccd727956","currency":"BTC","balance":"0.0000000000000000","available":"0","hold":"0.0000000000000000","profile_id":"2c-015-61806709e17"},{"id":"b9d028fa-748a-9fa3-9df9b877457d","currency":"LTC","balance":"0.0000000000000000","available":"0","hold":" etc... Test.IsOk InStr(TestResult, "profile_id") > 0 Test.IsOk InStr(TestResult, "balance") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult.Count > 1 Test.IsEqual JsonResult(1)("currency"), "BAT" Test.IsOk JsonResult(1)("balance") >= 0 Dim Params8 As New Dictionary Params8.Add "size", 0.01 Params8.Add "price", 100.1 Params8.Add "side", "buy" Params8.Add "product_id", "BTC-EUR" TestResult = PrivateCoinbasePro("orders", "POST", Cred, Params8) If InStr(TestResult, "error_txt") > 0 Then 'Error result, assume insufficient funds, but could also be Product not found '{"error_nr":400,"error_txt":"HTTP-Bad Request","response_txt":{"message":"Insufficient funds"}} Test.IsOk InStr(TestResult, "response_txt") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("response_txt")("message"), "Insufficient funds" Else 'Normal result '{"id": "d0c5340b-6d6c-49d9-b567-48c4bfca13d2","price": "100.10000000","size": "0.01000000","product_id": "BTC-EUR","side": "buy","stp": "dc","type": "limit","time_in_force": "GTC","post_only": false,"created_at": "2016-12-08T20:02:28.53864Z","fill_fees": "0.0000000000000000","filled_size": "0.00000000","executed_value": "0.0000000000000000","status": "pending","settled": false} Test.IsOk InStr(TestResult, "created_at") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk Len(JsonResult("id")) > 10 Test.IsEqual JsonResult("product_id"), "BTC-EUR" End If 'Delete all BTC-EUR orders Dim Params3 As New Dictionary Params3.Add "product_id", "BTC-EUR" TestResult = PrivateCoinbasePro("orders", "DELETE", Cred, Params3) 'No orders to delete: [] Test.IsEqual TestResult, "[]" 'Withdraw one BAT to an invalid account Dim Params4 As New Dictionary Params4.Add "amount", 1 Params4.Add "currency", "BAT" Params4.Add "crypto_address", "0x0" TestResult = PrivateCoinbasePro("withdrawals/crypto", "POST", Cred, Params4) 'E.g. {"error_nr":403,"error_txt":"HTTP-Forbidden","response_txt":{"message":"Forbidden"}} Test.IsOk InStr(TestResult, "Forbidden") > 0 Dim Params5 As New Dictionary Params5.Add "product_id", "ETH-USD" TestResult = PrivateCoinbasePro("fills", "GET", Cred, Params5) Test.IsEqual TestResult, "[]" '{"error_nr":401,"error_txt":"HTTP-Unauthorized","response_txt":{"message":"invalid signature"}} End Sub Function PublicCoinbasePro(Method As String, ReqType As String, Optional ParamDict As Dictionary) As String Dim url As String PublicApiSite = "https://api.pro.coinbase.com" MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams urlPath = "/" & Method & MethodParams url = PublicApiSite & urlPath PublicCoinbasePro = WebRequestURL(url, ReqType) End Function Function PrivateCoinbasePro(Method As String, ReqType As String, Credentials As Dictionary, Optional ParamDict As Dictionary) As String Dim NonceUnique As String Dim url As String Dim MethodParams As String 'Get a 10-digit Nonce NonceUnique = GetCoinbaseProTime TradeApiSite = "https://api.pro.coinbase.com" 'Change the parameters to JSON HEREHERE If ReqType = "GET" Then MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams Else 'e.g. POST MethodParams = JsonConverter.ConvertToJson(ParamDict) If MethodParams = "{}" Then MethodParams = "" End If SignMsg = NonceUnique & UCase(ReqType) & "/" & Method & "" & MethodParams APIsign = Base64Encode(ComputeHash_C("SHA256", SignMsg, Base64Decode(Credentials("secretKey")), "RAW")) Dim headerDict As New Dictionary headerDict.Add "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)" headerDict.Add "Content-Type", "application/json" headerDict.Add "CB-ACCESS-KEY", Credentials("apiKey") headerDict.Add "CB-ACCESS-SIGN", APIsign headerDict.Add "CB-ACCESS-TIMESTAMP", NonceUnique headerDict.Add "CB-ACCESS-PASSPHRASE", Credentials("Passphrase") url = TradeApiSite & "/" & Method If ReqType = "GET" Then url = url & MethodParams PrivateCoinbasePro = WebRequestURL(url, ReqType, headerDict, MethodParams) End Function Function GetCoinbaseProTime() As Double Dim JsonResponse As String Dim Json As Object 'PublicCoinbasePro time JsonResponse = PublicCoinbasePro("time", "GET") Set Json = JsonConverter.ParseJson(JsonResponse) GetCoinbaseProTime = Int(Json("epoch")) If GetCoinbaseProTime = 0 Then TimeCorrection = -3600 GetCoinbaseProTime = CreateNonce(10) GetCoinbaseProTime = Trim(Str((Val(GetGDAXTime) + TimeCorrection)) & Right(Int(Timer * 100), 2) & "0") End If Set Json = Nothing End Function ================================================ FILE: ModExchCoinone.bas ================================================ Attribute VB_Name = "ModExchCoinone" Sub TestCoinone() 'Source: https://github.com/krijnsent/crypto_vba 'https://doc.coinone.co.kr/#section/V2-version 'Remember to create a new API key for excel/VBA Dim Apikey As String Dim secretKey As String Apikey = "your api key here" secretKey = "your secret key here" 'Remove these 2 lines, unless you define 2 constants somewhere ( Public Const secretkey_btce = "the key to use everywhere" etc ) Apikey = apikey_coinone secretKey = secretkey_coinone 'Put the credentials in a dictionary Dim Cred As New Dictionary Cred.Add "apiKey", Apikey Cred.Add "secretKey", secretKey ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModExchCoinone" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestCoinonePublic") 'Error, unknown command TestResult = PublicCoinone("AnUnknownCommand", "GET") '{"error_nr":200,"error_txt":"NO JSON BUT HTML RETURNED","response_txt":0} Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_txt"), "HTTP-Found" Test.IsEqual JsonResult("error_nr"), 302 'OK request TestResult = PublicCoinone("ticker", "GET") 'e.g. {"currency":"btc","volume":"633.1048","last":"4684000.0","yesterday_last":"4636000.0","timestamp":"1554107620","yesterday_low":"4592000.0","errorCode":"0","yesterday_volume":"395.8966","high":"4720000.0","result":"success","yesterday_first":"4615000.0","first":"4636000.0","yesterday_high":"4651000.0","low":"4630000.0"} Test.IsOk InStr(TestResult, "yesterday_last") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk Val(JsonResult("last")) > 0 Test.IsEqual JsonResult("currency"), "btc" Test.IsOk Val(JsonResult("timestamp")) > 1500000000# 'Put parameters/options in a dictionary 'If no parameters are provided, the defaults are used 'If WRONG PARAMETERS are provided, the defaults will be used: the API fails "silently" and gives no error but default BTC data Dim Params As New Dictionary Params.Add "currency", "eth" Params.Add "period", "hour" TestResult = PublicCoinone("trades", "GET", Params) 'e.g. {"errorCode":"0","timestamp":"1554107995","completeOrders":[{"is_ask":"0","timestamp":"1554107949","price":"161600.0","id":"395377","qty":"1.6044"}, Test.IsOk InStr(TestResult, "completeOrders") > 0 Test.IsOk InStr(TestResult, "timestamp") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk Val(JsonResult("timestamp")) > 1500000000# Test.IsEqual JsonResult("errorCode"), "0" Test.IsEqual JsonResult("completeOrders").Count, 200 Test.IsOk Val(JsonResult("completeOrders")(1)("id")) > 0 Test.IsOk Val(JsonResult("completeOrders")(1)("qty")) > 0 Set Test = Suite.Test("TestCoinonePrivate") TestResult = PrivateCoinone2("account/balance", "POST", Cred) '{"btt": {"avail": "0.0", "balance": "0.0"}, "edna": {"avail": "0.0", "balance": "0.0"}, etc. Test.IsOk InStr(TestResult, "avail") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("result"), "success" Test.IsEqual JsonResult("errorCode"), "0" Test.IsOk JsonResult("eos")("avail") >= 0 Test.IsOk JsonResult("btc")("balance") >= 0 Dim Params2 As New Dictionary Params2.Add "price", 100 Params2.Add "qty", 3 Params2.Add "currency", "EOS" TestResult = PrivateCoinone2("order/limit_buy", "POST", Cred, Params2) '{"errorCode":"103","errorMsg":"Lack of Balance","result":"error"} '{"errorCode":"113","errorMsg":"Quantity is too low","result":"error"} '{"result": "success","errorCode": "0","orderId": "8a82c561-40b4-4cb3-9bc0-9ac9ffc1d63b"} Test.IsOk InStr(TestResult, "errorCode") > 0 Test.IsOk InStr(TestResult, "result") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) If Val(JsonResult("errorCode")) = 0 Then 'No error Test.IsEqual JsonResult("result"), "success" Test.IsEqual JsonResult("errorCode"), "0" Test.IsOk Len(JsonResult("orderId")) > 10 Else 'Error Test.IsEqual JsonResult("result"), "error" Test.IsOk Len(JsonResult("errorMsg")) > 0 End If Dim Params3 As New Dictionary Params3.Add "currency", "ETH" TestResult = PrivateCoinone2("order/complete_orders", "POST", Cred, Params3) '{"errorCode": "0", "completeOrders": [], "result": "success"} '{"result": "success","errorCode": "0","completeOrders": [{"timestamp": "1416561032","price": "419000.0","type": "bid","qty": "0.001","feeRate": "-0.0015","fee": "-0.0000015","orderId": "E84A1AC2-8088-4FA0-B093-A3BCDB9B3C85"}]} Test.IsOk InStr(TestResult, "completeOrders") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("result"), "success" Test.IsEqual JsonResult("errorCode"), "0" Test.IsOk JsonResult("completeOrders").Count >= 0 End Sub Function PublicCoinone(Method As String, ReqType As String, Optional ParamDict As Dictionary) As String Dim url As String PublicApiSite = "https://api.coinone.co.kr/" MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams urlPath = Method & MethodParams url = PublicApiSite & urlPath PublicCoinone = WebRequestURL(url, ReqType) End Function Function PrivateCoinone2(Method As String, ReqType As String, Credentials As Dictionary, Optional ParamDict As Dictionary) As String Dim NonceUnique As String Dim postdata As String Dim postdataUrl As String Dim postdataJSON As String Dim url As String 'Get a 14-digit Nonce NonceUnique = CreateNonce(14) TradeApiSite = "https://api.coinone.co.kr/v2/" url = TradeApiSite & Method Dim PostDict As New Dictionary PostDict.Add "access_token", Credentials("apiKey") PostDict.Add "nonce", NonceUnique If Not ParamDict Is Nothing Then For Each key In ParamDict.Keys PostDict(key) = ParamDict(key) Next key End If postdataUrl = DictToString(PostDict, "URLENC") postdataJSON = JsonConverter.ConvertToJson(PostDict) postdata64 = Base64Encode(postdataJSON) APIsign = ComputeHash_C("SHA512", postdata64, Credentials("secretKey"), "STRHEX") Dim headerDict As New Dictionary headerDict.Add "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)" headerDict.Add "Content-Type", "application/json" headerDict.Add "X-COINONE-PAYLOAD", postdata64 headerDict.Add "X-COINONE-SIGNATURE", APIsign url = TradeApiSite & Method PrivateCoinone2 = WebRequestURL(url, ReqType, headerDict, postdataUrl) End Function ================================================ FILE: ModExchCoinspot.bas ================================================ Attribute VB_Name = "ModExchCoinspot" Sub TestCoinspot() 'Source: https://github.com/krijnsent/crypto_vba 'Documentation: https://www.coinspot.com.au/api 'Remember to create a new API key for excel/VBA Dim Apikey As String Dim secretKey As String Apikey = "your api key here" secretKey = "your secret key here" 'Remove these 2 lines, unless you define 2 constants somewhere ( Public Const secretkey_btce = "the key to use everywhere" etc ) Apikey = apikey_coinspot secretKey = secretkey_coinspot 'Put the credentials in a dictionary Dim Cred As New Dictionary Cred.Add "apiKey", Apikey Cred.Add "secretKey", secretKey ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModExchCoinspot" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestCoinspotPublic") 'Error, unknown command TestResult = PublicCoinspot("AnUnknownCommand", "GET") '{"error_nr":404,"error_txt":"HTTP-Not Found","response_txt":0} Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 404 'Request without parameters (for Coinspot only public request) TestResult = PublicCoinspot("latest", "GET") '{"status":"ok","prices":{"btc":{"bid":"5330.10000001","ask":"5394","last":"5367"},"ltc":{"bid":"67.1","ask":"68.7","last":"68"},"doge":{"bid":"0.0027","ask":"0.0028","last":"0.0028"},"eth":{"bid":"186.11","ask":"191.99","last":"187"},"powr":{"bid":"0.133","ask":"0.1425","last":"0.14"},"ans":{"bid":"12.5","ask":"13","last":"12.5"},"xrp":{"bid":"0.44","ask":"0.449","last":"0.442"},"trx":{"bid":"0.0325","ask":"0.033999","last":"0.0327"}}} Test.IsOk InStr(TestResult, "btc") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("status"), "ok" Test.IsOk JsonResult("prices").Count >= 3 Test.IsOk JsonResult("prices")("btc")("last") > 0 Set Test = Suite.Test("TestCoinspotPrivate") TestResult = PrivateCoinspot("my/balances", "POST", Cred) 'e.g. {"status":"ok","balance":{"btc":0,"ltc":3,"doge":1000,"ppc":0,"wdc":0,"xpm":0,"max":0,"lot":0,"qrk":0,"moon":0,"ftc":0,"drk":0}} Test.IsOk InStr(TestResult, "balance") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("status"), "ok" Test.IsOk JsonResult("balance")("btc") >= 0 Test.IsOk JsonResult("balance")("doge") >= 0 'Put the parameters in a dictionary Dim Params As New Dictionary Params.Add "cointype", "DOGE" Params.Add "amount", 10000 TestResult = PrivateCoinspot("quote/buy", "POST", Cred, Params) 'e.g. {"status":"ok","quote":0.001619,"timeframe":0} Test.IsOk InStr(TestResult, "quote") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("status"), "ok" Test.IsOk JsonResult("quote") >= 0 Test.IsOk JsonResult("timeframe") >= 0 End Sub Function PublicCoinspot(Method As String, ReqType As String, Optional ParamDict As Dictionary) As String Dim url As String PublicApiSite = "https://www.coinspot.com.au" MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "&" & MethodParams urlPath = "/pubapi/" & Method & MethodOptions url = PublicApiSite & urlPath PublicCoinspot = WebRequestURL(url, ReqType) End Function Function PrivateCoinspot(Method As String, ReqType As String, Credentials As Dictionary, Optional ParamDict As Dictionary) As String Dim NonceUnique As String Dim postdata As String Dim url As String Dim PayloadDict As Dictionary Dim MethodParams As String 'Get a Nonce NonceUnique = CreateNonce() TradeApiSite = "https://www.coinspot.com.au" Set PayloadDict = New Dictionary PayloadDict("nonce") = Val(NonceUnique) If Not ParamDict Is Nothing Then For Each key In ParamDict.Keys PayloadDict(key) = ParamDict(key) Next key End If MethodParams = JsonConverter.ConvertToJson(PayloadDict) PostPath = "/api/" & Method APIsign = ComputeHash_C("SHA512", MethodParams, Credentials("secretKey"), "STRHEX") Dim headerDict As New Dictionary headerDict.Add "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)" headerDict.Add "Content-Type", "application/json" headerDict.Add "sign", APIsign headerDict.Add "key", Credentials("apiKey") url = TradeApiSite & PostPath PrivateCoinspot = WebRequestURL(url, "POST", headerDict, MethodParams) End Function ================================================ FILE: ModExchHitBTC.bas ================================================ Attribute VB_Name = "ModExchHitBTC" Sub TestHitBTC() 'Source: https://github.com/krijnsent/crypto_vba 'Remember to create a new API key for excel/VBA 'https://api.hitbtc.com/api/2/explore/ 'https://github.com/hitbtc-com/hitbtc-api#rest-api-reference 'HitBTC will require ever increasing values/nonces for the private API and the nonces created in VBA might mismatch that of other sources Dim Apikey As String Dim secretKey As String Apikey = "your api key here" secretKey = "your secret key here" 'Remove these 2 lines, unless you define 2 constants somewhere ( Public Const secretkey_HitBTC = "the key to use everywhere" etc ) Apikey = apikey_hitbtc secretKey = secretkey_hitbtc 'Put the credentials in a dictionary Dim Cred As New Dictionary Cred.Add "apiKey", Apikey Cred.Add "secretKey", secretKey ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModExchHitBTC" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestHitBTCPublic v2") 'Error, unknown command TestResult = PublicHitBTCv2("AnUnknownCommand", "GET") '{"error_nr":404,"error_txt":"HTTP-Not Found","response_txt":0} Test.IsOk InStr(TestResult, "error") > 0, "unknowncommand 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 503, "unknowncommand 2 failed, result: ${1}" 'Error, wrong parameter Dim Params As New Dictionary Params.Add "symbol", "BLABLA" TestResult = PublicHitBTCv2("trades", "GET", Params) '{"error_nr":400,"error_txt":"HTTP-Bad Request","response_txt":{"timestamp":"2021-02-09T17:30:24.738+00:00","path":"/api/2/public/trades/BLABLA","status":400,"error":{"code":2001,"description":"Try get /public/symbol, to get list of all available symbols.","message":"No such symbol: BLABLA"},"requestId":"eecd7978-102065517"}} Test.IsOk InStr(TestResult, "error") > 0, "trades params 1 failed, result: ${1}" Test.IsOk InStr(TestResult, "No such symbol") > 0, "trades params 2 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 400, "trades params 3 failed, result: ${1}" Test.IsEqual JsonResult("response_txt")("error")("code"), 2001, "trades params 4 failed, result: ${1}" 'Simple request without parameters TestResult = PublicHitBTCv2("currency", "GET") 'Example: [{"id":"DDF","fullName":"DDF","crypto":true,"payinEnabled":false,"payinPaymentId":false,"payinConfirmations":2,"payoutEnabled":true,"payoutIsPaymentId":false,"transferEnabled":true,"delisted":false,"payoutFee":"646"},{"id":"ZRX","fullName":"0x Protocol","crypto":true,"payinEnabled":true,"payinPaymentId":false,"payinConfirmations":2,"payoutEnabled":true,"payoutIsPaymentId":false,"transferEnabled":true,"delisted":false,"payoutFee":"26.45"},{"id":"ACO","fullName":"A!Coin","crypto":true etc... Test.IsOk InStr(TestResult, "payoutFee") > 0, "currency 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult.Count >= 100, "currency 2 failed, result: ${1}" Test.IsOk Len(JsonResult(1)("id")) >= 3, "currency 3 failed, result: ${1}" 'Request with parameter Dim Params2 As New Dictionary Params2.Add "currency", "ETH" TestResult = PublicHitBTCv2("currency", "GET", Params2) '{"id":"ETH","fullName":"Ethereum","crypto":true,"payinEnabled":true,"payinPaymentId":false,"payinConfirmations":2,"payoutEnabled":true,"payoutIsPaymentId":false,"transferEnabled":true,"delisted":false,"payoutFee":"0.0428"} Test.IsOk InStr(TestResult, "Ethereum") > 0, "currency params 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("id"), "ETH", "currency params 2 failed, result: ${1}" Test.IsEqual JsonResult("crypto"), True, "currency params 3 failed, result: ${1}" Test.IsEqual JsonResult("delisted"), False, "currency params 4 failed, result: ${1}" 'Request with parameters Dim Params3 As New Dictionary Params3.Add "symbol", "ETHBTC" Params3.Add "sort", "ASC" Params3.Add "limit", 10 TestResult = PublicHitBTCv2("trades", "GET", Params3) '[{"id":3462311,"price":"0.006000","quantity":"0.001","side":"buy","timestamp":"2015-08-20T19:01:23.764Z"},{"id":3462314,"price":"0.006000","quantity":"0.001","side":"buy","timestamp":"2018-07-10T16:11:35.511Z"},etc... Test.IsOk InStr(TestResult, "timestamp") > 0, "trades2 params 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult(1)("id") > 0, "trades2 params 2 failed, result: ${1}" Test.IsOk Val(JsonResult(1)("quantity")) > 0, "trades2 params 3 failed, result: ${1}" Test.IsEqual JsonResult(1)("side"), "buy", "trades2 params 4 failed, result: ${1}" Set Test = Suite.Test("TestHitBTCPrivate v2") TestResult = PrivateHitBTCv2("trading/balance", "GET", Cred) '[{"currency":"1ST","available":"0","reserved":"0"},{"currency":"8BT","available":"0","reserved":"0"},{"currency":"ABA","available":"0","reserved":"0"},{"currency":"ABTC","available":"0","reserved":"0"},{"currency":"ABYSS","available":"0","reserved":"0"} etc... Test.IsOk InStr(TestResult, "available") > 0 Test.IsOk InStr(TestResult, "reserved") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) 'Loop through all coins For Each Coin In JsonResult If Coin("available") + Coin("reserved") > 0 Then 'Debug.Print Coin("currency"), Coin("available") + Coin("reserved") Test.IsOk Len(Coin("currency")) >= 3 End If Next Coin Test.IsOk Len(JsonResult(1)("currency")) > 0 Test.IsOk Val(JsonResult(2)("available")) >= 0 Dim Params4 As New Dictionary Params4.Add "symbol", "DOGEETH" TestResult = PrivateHitBTCv2("history/trades", "GET", Cred, Params4) 'e.g. [{"id":215639995,"clientOrderId":"4ab37988ea9545aeb325fc60931fbaa3","orderId":19837911730,"symbol":"DOGEETH","side":"sell","quantity": etc. If TestResult = "[]" Then Test.IsEqual TestResult, "[]" Else Test.IsOk InStr(TestResult, "clientOrderId") > 0 Test.IsOk InStr(TestResult, "symbol") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk Len(JsonResult(1)("symbol")) >= 6 Test.IsOk JsonResult(2)("orderId") > 0 End If 'Delete all orders DOGE-ETH Dim Params5 As New Dictionary Params5.Add "symbol", "DOGEETH" TestResult = PrivateHitBTCv2("order", "DELETE", Cred, Params5) 'e.g. [{"id": 0,"clientOrderId": "d8574207d9e3b16a4a5511753eeef175","symbol": "DOGEETH","side": "sell","status": "canceled","type": "limit", etc... If InStr(TestResult, "NO VALID JSON RETURNED") > 0 Then Test.IsOk InStr(TestResult, ":200") > 0 Else If TestResult <> "[]" Then Test.IsOk InStr(TestResult, "clientOrderId") > 0 Test.IsOk InStr(TestResult, "symbol") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult(1)("symbol"), "DOGEETH" Test.IsOk Len(JsonResult(1)("side")) >= 3 End If End If 'Create an order, but trigger an error Dim Params6 As New Dictionary Params6.Add "symbol", "ETHBTC" Params6.Add "side", "sell" Params6.Add "quantity", "0.000005" Params6.Add "price", "1" TestResult = PrivateHitBTCv2("order", "POST", Cred, Params6) 'e.g. {"error_nr":400,"error_txt":"HTTP-Bad Request","response_txt":{"error":{"code":20001,"message":"Insufficient funds","description":"Check that the funds are sufficient, given commissions"}}} '{"error_nr":400,"error_txt":"HTTP-Bad Request","response_txt":{"error":{"code":2011,"message":"Quantity too low","description":"Minimum quantity 0.0001"}}} 'if OK, e.g. {"id": 0,"clientOrderId": "d8574207d9e3b16a4a5511753eeef175","symbol": "ETHBTC","side": "sell","status": "new","type": "limit","timeInForce": "GTC","quantity": "0.063","price": "0.046016","cumQuantity": "0.000","postOnly": false,"createdAt": "2017-05-15T17:01:05.092Z","updatedAt": "2017-05-15T17:01:05.092Z"} If InStr(TestResult, "clientOrderId") > 0 Then 'Shouldn't happen with current test, for successfull orders Test.IsOk InStr(TestResult, "symbol") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult(1)("symbol"), "ETHBTC" Test.IsOk Len(JsonResult(1)("side")) >= 3 Else Test.IsOk InStr(TestResult, "message") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("response_txt")("error")("code"), 2011 Test.IsEqual JsonResult("response_txt")("error")("message"), "Quantity too low" End If End Sub Function PublicHitBTCv2(Method As String, ReqType As String, Optional ParamDict As Dictionary) As String Dim url As String Dim PayloadDict As New Dictionary PublicApiSite = "https://api.hitbtc.com" 'Get special parameters currency and symbol and add them to the URL If Not ParamDict Is Nothing Then For Each key In ParamDict.Keys If LCase(key) = "currency" Or LCase(key) = "symbol" Then Method = Method & "/" & ParamDict(key) Else PayloadDict(key) = ParamDict(key) End If Next key End If MethodParams = DictToString(PayloadDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams urlPath = "/api/2/public/" & Method & MethodParams url = PublicApiSite & urlPath PublicHitBTCv2 = WebRequestURL(url, ReqType) End Function Function PrivateHitBTCv2(Method As String, ReqType As String, Credentials As Dictionary, Optional ParamDict As Dictionary) As String Dim NonceUnique As String Dim postdata As String Dim url As String Dim MethodParams As String NonceUnique = CreateNonce(10) TradeApiSite = "https://api.hitbtc.com" urlPath = "/api/2/" & Method MethodParams = DictToString(ParamDict, "URLENC") postdata = JsonConverter.ConvertToJson(ParamDict) If MethodParams <> "" Then MethodParams = "?" & MethodParams url = TradeApiSite & urlPath Dim headerDict As New Dictionary headerDict.Add "Content-Type", "application/json" 'Credentials in a special format headerDict.Add "Authorization", "Basic " & Base64Encode(Credentials("apiKey") & ":" & Credentials("secretKey")) url = TradeApiSite & urlPath & MethodParams PrivateHitBTCv2 = WebRequestURL(url, ReqType, headerDict, postdata) End Function ================================================ FILE: ModExchHuobi.bas ================================================ Attribute VB_Name = "ModExchHuobi" Sub TestHuobi() 'Source: https://github.com/krijnsent/crypto_vba 'https://alphaex-api.github.io/openapi/spot/v1/en/#introduction 'Remember to create a new API key for excel/VBA Dim Apikey As String Dim secretKey As String Apikey = "your api key here" secretKey = "your secret key here" 'Remove these 2 lines, unless you define 2 constants somewhere ( Public Const secretkey_btce = "the key to use everywhere" etc ) Apikey = apikey_huobi secretKey = secretkey_huobi 'Put the credentials in a dictionary Dim Cred As New Dictionary Cred.Add "apiKey", Apikey Cred.Add "secretKey", secretKey ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModExchHuobi" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestHuobiPublic") 'Error, unknown command TestResult = PublicHuobi("AnUnknownCommand", "GET") '{"error_nr":404,"error_txt":"HTTP-Not Found","response_txt":0} Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_txt"), "HTTP-Not Found" Test.IsEqual JsonResult("error_nr"), 404 'OK request TestResult = PublicHuobi("v1/common/timestamp", "GET") 'e.g. {"status":"ok","data":1579706923783} Test.IsOk InStr(TestResult, "data") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("status"), "ok" Test.IsOk Val(JsonResult("data")) > 1500000000000# 'Parameters missing TestResult = PublicHuobi("market/history/kline", "GET") 'e.g. {"ts":1579707152954,"status":"error","err-code":"invalid-parameter","err-msg":"invalid symbol"} Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("status"), "error" Test.IsEqual JsonResult("err-msg"), "invalid symbol" Test.IsOk Val(JsonResult("ts")) > 1500000000000# 'Put parameters/options in a dictionary 'If no parameters are provided, the defaults are used Dim Params As New Dictionary Params.Add "period", "1day" Params.Add "symbol", "btcusdt" Params.Add "size", 10 TestResult = PublicHuobi("market/history/kline", "GET", Params) 'e.g. {"status":"ok","ch":"market.btcusdt.kline.1day","ts":1579707654120,"data":[{"amount":25326.647313510339831018,"open":8645.130000000000000000,"close":8659.620000000000000000,"high":8817.730000000000000000,"id":1579622400,"count":202979,"low":8500.000000000000000000,"vol":219864523.567705105282063018560000000000000000},{"amount":17344.079067910875891838,"open":8677.970000000000000000,"close":8646.800000000000000000,"high":8744.510000000000000000,"id":1579536000,"count":153447,"low":8607.430000000000000000,"vol":150214939.669388488950943200910000000000000000},{"amount":27195.320357908427801956,"open":8632.820000000000000000,"close":8677.200000000000000000,"high":8756.040000000000000000,"id":1579449600,"count":234172,"low":8480.000000000000000000,"vol":235036539.681727868489706633830000000000000000}, Test.IsOk InStr(TestResult, "market.btcusdt.kline.1day") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk Val(JsonResult("ts")) > 1500000000000# Test.IsEqual JsonResult("status"), "ok" Test.IsEqual JsonResult("data").Count, 10 Test.IsOk Val(JsonResult("data")(1)("amount")) > 0 Test.IsOk Val(JsonResult("data")(2)("high")) > 0 Set Test = Suite.Test("TestHuobiPrivate GET") 'Simple test, should return data TestResult = PrivateHuobi("v1/account/accounts", "GET", Cred) '{"status":"ok","data":[{"id":9999,"type":"spot","subtype":"","state":"working"}]} Debug.Print TestResult Test.IsOk InStr(TestResult, "status") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("status"), "ok" Test.IsEqual JsonResult("data")(1)("state"), "working" 'Error, forgotten parameter Dim Params2 As New Dictionary Params2.Add "size", 10 TestResult = PrivateHuobi("v1/account/history", "GET", Cred, Params2) '{"status":"error","err-code":"validation-constraints-required","err-msg":"Field is missing: account-id.","data":null} Test.IsOk InStr(TestResult, "err-msg") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("status"), "error" Test.IsEqual JsonResult("err-msg"), "Field is missing: account-id." 'Unknown account-id Dim Params3 As New Dictionary Params3.Add "account-id", 9999 Params3.Add "size", 50 TestResult = PrivateHuobi("v1/account/history", "GET", Cred, Params3) '{"status":"error","err-code":"account-get-balance-account-inexistent-error","err-msg":"account for id `6,000,006` and user id `9,999` does not exist","data":null} Test.IsOk InStr(TestResult, "err-msg") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("status"), "error" Test.IsEqual JsonResult("err-code"), "account-get-balance-account-inexistent-error" Set Test = Suite.Test("TestHuobiPrivate POST") 'Get account-id: TestResult = PrivateHuobi("v1/account/accounts", "GET", Cred) Set JsonResult = JsonConverter.ParseJson(TestResult) AccId = JsonResult("data")(1)("id") 'Place order Dim Params4 As New Dictionary Params4.Add "account-id", AccId Params4.Add "amount", 1 Params4.Add "price", 1 Params4.Add "symbol", "ethusdt" Params4.Add "type", "buy-limit" TestResult = PrivateHuobi("v1/order/orders/place", "POST", Cred, Params4) '{"status":"error","err-code":"order-value-min-error","err-msg":"Order total cannot be lower than: `5`","data":null} Test.IsOk InStr(TestResult, "status") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("status"), "error" Test.IsEqual JsonResult("err-code"), "order-value-min-error" End Sub Function PublicHuobi(Method As String, ReqType As String, Optional ParamDict As Dictionary) As String Dim url As String PublicApiSite = "https://api-cloud.huobi.co.kr/" MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams urlPath = Method & MethodParams url = PublicApiSite & urlPath 'Debug.Print Url PublicHuobi = WebRequestURL(url, ReqType) End Function Function PrivateHuobi(Method As String, ReqType As String, Credentials As Dictionary, Optional ParamDict As Dictionary) As String Dim APIsign As String Dim ApiEndPoint As String Dim postdata As String Dim url As String 'Get a Timestamp Stamp = GetUTCTime() StampTxt = URLEncode(Format(Stamp, "YYYY-MM-DDThh:mm:ss")) HostTxt = "api-cloud.huobi.co.kr" HostTxt = "api.huobi.pro" TradeApiSite = "https://" & HostTxt & "/" url = TradeApiSite & Method StrHash = "" postdata = "" Dim TotDict As New Dictionary TotDict.Add "AccessKeyId", Credentials("apiKey") TotDict.Add "SignatureMethod", "HmacSHA256" TotDict.Add "SignatureVersion", 2 TotDict.Add "Timestamp", StampTxt If UCase(ReqType) = "POST" Then 'For POST request, all query parameters need to be included in the request body with JSON. (e.g. {"currency":"BTC"}). MethodParams = DictToString(TotDict, "URLENC") postdata = JsonConverter.ConvertToJson(ParamDict) 'ApiEndPoint = Url ElseIf UCase(ReqType) = "GET" Then If Not ParamDict Is Nothing Then For Each key In ParamDict.Keys TotDict(key) = ParamDict(key) Next key End If MethodParams = DictToString(TotDict, "URLENC") postdata = "" End If StrHash = UCase(ReqType) & Chr(10) & HostTxt & Chr(10) & "/" & Method & Chr(10) & MethodParams If MethodParams <> "" Then MethodParams = "?" & MethodParams ApiEndPoint = url & MethodParams 'Dim PostDict As New Dictionary 'PostDict.Add "access_token", Credentials("apiKey") 'PostDict.Add "nonce", NonceUnique 'If Not ParamDict Is Nothing Then ' For Each Key In ParamDict.Keys ' PostDict(Key) = ParamDict(Key) ' Next Key 'End If 'postdataUrl = DictToString(PostDict, "URLENC") 'postdataJSON = JsonConverter.ConvertToJson(ParamDict) 'postdata64 = Base64Encode(postdataJSON) APIsign = ComputeHash_C("SHA256", StrHash, Credentials("secretKey"), "STR64") APIsignEnc = URLEncode(APIsign) ApiEndPoint = ApiEndPoint & "&Signature=" & APIsignEnc Dim headerDict As New Dictionary headerDict.Add "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)" headerDict.Add "Content-Type", "application/json" 'Debug.Print ApiEndPoint PrivateHuobi = WebRequestURL(ApiEndPoint, ReqType, headerDict, postdata) End Function ================================================ FILE: ModExchIDEX.bas ================================================ Attribute VB_Name = "ModExchIDEX" 'https://docs.idex.market/#operation/returnCurrencies Sub TestIDEX() 'Source: https://github.com/krijnsent/crypto_vba 'Documentation: https://docs.idex.io/ 'Remember to create a new API key for excel/VBA Dim Apikey As String Apikey = "your api key here" 'Remove this lines, unless you define a constant somewhere ( Public Const apikey_idex = "the key to use everywhere" etc ) Apikey = apikey_idex 'Put the credentials in a dictionary Dim Cred As New Dictionary Cred.Add "apiKey", Apikey ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModExchIDEX" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestIDEX") 'Error, unknown command TestResult = PublicIDEX("AnUnknownCommand", "GET") '{"error_nr":404,"error_txt":"HTTP-Not Found","response_txt":{"code":"ResourceNotFound","message":"/AnUnknownCommand does not exist"}} Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 404 'Error, missing parameter TestResult = PublicIDEX("candles", "GET") '{"error_nr":400,"error_txt":"HTTP-Bad Request","response_txt":{"code":"REQUIRED_PARAMETER","message":"parameter \"market\" is required but was not provided"}} Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 400 Test.IsEqual JsonResult("response_txt")("code"), "REQUIRED_PARAMETER" 'GET ticker Dim Params As New Dictionary Params.Add "market", "ZRX-ETH" TestResult = PublicIDEX("tickers", "GET", Params) '[{"market":"ZRX-ETH","time":1612898636288,"open":null,"high":null,"low":null,"close":null,"closeQuantity":null,"baseVolume":"0.00000000","quoteVolume":"0.00000000","percentChange":"0.00","numTrades":0,"ask":"0.00191918","bid":"0.00034900","sequence":null}] Test.IsOk InStr(TestResult, "baseVolume") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult(1)("time") >= 0 End Sub Function PublicIDEX(Method As String, ReqType As String, Optional ParamDict As Dictionary) As String Dim url As String Dim postdata As String PublicApiSite = "https://api-eth.idex.io/v1/" If UCase(ReqType) = "POST" Then 'For POST request, all query parameters need to be included in the request body with JSON. (e.g. {"currency":"BTC"}). postdata = JsonConverter.ConvertToJson(ParamDict) ElseIf UCase(ReqType) = "GET" Then MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams ApiEndPoint = ApiEndPoint & MethodParams postdata = "" End If urlPath = "/" & Method & MethodParams url = PublicApiSite & urlPath Dim headerDict As New Dictionary headerDict.Add "Content-Type", "application/json" PublicIDEX = WebRequestURL(url, ReqType, headerDict, postdata) End Function Function PrivateIDEX(Method As String, ReqType As String, Credentials As Dictionary, Optional ParamDict As Dictionary) As String 'Work in Progress End Function ================================================ FILE: ModExchKraken.bas ================================================ Attribute VB_Name = "ModExchKraken" Sub TestKraken() 'Source: https://github.com/krijnsent/crypto_vba 'Remember to create a new API key for excel/VBA 'Kraken will require ever increasing values/nonces for the private API and the nonces created in VBA might mismatch that of other sources 'https://www.kraken.com/en-us/help/api#public-market-data 'https://www.kraken.com/help/api#private-user-data Dim Apikey As String Dim secretKey As String Apikey = "your api key here" secretKey = "your secret key here" 'Remove these 2 lines, unless you define 2 constants somewhere ( Public Const secretkey_kraken = "the key to use everywhere" etc ) Apikey = apikey_kraken secretKey = secretkey_kraken 'Put the credentials in a dictionary Dim Cred As New Dictionary Cred.Add "apiKey", Apikey Cred.Add "secretKey", secretKey ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModExchKraken" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestKrakenPublic") 'Error, unknown command TestResult = PublicKraken("AnUnknownCommand", "GET") '{"error_nr":404,"error_txt":"HTTP-Not Found","response_txt":{"error":["EGeneral:Unknown method"]}} Test.IsOk InStr(TestResult, "error") > 0, "test error 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 404, "test error 2 failed, result: ${1}" 'Error, parameter missing TestResult = PublicKraken("Ticker", "GET") '{"error":["EGeneral:Invalid arguments"]} Test.IsOk InStr(TestResult, "Invalid") > 0, "test error 3 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error")(1), "EGeneral:Invalid arguments", "test error 4 failed, result: ${1}" 'Ok request without parameters TestResult = PublicKraken("Time", "GET") 'Example: {"error":[],"result":{"unixtime":1551737935,"rfc1123":"Mon, 4 Mar 19 22:18:55 +0000"}} Test.IsOk InStr(TestResult, "unixtime") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("result")("unixtime") >= 1510000000 Dim Params As New Dictionary Params.Add "pair", "XXBTZEUR" TestResult = PublicKraken("OHLC", "GET", Params) '{"error":[],"result":{"XXBTZEUR":[[1551695100,"3265.8","3265.8","3265.2","3265.2","3265.5","0.53688049",12],[1551695160,"3265.2", etc... Test.IsOk InStr(TestResult, "XXBTZEUR") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("result")("XXBTZEUR")(1)(1) >= 1510000000 Set Test = Suite.Test("TestKrakenPrivate") TestResult = PrivateKraken("Balance", "POST", Cred) '{"error":[],"result":{"ZEUR":"15.35","KFEE":"935","XXBT": etc... Test.IsOk InStr(TestResult, "ZEUR") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("result")("KFEE") >= 0 'Unix time period: t1 = DateToUnixTime("1/1/2016") t2 = DateToUnixTime("1/1/2018") Dim Params2 As New Dictionary Params2.Add "start", t1 Params2.Add "end", t2 TestResult = PrivateKraken("TradesHistory", "POST", Cred, Params2) '{"error":[],"result":{"trades":{"TBSI6I-EO4KN-MLU4AI":{"ordertxid":"O7AERY-NCNDR-6WKLMU","pair":"XXMRZEUR","time":1493715960.4854,"type":"buy","ordertype":"limit","price": etc... Test.IsOk InStr(TestResult, "trades") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("result")("trades").Count >= 0 End Sub Function PublicKraken(Method As String, ReqType As String, Optional ParamDict As Dictionary) As String Dim url As String PublicApiSite = "https://api.kraken.com" MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams urlPath = "/0/public/" & Method & MethodParams url = PublicApiSite & urlPath PublicKraken = WebRequestURL(url, ReqType) End Function Function PrivateKraken(Method As String, ReqType As String, Credentials As Dictionary, Optional ParamDict As Dictionary) As String Dim NonceUnique As String Dim postdata As String Dim PayloadDict As Dictionary Dim url As String 'Kraken nonce: 16 characters NonceUnique = CreateNonce(16) TradeApiSite = "https://api.kraken.com" urlPath = "/0/private/" & Method Set PayloadDict = New Dictionary If Not ParamDict Is Nothing Then For Each key In ParamDict.Keys PayloadDict(key) = ParamDict(key) Next key End If PayloadDict("nonce") = NonceUnique postdata = DictToString(PayloadDict, "URLENC") url = TradeApiSite & urlPath APIsign = ComputeHash_C("SHA512", urlPath & ComputeHash_C("SHA256", NonceUnique & postdata, "", "RAW"), Base64Decode(Credentials("secretKey")), "STR64") Dim headerDict As New Dictionary headerDict.Add "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)" headerDict.Add "Content-Type", "application/x-www-form-urlencoded" headerDict.Add "API-Key", Credentials("apiKey") headerDict.Add "API-Sign", APIsign PrivateKraken = WebRequestURL(url, ReqType, headerDict, postdata) End Function ================================================ FILE: ModExchKucoin.bas ================================================ Attribute VB_Name = "ModExchKucoin" Sub TestKucoin() 'Source: https://github.com/krijnsent/crypto_vba 'https://docs.kucoin.com/ 'Remember to create a new API key for excel/VBA 'Kucoin will require ever increasing values/nonces for the private API and the nonces created in VBA might mismatch that of other sources Dim Apikey As String Dim secretKey As String Apikey = "your api key here" secretKey = "your secret key here" 'Remove these 2 lines, unless you define 2 constants somewhere ( Public Const secretkey_Kucoin = "the key to use everywhere" etc ) Apikey = apikey_kucoin secretKey = secretkey_kucoin passphrase = passphrase_kucoin 'Put the credentials in a dictionary Dim Cred As New Dictionary Cred.Add "apiKey", Apikey Cred.Add "secretKey", secretKey Cred.Add "Passphrase", passphrase ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModExchKucoin" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestKucoinPublic") 'Error, unknown command TestResult = PublicKucoin("AnUnknownCommand", "GET") Test.IsOk InStr(TestResult, "error") > 0, "test error 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 404, "test error 2 failed, result: ${1}" 'Error, missing parameters TestResult = PublicKucoin("market/orderbook/level1", "GET") Test.IsOk InStr(TestResult, "error") > 0, "test error 3 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 400, "test error 4 failed, result: ${1}" TestResult = PublicKucoin("market/allTickers", "GET") '{"code":"200000","data":{"ticker":[{"symbol":"LOOM-BTC","high":"0.00001204","vol":"39738.31683935","last":"0.00001187","low":"0.00001151","buy":"0.00001172","sell":"0.00001187","changePrice":"0.00000025","changeRate":"0.0215"},etc... Test.IsOk InStr(TestResult, "code") > 0 Test.IsOk InStr(TestResult, "changePrice") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("code") * 1, 200000 Test.IsOk JsonResult("data")("ticker").Count > 100 Test.IsOk Len(JsonResult("data")("ticker")(9)("symbol")) > 0 Test.IsOk JsonResult("data")("ticker")(3)("vol") > 0 Dim Params As New Dictionary Params.Add "symbol", "KCS-BTC" TestResult = PublicKucoin("market/orderbook/level2_20", "GET", Params) '{"code":"200000","data":{"sequence":"1550467431550","asks":[["0.00011794","184.4706"],["0.00011795","48.7387"],["0.00011796","154.9647"], Test.IsOk InStr(TestResult, "code") > 0 Test.IsOk InStr(TestResult, "sequence") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("code") * 1, 200000 Test.IsOk JsonResult("data")("time") > 1500000000000# Test.IsEqual JsonResult("data")("asks").Count, 20 Test.IsEqual JsonResult("data")("bids").Count, 20 Test.IsOk JsonResult("data")("asks")(1)(1) > 0 Test.IsOk JsonResult("data")("asks")(1)(2) > 0 ' Create a new test Set Test = Suite.Test("TestKucoinTime") TestResult = GetKucoinTime() Test.IsOk TestResult > 1500000000000#, "test time 1 failed, result: ${1}" Test.IsOk TestResult < 1700000000000#, "test time 2 failed, result: ${1}" Set Test = Suite.Test("TestKucoinPrivate") TestResult = PrivateKucoin("accounts", "GET", Cred) '{"code":"200000","data":[{"balance":"15.827819","available":"15.827819","holds":"0","currency":"KCS","id":"5c6a4a1d81a34e1da97","type":"trade"},{"balance":"2.12058951","available":"2.12058951",", etc... Test.IsOk InStr(TestResult, "code") > 0, "test accounts 1a failed, result: ${1}" Test.IsOk InStr(TestResult, "balance") > 0, "test accounts 1b failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("code") * 1, 200000, "test accounts 1c failed, result: ${1}" Test.IsOk JsonResult("data").Count > 20, "test accounts 1d failed, result: ${1}" Test.IsOk JsonResult("data")(1)("balance") > 0, "test accounts 1e failed, result: ${1}" 'Get only KCS account amount Dim Params1 As New Dictionary Params1.Add "currency", "KCS" TestResult = PrivateKucoin("accounts", "GET", Cred, Params1) 'Debug.Print TestResult '{"code":"200000","data":[{"balance":"15.82887819","available":"15.82887819","holds":"0","currency":"KCS","id":"5c6a4a1d81a34e1da97","type":"trade"}]} Test.IsOk InStr(TestResult, "code") > 0, "test accounts 2a failed, result: ${1}" Test.IsOk InStr(TestResult, "balance") > 0, "test accounts 2b failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("code") * 1, 200000, "test accounts 2c failed, result: ${1}" Test.IsOk JsonResult("data").Count >= 1, "test accounts 2d failed, result: ${1}" Test.IsOk JsonResult("data")(1)("balance") > 0, "test accounts 2e failed, result: ${1}" 'Create a main LTC account (if it doesn't exist) Dim Params2 As New Dictionary Params2.Add "currency", "LTC" TestResult = PrivateKucoin("accounts", "POST", Cred, Params2) 'Debug.Print TestResult '{"code":"400100","msg":"type can not be empty"} Test.IsOk InStr(TestResult, "code") > 0 Test.IsOk InStr(TestResult, "msg") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("code") * 1, 400100 Test.IsEqual JsonResult("msg"), "type can not be empty" Params2.Add "type", "main" TestResult = PrivateKucoin("accounts", "POST", Cred, Params2) 'Debug.Print TestResult 'FIRST TIME RESULT: {"code":"200000","data":{"id":"5c7556e3cbfc7b24a1a1a1a9"}} 'NEXT RESULT: {"code":"230005","msg":"account already exists"} Test.IsOk InStr(TestResult, "code") > 0 Test.IsOk InStr(TestResult, "msg") + InStr(TestResult, "data") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("code") * 1 >= 200000 Test.IsOk JsonResult("code") * 1 <= 230005 Set Test = Suite.Test("TestKucoinPrivate Orders") 'Create orders 'sell 0.01 KCS for a price of 100 KCS per ETH 'price hopefully insane enough never to execute TempOrderID = CreateNonce() Dim Params3 As New Dictionary Params3.Add "clientOid", TempOrderID Params3.Add "symbol", "KCS-ETH" Params3.Add "side", "sell" Params3.Add "price", 100 Params3.Add "size", 0.01 Params3.Add "timeInForce", "GTC" TestResult = PrivateKucoin("orders", "POST", Cred, Params3) 'Debug.Print TestResult '{"code":"200000","data":{"orderId":"5ca22ec6513ab9576fb77d92"}} '{"code":"200004","msg":"Balance insufficient!"} Test.IsOk InStr(TestResult, "code") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("code") * 1 >= 200000 Test.IsOk JsonResult("code") * 1 <= 200004 'Add another order Dim Params4 As New Dictionary Params4.Add "clientOid", TempOrderID + 3 Params4.Add "symbol", "KCS-BTC" Params4.Add "side", "sell" Params4.Add "price", 100 Params4.Add "size", 0.01 Params4.Add "timeInForce", "GTC" TestResult = PrivateKucoin("orders", "POST", Cred, Params4) 'Debug.Print TestResult '{"code":"200000","data":{"orderId":"5ca22ec6513ab9576fb77d92"}} '{"code":"200004","msg":"Balance insufficient!"} Test.IsOk InStr(TestResult, "code") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("code") * 1 >= 200000 Test.IsOk JsonResult("code") * 1 <= 200004 'Now get the open orders TestResult = PrivateKucoin("orders", "GET", Cred) '{"code":"200000","data":{"totalNum":8,"totalPage":1,"pageSize":50,"currentPage":1,"items":[{"symbol":"KCS-BTC","hidden":false,"opType":"DEAL" Test.IsOk InStr(TestResult, "code") > 0 Test.IsOk InStr(TestResult, "totalPage") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("code") * 1 >= 200000 Test.IsOk JsonResult("code") * 1 <= 200004 Test.IsOk JsonResult("data")("items").Count >= 0 'Delete all KCS-BTC orders Dim Params5 As New Dictionary Params5.Add "symbol", "KCS-BTC" TestResult = PrivateKucoin("orders", "DELETE", Cred, Params5) '{"code":"200000","data":{"cancelledOrderIds":["5ca2798389fc8450590fe207"]}} Test.IsOk InStr(TestResult, "code") > 0 Test.IsOk InStr(TestResult, "cancelledOrderIds") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("code") * 1 >= 200000 Test.IsOk JsonResult("code") * 1 <= 200004 'Delete the created KCS-ETH order Dim Params6 As New Dictionary Params6.Add "OrderId", JsonResult("data")("orderId") TestResult = PrivateKucoin("orders", "DELETE", Cred, Params6) 'Debug.Print TestResult '{"code":"200000","data":{"cancelledOrderIds":["5ca27982054b467eb0d0c8dc"]}} Test.IsOk InStr(TestResult, "code") > 0 Test.IsOk InStr(TestResult, "cancelledOrderIds") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("code") * 1 >= 200000 Test.IsOk JsonResult("code") * 1 <= 200004 'Delete all orders (should be none) TestResult = PrivateKucoin("orders", "DELETE", Cred) '{"code":"200000","data":{"cancelledOrderIds":[]}} Test.IsOk InStr(TestResult, "code") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("code") * 1 >= 200000 Test.IsOk JsonResult("code") * 1 <= 200004 End Sub Function PublicKucoin(Method As String, ReqType As String, Optional ParamDict As Dictionary) As String Dim url As String PublicApiSite = "https://api.kucoin.com/api/v1" MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams urlPath = "/" & Method & MethodParams url = PublicApiSite & urlPath PublicKucoin = WebRequestURL(url, ReqType) End Function Function PrivateKucoin(Method As String, ReqType As String, Credentials As Dictionary, Optional ParamDict As Dictionary) As String Dim NonceUnique As String Dim url As String Dim postdata As String 'Kucoin wants a 13-digit Nonce, use time correction if needed NonceUnique = GetKucoinTime() TradeApiSite = "https://api.kucoin.com" ApiEndPoint = "/api/v1/" & Method If ReqType = "GET" Or ReqType = "DELETE" Then 'For GET, DELETE request, all query parameters need to be included in the request url. (e.g. /api/v1/accounts?currency=BTC) If Not ParamDict Is Nothing Then 'OrderId -> add to URL For Each key In ParamDict.Keys If LCase(key) = "orderid" Then ApiEndPoint = ApiEndPoint & "/" & ParamDict(key) ParamDict.Remove key Exit For End If Next key End If MethodTxt = DictToString(ParamDict, "URLENC") If MethodTxt <> "" Then ApiEndPoint = ApiEndPoint & "?" & MethodTxt ReqBody = "" Else 'For POST, PUT request, all query parameters need to be included in the request body with JSON. (e.g. {"currency":"BTC"}). Do not include extra spaces in JSON strings. MethodTxt = "" ReqBody = JsonConverter.ConvertToJson(ParamDict) postdata = ReqBody End If ApiForSign = NonceUnique & ReqType & ApiEndPoint & ReqBody APIsign = ComputeHash_C("SHA256", ApiForSign, Credentials("secretKey"), "STR64") url = TradeApiSite & ApiEndPoint Dim headerDict As New Dictionary headerDict.Add "KC-API-KEY", Credentials("apiKey") headerDict.Add "KC-API-SIGN", APIsign headerDict.Add "KC-API-TIMESTAMP", NonceUnique headerDict.Add "KC-API-PASSPHRASE", Credentials("Passphrase") headerDict.Add "Content-Type", "application/json" PrivateKucoin = WebRequestURL(url, ReqType, headerDict, postdata) End Function Function GetKucoinTime() As Double Dim JsonResponse As String Dim Json As Object 'PublicKucoin time JsonResponse = PublicKucoin("timestamp", "GET") Set Json = JsonConverter.ParseJson(JsonResponse) GetKucoinTime = Json("data") If GetKucoinTime = 0 Then TimeCorrection = -3600 GetKucoinTime = DateDiff("s", "1/1/1970", Now) GetKucoinTime = Trim(Str((Val(GetKucoinTime) + TimeCorrection)) & Right(Int(Timer * 100), 2) & "0") End If Set Json = Nothing End Function ================================================ FILE: ModExchOKEx.bas ================================================ Attribute VB_Name = "ModExchOkex" Sub TestOKEx() 'Source: https://github.com/krijnsent/crypto_vba 'https://www.okex.com/docs/en/ 'Remember to create a new API key for excel/VBA Dim Apikey As String Dim secretKey As String Apikey = "your api key here" secretKey = "your secret key here" 'Remove these 2 lines, unless you define 2 constants somewhere ( Public Const secretkey_okex = "the key to use everywhere" etc ) Apikey = apikey_okex secretKey = secretkey_okex passphrase = passphrase_okex 'Put the credentials in a dictionary Dim Cred As New Dictionary Cred.Add "apiKey", Apikey Cred.Add "secretKey", secretKey Cred.Add "Passphrase", passphrase ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModExchOKEx" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestOKExPublic") 'Error, unknown command, returns invalid JSON TestResult = PublicOKEx("AnUnknownCommand", "GET") Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 403 'Error, missing parameter TestResult = PublicOKEx("spot/v3/instruments/EOS-BTC/", "GET") Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 404 'Error, unknown pair TestResult = PublicOKEx("spot/v3/instruments/EOS-BLA/ticker", "GET") Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 400 Test.IsEqual JsonResult("response_txt")("code"), 30032 Test.IsEqual JsonResult("response_txt")("message"), "The currency pair does not exist" TestResult = PublicOKEx("spot/v3/instruments/ticker", "GET") '[{"best_ask":"0.006388","best_bid":"0.006387","instrument_id":"LTC-BTC","product_id":"LTC-BTC","last":"0.006387","ask":"0.006388","bid":"0.006387","open_24h":"0.006532","high_24h":"0.006727","low_24h":"0.006359","base_volume_24h":"221873.685698","timestamp":"2019-09-04T09:31:50.304Z","quote_volume_24h":"1445.8081"},{"best_ask":"0.01685","best_bid":"0.01684","instrument_id":"ETH-BTC","product_id":"ETH-BTC" etc... Test.IsOk InStr(TestResult, "best_bid") > 0 Test.IsOk InStr(TestResult, "product_id") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult.Count > 100 Test.IsOk JsonResult(1)("last") * 1 > 0 Test.IsOk Len(JsonResult(2)("instrument_id")) > 0 Dim Params As New Dictionary Params.Add "granularity", 14400 '14400 seconds = 6 hours Params.Add "start", "2020-12-15T08%3A28%3A48.899Z" 'ISO 8601 Params.Add "end", "2020-12-19T09%3A28%3A48.899Z" TestResult = PublicOKEx("spot/v3/instruments/ETH-USDT/candles", "GET", Params) 'Result: TOHLCV '[["2019-03-19T08:00:00.000Z","137.74","138.69","137.38","137.79","107365.43315"],["2019-03-19T04:00:00.000Z","137.76","138","136.97","137.73","85020.919026"],["2019-03-19T00:00:00.000Z","137.61","139.41","137.31","137.74","94292.72983"],["2019-03-18T20:00:00.000Z","137.44","138.33","137.42","137.63","63587.691327"],["2019-03-18T16:00:00.000Z","137.59","137.91","137.09","137.42","58001.277483"],["2019-03-18T12:00:00.000Z","137.27","138.03","137","137.6","83512.951662"]] Test.IsOk InStr(TestResult, "2020-12-19") > 0 Test.IsOk InStr(TestResult, "2020-12-18") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult(1)(1), "2020-12-19T08:00:00.000Z" Test.IsEqual JsonResult(1)(2), "648.67" Test.IsEqual JsonResult.Count, 24 ' Create a new test Set Test = Suite.Test("TestOKExTime") TestResult = GetOKExTime() Test.IsOk TestResult > 1500000000# Test.IsOk TestResult < 1700000000# Set Test = Suite.Test("TestOKExPrivate") TestResult = PrivateOKEx("spot/v3/accounts", "GET", Cred) '[{"frozen":"0","hold":"0","id":"","currency":"BTC","balance":"0","available":"0","holds":"0"},{"frozen":"0","hold":"0","id":"","currency":"XAS","balance":"0.000233","available":"0.000233","holds":"0"}] Test.IsOk InStr(TestResult, "currency") > 0 Test.IsOk InStr(TestResult, "balance") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult.Count >= 2 Test.IsOk JsonResult(1)("balance") * 1 >= 0 Test.IsOk JsonResult(1)("holds") * 1 >= 0 'Invalid token TestResult = PrivateOKEx("account/v3/wallet/BLA", "GET", Cred) '{"error_nr":400,"error_txt":"HTTP-","response_txt":{"code":30031,"message":"BLA is an invalid token"}} Test.IsOk InStr(TestResult, "error") > 0 Test.IsOk InStr(TestResult, 30031) > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("response_txt")("code"), 30031 Test.IsEqual JsonResult("response_txt")("message"), "BLA is an invalid token" Set Test = Suite.Test("TestOKExPrivate Orders") 'Create order 'BUY 100 BTC for a price of 1 USDT per BTC 'price hopefully insane enough never to execute Dim Params2 As New Dictionary Params2.Add "instrument_id", "BTC-USDT" Params2.Add "type", "limit" Params2.Add "side", "buy" Params2.Add "price", 1 Params2.Add "size", 100 Params2.Add "order_type", 3 '3-Immediate Or Cancel TestResult = PrivateOKEx("spot/v3/orders", "POST", Cred, Params2) 'e.g. {"client_oid":"","error_code":"33017","error_message":"Greater than the maximum available balance","order_id":"-1","result":false} Test.IsOk InStr(TestResult, "code") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("error_code") * 1 = 33017 Test.IsOk JsonResult("error_message") = "Greater than the maximum available balance" Dim Params3 As New Dictionary Params3.Add "instrument_id", "XMR-BTC" ClientIdOrderId = "12345" TestResult = PrivateOKEx("spot/v3/cancel_orders/" & ClientIdOrderId, "POST", Cred, Params3) '{"client_oid":"","code":"33014","error_code":"33014","error_message":"Order does not exist","message":"Order does not exist","order_id":"12345","result":false} Test.IsOk InStr(TestResult, "code") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("code") * 1 = 33014 Test.IsOk JsonResult("message") = "Order does not exist" Dim Params4 As New Dictionary Params4.Add "instrument_id", "XMR-BTC" Params4.Add "limit", 4 TestResult = PrivateOKEx("spot/v3/orders_pending", "GET", Cred, Params4) '[] (no orders), [[{"client_oid":"oktspot86","created_at":"2019-03-20T03:28:14.000Z",etc... If TestResult = "[]" Then 'No orders Else Test.IsOk InStr(TestResult, "created_at") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult(1)("instrument_id") = "XMR-BTC" Test.IsOk Len(JsonResult(1)("order_id")) > 0 End If Dim Params5 As New Dictionary instrument_id = "XAS-BTC" Params5.Add "instrument_id", instrument_id JsonResponse = PrivateOKEx("spot/v3/fills", "GET", Cred, Params5) 'e.g. [] If TestResult = "[]" Then 'No orders Else Test.IsOk InStr(TestResult, "created_at") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult(1)("instrument_id") = "XAS-BTC" End If End Sub Function PublicOKEx(Method As String, ReqType As String, Optional ParamDict As Dictionary) As String Dim url As String PublicApiSite = "https://www.okex.com/api" MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams urlPath = "/" & Method & MethodParams url = PublicApiSite & urlPath PublicOKEx = WebRequestURL(url, ReqType) End Function Function PrivateOKEx(Method As String, ReqType As String, Credentials As Dictionary, Optional ParamDict As Dictionary) As String Dim NonceUnique As String Dim url As String Dim postdata As String TradeApiSite = "https://www.okex.com" ApiEndPoint = "/api/" & Method 'OKEx nonce NonceUnique = GetOKExTime() & ".00" 'Should be string If UCase(ReqType) = "POST" Then 'For POST request, all query parameters need to be included in the request body with JSON. (e.g. {"currency":"BTC"}). postdata = JsonConverter.ConvertToJson(ParamDict) ElseIf UCase(ReqType) = "GET" Then MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams ApiEndPoint = ApiEndPoint & MethodParams End If ApiForSign = NonceUnique & UCase(ReqType) & ApiEndPoint & postdata APIsign = ComputeHash_C("SHA256", ApiForSign, Credentials("secretKey"), "STR64") url = TradeApiSite & ApiEndPoint Dim headerDict As New Dictionary headerDict.Add "OK-ACCESS-KEY", Credentials("apiKey") headerDict.Add "OK-ACCESS-SIGN", APIsign headerDict.Add "OK-ACCESS-TIMESTAMP", NonceUnique headerDict.Add "OK-ACCESS-PASSPHRASE", Credentials("Passphrase") headerDict.Add "Content-Type", "application/json" PrivateOKEx = WebRequestURL(url, ReqType, headerDict, postdata) End Function Function GetOKExTime() As Double Dim JsonResponse As String Dim Json As Object 'PublicOKEx time JsonResponse = PublicOKEx("general/v3/time", "GET") Set Json = JsonConverter.ParseJson(JsonResponse) If InStr(Json("epoch"), ".") Then GetOKExTime = Left(Json("epoch"), InStr(Json("epoch"), ".")) Else GetOKExTime = Json("epoch") End If If GetOKExTime = 0 Then TimeCorrection = -3600 GetOKExTime = DateDiff("s", "1/1/1970", Now) GetOKExTime = Trim(Str((Val(GetOKExTime) + TimeCorrection)) & Right(Int(Timer * 100), 2) & "0") End If Set Json = Nothing End Function ================================================ FILE: ModExchPoloniex.bas ================================================ Attribute VB_Name = "ModExchPoloniex" Sub TestPoloniex() 'Source: https://github.com/krijnsent/crypto_vba 'Remember to create a new API key for excel/VBA 'https://docs.poloniex.com/#http-api 'Poloniex will require ever increasing values/nonces for the private API and the nonces created in VBA might mismatch that of other sources Dim Apikey As String Dim secretKey As String Apikey = "your api key here" secretKey = "your secret key here" 'Remove these 2 lines, unless you define 2 constants somewhere ( Public Const secretkey_poloniex = "the key to use everywhere" etc ) Apikey = apikey_poloniex secretKey = secretkey_poloniex 'Put the credentials in a dictionary Dim Cred As New Dictionary Cred.Add "apiKey", Apikey Cred.Add "secretKey", secretKey ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModExchPoloniex" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestPoloniexPublic") 'Error, unknown command TestResult = PublicPoloniex("returnUnknownCommand", "GET") '{"error":"Invalid command."} Test.IsOk InStr(TestResult, "error") > 0, "test error 1 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error"), "Invalid command.", "test error 2 failed, result: ${1}" 'Error, missing parameters TestResult = PublicPoloniex("returnOrderBook", "GET") '{"error":"Please specify a currency pair."} Test.IsOk InStr(TestResult, "error") > 0, "test error 3 failed, result: ${1}" Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error"), "Please specify a currency pair.", "test error 4 failed, result: ${1}" 'Testing error catching and replies TestResult = PublicPoloniex("returnTicker", "GET") '{"BTC_BCN":{"id":7,"last":"0.00000120","lowestAsk":"0.00000120","highestBid":"0.00000119","percentChange":"1.00000000","baseVolume":"21570.44763887","quoteVolume":"21082615430.89178085", etc... Test.IsOk InStr(TestResult, "lowestAsk") > 0 Test.IsOk InStr(TestResult, "BTC_ETH"":") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error"), "" Test.IsEqual JsonResult("BTC_ETH")("id"), 148 Test.IsOk JsonResult("BTC_ETH")("highestBid") > 0 'Put the parameters in a dictionary Dim Params As New Dictionary Params.Add "currencyPair", "BTC_ETH" Params.Add "depth", 10 TestResult = PublicPoloniex("returnOrderBook", "GET", Params) '{"asks":[["0.03530499",1.18647302],["0.03530500",110.78279995],["0.03531880",0.70796807],["0.03534095",2.12187844],["0.03534099",0.11553593],["0.03534767",29.95566069],["0.03534768",3.99999999],["0.03535000",0.99900001],["0.03535497",14.16571992],["0.03535498",0.6221801]],"bids":[["0.03528822",0.0031],["0.03528813",0.06749181],["0.03528730",0.0674917],["0.03528711",0.0674917],["0.03528638",0.0673596],["0.03528531",0.01],["0.03528303",0.01417112],["0.03527231",16.12158867],["0.03527000",110.5868],["0.03526147",33.74922032]],"isFrozen":"0","seq":644421713} Test.IsOk InStr(TestResult, "],[") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("asks").Count, 10 Test.IsEqual JsonResult("bids").Count, 10 Test.IsOk JsonResult("asks")(1)(2) > 0 'Unix time period: Set Test = Suite.Test("TestPoloniexPrivate") t1 = DateToUnixTime("1/1/2016") t2 = DateToUnixTime("1/1/2019") TestResult = PrivatePoloniex("returnBalances", "POST", Cred) '{"1CR":"0.00000000","ABY":"0.00000000","AC":"0.00000000","ACH":"0.00000000","ADN":"0.00000000","AEON":"0.00000000" etc... Test.IsOk InStr(TestResult, "BTC") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult.Count >= 10 Test.IsOk JsonResult("ETH") >= 0 'Put the parameters in a dictionary Dim Params2 As New Dictionary Params2.Add "currencyPair", "all" Params2.Add "start", t1 Params2.Add "end", t2 TestResult = PrivatePoloniex("returnTradeHistory", "POST", Cred, Params2) If InStr(TestResult, "globalTradeID") > 0 Then 'has some results 'e.g.: {"BTC_ETH":[{"globalTradeID":108848981,"tradeID":"22880801","date":"2017-04-19 23:26:55","rate":"0.03900000","amount":"65.35644222","total":"2.54890124", etc... Test.IsOk InStr(TestResult, "amount") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) For Each k In JsonResult.Keys() Test.IsOk JsonResult(k).Count >= 1 Next k Else 'no results 'Empty: [] Test.IsEqual TestResult, "[]" End If 'Put the parameters in a dictionary Dim Params3 As New Dictionary Params3.Add "currencyPair", "BTC_ETH" Params3.Add "rate", 0.001 Params3.Add "amount", 3 Params3.Add "fillOrKill", 1 TestResult = PrivatePoloniex("buy", "POST", Cred, Params3) '{"error":"This API key does not have permission to trade."} '{orderNumber: '514845991795',resultingTrades:[{amount: '3.0',Date: '2018-10-25 23:03:21',rate:'0.0002',total:'0.0006',tradeID:'251834',type:'buy'}]} '{"error":"Not enough BTC.","fee":"0.00125000","currencyPair":"BTC_ETH"} If InStr(TestResult, "error") > 0 Then Test.IsOk InStr(TestResult, "currencyPair") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error"), "Not enough BTC." Else Test.IsOk InStr(TestResult, "resultingTrades") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("orderNumber") >= 0 End If End Sub Function PublicPoloniex(Method As String, ReqType As String, Optional ParamDict As Dictionary) As String Dim url As String PublicApiSite = "https://poloniex.com" MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "&" & MethodParams urlPath = "/public?command=" & Method & MethodParams url = PublicApiSite & urlPath PublicPoloniex = WebRequestURL(url, ReqType) End Function Function PrivatePoloniex(Method As String, ReqType As String, Credentials As Dictionary, Optional ParamDict As Dictionary) As String Dim NonceUnique As String Dim postdata As String Dim PayloadDict As Dictionary Dim url As String 'Poloniex nonce NonceUnique = CreateNonce(16) url = "https://poloniex.com/tradingApi" Set PayloadDict = New Dictionary PayloadDict("command") = Method If Not ParamDict Is Nothing Then For Each key In ParamDict.Keys PayloadDict(key) = ParamDict(key) Next key End If PayloadDict("&nonce") = NonceUnique postdata = DictToString(PayloadDict, "URLENC") APIsign = ComputeHash_C("SHA512", postdata, Credentials("secretKey"), "STRHEX") Dim headerDict As New Dictionary headerDict.Add "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)" headerDict.Add "Content-Type", "application/x-www-form-urlencoded" headerDict.Add "Key", Credentials("apiKey") headerDict.Add "Sign", APIsign PrivatePoloniex = WebRequestURL(url, ReqType, headerDict, postdata) End Function ================================================ FILE: ModFunctions.bas ================================================ Attribute VB_Name = "ModFunctions" Declare PtrSafe Sub GetSystemTime Lib "kernel32" (ByRef lpSystemTime As SYSTEMTIME) Type SYSTEMTIME wYear As Integer wMonth As Integer wDayOfWeek As Integer wDay As Integer wHour As Integer wMinute As Integer wSecond As Integer wMilliseconds As Integer End Type 'Functions in module: 'DateToUnixTime - retuns the UnixTime of a date/time 'UnixTimeToDate - returns the date/time of a UnixTime 'TransposeArr - Custom transpose function, worksheetfunction.transpose won't handle long strings 'URLEncode - especially for Excel 2013 and before, afterwards it's a standard function 'Source: https://github.com/krijnsent/crypto_vba Sub TestFunctions() ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModFunctions" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("CreateNonce") TestResult = CreateNonce() Test.IsOk TestResult > 151802369827# Test.IsEqual Len(TestResult), 12 TestResult = CreateNonce("10") Test.IsOk TestResult > 1518023698 Test.IsEqual Len(TestResult), 10 TestResult = CreateNonce(3) Test.IsOk TestResult >= 151 Test.IsEqual Len(TestResult), 3 TestResult = CreateNonce(15) Test.IsOk TestResult > 151802369827000# Test.IsEqual Len(TestResult), 15 Set Test = Suite.Test("DateToUnixTime") TestResult = DateToUnixTime(#4/26/2017#) Test.IsEqual TestResult, 1493164800 Test.IsEqual Len(TestResult), 10 TestResult = DateToUnixTime(Now) Test.IsOk TestResult > 1511958343 Test.IsEqual Len(TestResult), 10 Set Test = Suite.Test("UnixTimeToDate") TestResult = UnixTimeToDate(1493164800) Test.IsEqual TestResult, #4/26/2017# Test.IsEqual Len(TestResult), 9 TestResult = UnixTimeToDate(1511958343) Test.IsEqual TestResult, #11/29/2017 12:25:43 PM# Test.IsEqual Len(TestResult), 19 Set Test = Suite.Test("TransposeArr") ' Declare a two dimensional array, Fill the array with text made up of i and j values Dim TestArr(1 To 3, 1 To 2) As Variant Dim i As Long, j As Long For i = LBound(TestArr) To UBound(TestArr) For j = LBound(TestArr, 2) To UBound(TestArr, 2) TestArr(i, j) = CStr(i) & ":" & CStr(j) Next j Next i FlipArr = TransposeArr(TestArr) Test.IsEqual TestArr(1, 2), "1:2" Test.IsEqual TestArr(1, 2), FlipArr(2, 1) 'Test URLEncode Set Test = Suite.Test("URLEncode") TestResult = URLEncode("http://www.github.com/") Test.IsEqual TestResult, "http%3A%2F%2Fwww.github.com%2F" TestResult = URLEncode("https://github.com/search?q=crypto_vba&type=") Test.IsEqual TestResult, "https%3A%2F%2Fgithub.com%2Fsearch%3Fq%3Dcrypto_vba%26type%3D" 'TestDictToString 'Only works for 1-level Dicts, for multilevel, use JsonConverter.ConvertToJson(testDict) Set Test = Suite.Test("TestDictToString") Dim testDict As New Dictionary 'Empty Dict TestResult = DictToString(testDict, "JSON") Test.IsEqual TestResult, "{}" 'Unknown type TestResult = DictToString(testDict, "-") Test.IsEqual TestResult, "UNKNOWN_TYPE" 'Fill dictionary testDict.Add "option1", "BTC-ETH" testDict.Add "another_option", "16" JsonTxt = "{""option1"":""BTC-ETH"",""another_option"":""16""}" TestResult = DictToString(testDict, "JSON") Test.IsEqual TestResult, JsonTxt UrlTxt = "option1=BTC-ETH&another_option=16" TestResult = DictToString(testDict, "URLENC") Test.IsEqual TestResult, UrlTxt Dim testDict2 As New Dictionary 'Fill dictionary testDict2.Add "value1", 9 testDict2.Add "value_2", 0.154 testDict2.Add "value_as_string", "1.87" testDict2.Add "commaval_as_str", "2,16" TestResult = DictToString(testDict2, "JSON") JsonTxt = "{""value1"":9,""value_2"":0.154,""value_as_string"":""1.87"",""commaval_as_str"":""2,16""}" Test.IsEqual TestResult, JsonTxt TestResult = DictToString(testDict2, "URLENC") UrlTxt = "value1=9&value_2=0.154&value_as_string=1.87&commaval_as_str=2,16" Test.IsEqual TestResult, UrlTxt 'TestSortDict Set Test = Suite.Test("TestSortDict") 'Function: Sort dictionaries Dim testDict3 As New Dictionary 'Fill dictionary testDict3.Add "d", 9 testDict3.Add "e", 0.154 testDict3.Add "c", "1.87" testDict3.Add "b", "2,16" 'Sort normally Call SortDictByKey(testDict3) Test.IsEqual testDict3.Count, 4 Test.IsEqual testDict3.Keys(0), "b" Test.IsEqual testDict3.Keys(3), "e" Test.IsEqual testDict3.Items(3), 0.154 'Sort desc Call SortDictByKey(testDict3, False) Test.IsEqual testDict3.Count, 4 Test.IsEqual testDict3.Keys(0), "e" Test.IsEqual testDict3.Keys(3), "b" Test.IsEqual testDict3.Items(3), "2,16" End Sub Function DateToUnixTime(dt) As Long DateToUnixTime = 0 On Error Resume Next DateToUnixTime = DateDiff("s", "1/1/1970", dt) On Error GoTo 0 End Function Function UnixTimeToDate(ts As Long) As Date 'http://www.vbforums.com/showthread.php?513727-RESOLVED-Convert-Unix-Time-to-Date&p=3168062&viewfull=1#post3168062 Dim intDays As Integer, intHours As Integer, intMins As Integer, intSecs As Integer intDays = ts \ 86400 intHours = (ts Mod 86400) \ 3600 intMins = (ts Mod 3600) \ 60 intSecs = ts Mod 60 UnixTimeToDate = DateSerial(1970, 1, intDays + 1) + TimeSerial(intHours, intMins, intSecs) End Function Function CreateNonce(Optional NonceLength As Integer = 12) As String Dim ScsLng As Long ScsLng = Int(Timer() * 100) NonceUnique = DateDiff("s", "1/1/1970", Now) If NonceLength >= 12 Then CreateNonce = NonceUnique & Right(ScsLng, 2) & String(NonceLength - 12, "0") ElseIf NonceLength >= 1 Then CreateNonce = Left(NonceUnique & Right(ScsLng, 2), NonceLength) Else CreateNonce = 0 End If End Function Function GetUTCTime() As Date Dim t As SYSTEMTIME Dim currentime As String GetSystemTime t currentTime = t.wYear & "/" & t.wMonth & "/" & t.wDay & " " & t.wHour & ":" & t.wMinute & ":" & t.wSecond GetUTCTime = currentTime End Function Function TransposeArr(ArrIn As Variant) 'Custom transpose function, worksheetfunction.transpose won't handle long strings 'It will give error 13, https://stackoverflow.com/questions/23315252/vba-tranpose-type-mismatch-error Dim TempArr As Variant ReDim TempArr(1 To UBound(ArrIn, 2), 1 To UBound(ArrIn, 1)) For i = 1 To UBound(ArrIn, 2) For j = 1 To UBound(ArrIn, 1) TempArr(i, j) = ArrIn(j, i) Next Next TransposeArr = TempArr End Function Public Function URLEncode(StringVal As String, Optional SpaceAsPlus As Boolean = False) As String 'https://stackoverflow.com/questions/218181/how-can-i-url-encode-a-string-in-excel-vba Dim StringLen As Long: StringLen = Len(StringVal) If StringLen > 0 Then ReDim Result(StringLen) As String Dim i As Long, CharCode As Integer Dim Char As String, Space As String If SpaceAsPlus Then Space = "+" Else Space = "%20" For i = 1 To StringLen Char = Mid$(StringVal, i, 1) CharCode = Asc(Char) Select Case CharCode Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126 Result(i) = Char Case 32 Result(i) = Space Case 0 To 15 Result(i) = "%0" & Hex(CharCode) Case Else Result(i) = "%" & Hex(CharCode) End Select Next i URLEncode = Join(Result, "") End If End Function Function DictToString(DictIn As Dictionary, OutputType As String) As String Dim OutputTxt As String Dim ValStr As String If DictIn Is Nothing Then DictToString = "" Exit Function End If If OutputType = "JSON" Then OutputTxt = "{" For Each opt In DictIn.Keys() If OutputTxt <> "{" Then OutputTxt = OutputTxt & "," 'If a string came in, put double quotes around it ValD = DictIn(opt) Separ = "" If VarType(ValD) = vbString Then Separ = """" 'Value: correct for comma decimal system if a value was supplied ValStr = ValD If VarType(ValD) <> vbString Then ValStr = Replace(ValStr, ",", ".") OutputTxt = OutputTxt & """" & opt & """" & ":" & Separ & ValStr & Separ Next OutputTxt = OutputTxt & "}" ElseIf OutputType = "URLENC" Then OutputTxt = "" For Each opt In DictIn.Keys() If OutputTxt <> "" Then OutputTxt = OutputTxt & "&" ValD = DictIn(opt) ValStr = ValD If VarType(ValD) <> vbString Then ValStr = Replace(ValStr, ",", ".") OutputTxt = OutputTxt & opt & "=" & ValStr Next Else OutputTxt = "UNKNOWN_TYPE" End If DictToString = OutputTxt End Function Sub SortDictByKey(DictIn As Dictionary, Optional SortAsc As Boolean = True) 'Default: sort dictionary Ascending by Key 'Inspired by https://excelmacromastery.com/vba-dictionary/#Sorting_the_Dictionary Dim ResDict As New Dictionary Set arrayList = CreateObject("System.Collections.ArrayList") 'Exit if DictIn is empty or only has max 1 item If DictIn Is Nothing Then Exit Sub Else If DictIn.Count <= 1 Then Exit Sub End If End If ' Put keys in array and sort (asc/desc) For Each key In DictIn.Keys arrayList.Add key Next key arrayList.Sort If SortAsc = False Then arrayList.Reverse End If 'Loop through array For Each va In arrayList ResDict.Add va, DictIn(va) Next va Set DictIn = ResDict End Sub ================================================ FILE: ModHash.bas ================================================ Attribute VB_Name = "ModHash" 'Public Function Suite() As TestSuite ' Set Suite = New TestSuite ' Suite.Description = "..." ' ' ' Create reporter and attach it to these specs ' Dim Reporter As New ImmediateReporter ' Reporter.ListenTo Suite ' ' ' ' -> Reporter will now output results as they are generated 'End Function Sub TestHash() ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModHash" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestHashes") '9f54d278014e50f71c789e6fba09c6cfb0945d9253eb8dc5f91ecf52e9996ab9 TestResult = ComputeHash_C("SHA256", "input_string", "", "STRHEX") Test.IsEqual Len(TestResult), 64 Test.IsEqual TestResult, "9f54d278014e50f71c789e6fba09c6cfb0945d9253eb8dc5f91ecf52e9996ab9" '9DsHyKCMZmDa5+y2I4v9ErMAa4rTWXVZVqDA5HOuScHFJBjUJeJW11B6CojHJHQHIzXJc8tkneRLRCqaZfV05A== TestResult = ComputeHash_C("SHA512", "input_string", "my_key", "STR64") Test.IsEqual Len(TestResult), 88 Test.IsEqual TestResult, "9DsHyKCMZmDa5+y2I4v9ErMAa4rTWXVZVqDA5HOuScHFJBjUJeJW11B6CojHJHQHIzXJc8tkneRLRCqaZfV05A==" '29uD{SѢ9K˭Sթk46gyRe TestResult = ComputeHash_C("SHA384", "input_string", "", "RAW") 'If Len(TestResult) = 48 And Left(TestResult, 4) = "29u" Then Test.IsEqual Len(TestResult), 48 Test.IsEqual Left(TestResult, 4), "29u" End Sub Function ComputeHash_C(Meth As String, ByVal clearText As String, ByVal key As String, Optional OutType As String) As Variant 'Created by Koen Rijnsent, www.castoro.nl 'Function to return a hash 'Methods: default SHA1, other options SHA512, SHA384 and SHA256 'Key: "" for no key 'Output: STR64, STRHEX, RAW or bytes Dim BKey() As Byte Dim BTxt() As Byte Dim oT As Object Dim TextToHash() As Byte Dim bytes() As Byte BTxt = StrConv(clearText, vbFromUnicode) BKey = StrConv(key, vbFromUnicode) If key <> "" Then 'MD5 does not work with a key, no error catching yet If Meth = "SHA512" Then Set SHAhasher = CreateObject("System.Security.Cryptography.HMACSHA512") ElseIf Meth = "SHA384" Then Set SHAhasher = CreateObject("System.Security.Cryptography.HMACSHA384") ElseIf Meth = "SHA256" Then Set SHAhasher = CreateObject("System.Security.Cryptography.HMACSHA256") Else Set SHAhasher = CreateObject("System.Security.Cryptography.HMACSHA1") End If SHAhasher.key = BKey bytes = SHAhasher.computeHash_2(BTxt) Else If Meth = "SHA512" Then Set SHAhasher = CreateObject("System.Security.Cryptography.SHA512Managed") ElseIf Meth = "SHA256" Then Set SHAhasher = CreateObject("System.Security.Cryptography.SHA256Managed") ElseIf Meth = "SHA384" Then Set SHAhasher = CreateObject("System.Security.Cryptography.SHA384Managed") ElseIf Meth = "MD5" Then Set SHAhasher = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider") Else Set SHAhasher = CreateObject("System.Security.Cryptography.SHA1Managed") End If Set oT = CreateObject("System.Text.UTF8Encoding") TextToHash = oT.GetBytes_4(clearText) bytes = SHAhasher.computeHash_2((TextToHash)) End If If OutType = "STR64" Then ComputeHash_C = ConvToBase64String(bytes) ElseIf OutType = "STRHEX" Then ComputeHash_C = ConvToHexString(bytes) ElseIf OutType = "RAW" Then ComputeHash_C = Base64Decode(ConvToBase64String(bytes)) Else ComputeHash_C = bytes End If Set SHAhaser = Nothing End Function Function ConvToBase64String(vIn As Variant) As Variant 'Source: https://en.wikibooks.org/wiki/Visual_Basic_for_Applications/File_Hashing_in_VBA Dim oD As Object Set oD = CreateObject("MSXML2.DOMDocument") With oD .LoadXML "" .DocumentElement.DataType = "bin.base64" .DocumentElement.nodeTypedValue = vIn End With ConvToBase64String = Replace(oD.DocumentElement.Text, vbLf, "") Set oD = Nothing End Function Function ConvToHexString(vIn As Variant) As Variant 'Source: https://en.wikibooks.org/wiki/Visual_Basic_for_Applications/File_Hashing_in_VBA Dim oD As Object Set oD = CreateObject("MSXML2.DOMDocument") With oD .LoadXML "" .DocumentElement.DataType = "bin.Hex" .DocumentElement.nodeTypedValue = vIn End With ConvToHexString = Replace(oD.DocumentElement.Text, vbLf, "") Set oD = Nothing End Function ' Decodes a base-64 encoded string (BSTR type). ' 1999 - 2004 Antonin Foller, http://www.motobit.com ' 1.01 - solves problem with Access And 'Compare Database' (InStr) Function Base64Decode(ByVal base64String) 'rfc1521 '1999 Antonin Foller, Motobit Software, http://Motobit.cz Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" Dim dataLength, sOut, groupBegin 'remove white spaces, If any base64String = Replace(base64String, vbCrLf, "") base64String = Replace(base64String, vbTab, "") base64String = Replace(base64String, " ", "") 'The source must consists from groups with Len of 4 chars dataLength = Len(base64String) If dataLength Mod 4 <> 0 Then Err.Raise 1, "Base64Decode", "Bad Base64 string." Exit Function End If ' Now decode each group: For groupBegin = 1 To dataLength Step 4 Dim numDataBytes, CharCounter, thisChar, thisData, nGroup, pOut ' Each data group encodes up To 3 actual bytes. numDataBytes = 3 nGroup = 0 For CharCounter = 0 To 3 ' Convert each character into 6 bits of data, And add it To ' an integer For temporary storage. If a character is a '=', there ' is one fewer data byte. (There can only be a maximum of 2 '=' In ' the whole string.) thisChar = Mid(base64String, groupBegin + CharCounter, 1) If thisChar = "=" Then numDataBytes = numDataBytes - 1 thisData = 0 Else thisData = InStr(1, Base64, thisChar, vbBinaryCompare) - 1 End If If thisData = -1 Then Err.Raise 2, "Base64Decode", "Bad character In Base64 string." Exit Function End If nGroup = 64 * nGroup + thisData Next 'Hex splits the long To 6 groups with 4 bits nGroup = Hex(nGroup) 'Add leading zeros nGroup = String(6 - Len(nGroup), "0") & nGroup 'Convert the 3 byte hex integer (6 chars) To 3 characters pOut = Chr(CByte("&H" & Mid(nGroup, 1, 2))) + _ Chr(CByte("&H" & Mid(nGroup, 3, 2))) + _ Chr(CByte("&H" & Mid(nGroup, 5, 2))) 'add numDataBytes characters To out string sOut = sOut & Left(pOut, numDataBytes) Next Base64Decode = sOut End Function Function Base64Encode(inData) 'rfc1521 '2001 Antonin Foller, Motobit Software, http://Motobit.cz Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" Dim cOut, sOut, i 'For each group of 3 bytes For i = 1 To Len(inData) Step 3 Dim nGroup, pOut, sGroup 'Create one long from this 3 bytes. nGroup = &H10000 * Asc(Mid(inData, i, 1)) + _ &H100 * MyASC(Mid(inData, i + 1, 1)) + MyASC(Mid(inData, i + 2, 1)) 'Oct splits the long To 8 groups with 3 bits nGroup = Oct(nGroup) 'Add leading zeros nGroup = String(8 - Len(nGroup), "0") & nGroup 'Convert To base64 pOut = Mid(Base64, CLng("&o" & Mid(nGroup, 1, 2)) + 1, 1) + _ Mid(Base64, CLng("&o" & Mid(nGroup, 3, 2)) + 1, 1) + _ Mid(Base64, CLng("&o" & Mid(nGroup, 5, 2)) + 1, 1) + _ Mid(Base64, CLng("&o" & Mid(nGroup, 7, 2)) + 1, 1) 'Add the part To OutPut string sOut = sOut + pOut 'Add a new line For Each 76 chars In dest (76*3/4 = 57) 'If (I + 2) Mod 57 = 0 Then sOut = sOut + vbCrLf Next Select Case Len(inData) Mod 3 Case 1: '8 bit final sOut = Left(sOut, Len(sOut) - 2) + "==" Case 2: '16 bit final sOut = Left(sOut, Len(sOut) - 1) + "=" End Select Base64Encode = sOut End Function Function MyASC(OneChar) If OneChar = "" Then MyASC = 0 Else MyASC = Asc(OneChar) End Function ================================================ FILE: ModJSON.bas ================================================ Attribute VB_Name = "ModJSON" 'Functions in module: 'MaxDepth - integer with the maximum depth of the JSON 'JsonToArray - transforms JSON into an array with an internal tree structure 'ArrayTable - transforms JsonToArray (internal tree) into a flat table for output 'Source: https://github.com/krijnsent/crypto_vba Sub TestJson() Dim JsonResponse As String Dim Json As Object 'Can be dictionary - json starting {} or collection - json starting [] Dim JsonRes As Dictionary ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModJSON" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestDepth") 'Kraken Time JsonResponse = "{""error"":[],""result"":{""unixtime"":1495455831,""rfc1123"":""Mon, 22 May 17 12:23:51 +0000""}}" Set Json = JsonConverter.ParseJson(JsonResponse) Set JsonRes = Json("result") TestResult = MaxDepth(JsonRes) Test.IsEqual TestResult, 1 'Poloniex returnTicker JsonResponse = "{""BTC_BCN"":{""id"":7,""last"":""0.00000210"",""lowestAsk"":""0.00000210"",""highestBid"":""0.00000208"",""percentChange"":""0.73553719"",""baseVolume"":""26784.80209760"",""quoteVolume"":""13894501407.13100815"",""isFrozen"":""0"",""high24hr"":""0.00000280"",""low24hr"":""0.00000118""},""BTC_DASH"":{""id"":24,""last"":""0.04775443"",""lowestAsk"":""0.04781078"",""highestBid"":""0.04775443"",""percentChange"":""0.00446825"",""baseVolume"":""2884.45152468"",""quoteVolume"":""60634.59565660"",""isFrozen"":""0"",""high24hr"":""0.05035290"",""low24hr"":""0.04430738""}}" Set Json = JsonConverter.ParseJson(JsonResponse) TestResult = MaxDepth(Json) Test.IsEqual TestResult, 2 'Kraken OHLC JsonResponse = "{""error"":[],""result"":{""XXBTZEUR"":[[1492606800,""1121.990"",""1124.912"",""1119.680"",""1124.912"",""1122.345"",""352.76808800"",602],[1492610400,""1124.499"",""1124.980"",""1119.680"",""1122.000"",""1122.194"",""218.62127780"",713],[1492614000,""1121.311"",""1122.900"",""1120.501"",""1122.899"",""1122.266"",""445.46426003"",851],[1492617600,""1122.894"",""1124.499"",""1120.710"",""1123.291"",""1123.068"",""253.55336370"",860],[1492621200,""1124.406"",""1126.000"",""1123.017"",""1125.990"",""1124.775"",""234.27612705"",918],[1492624800,""1125.610"",""1126.231"",""1123.010"",""1126.229"",""1125.453"",""243.42246123"",772]],""last"":1495191600}}" Set Json = JsonConverter.ParseJson(JsonResponse) Set JsonRes = Json("result") TestResult = MaxDepth(JsonRes) Test.IsEqual TestResult, 3 'WEXnz depth JsonResponse = "{""btc_eur"":{""asks"":[[1919.99999,0.1111724],[1920,0.30236723],[1924.41,0.00601202],[1924.41522,0.009536]]}}" Set Json = JsonConverter.ParseJson(JsonResponse) TestResult = MaxDepth(Json) Test.IsEqual TestResult, 4 'TestJsonToArray Set Test = Suite.Test("TestJsonToArray") 'Kraken Time JsonResponse = "{""error"":[],""result"":{""unixtime"":1495455831,""rfc1123"":""Mon, 22 May 17 12:23:51 +0000""}}" Set Json = JsonConverter.ParseJson(JsonResponse) Set JsonRes = Json("result") TestResult = JsonToArray(JsonRes) Test.IsEqual UBound(TestResult, 1), 5 Test.IsEqual UBound(TestResult, 2), 3 Test.IsEqual TestResult(3, 2), "unixtime" Test.IsEqual TestResult(3, 3), "rfc1123" 'Poloniex returnTicker JsonResponse = "{""BTC_BCN"":{""id"":7,""last"":""0.00000210"",""lowestAsk"":""0.00000210"",""highestBid"":""0.00000208"",""percentChange"":""0.73553719"",""baseVolume"":""26784.80209760"",""quoteVolume"":""13894501407.13100815"",""isFrozen"":""0"",""high24hr"":""0.00000280"",""low24hr"":""0.00000118""},""BTC_DASH"":{""id"":24,""last"":""0.04775443"",""lowestAsk"":""0.04781078"",""highestBid"":""0.04775443"",""percentChange"":""0.00446825"",""baseVolume"":""2884.45152468"",""quoteVolume"":""60634.59565660"",""isFrozen"":""0"",""high24hr"":""0.05035290"",""low24hr"":""0.04430738""}}" Set Json = JsonConverter.ParseJson(JsonResponse) TestResult = JsonToArray(Json) Test.IsEqual UBound(TestResult, 1), 5 Test.IsEqual UBound(TestResult, 2), 23 Test.IsEqual TestResult(3, 11), "high24hr" Test.IsEqual TestResult(4, 14), 24 'Kraken OHLC JsonResponse = "{""error"":[],""result"":{""XXBTZEUR"":[[1492606800,""1121.990"",""1124.912"",""1119.680"",""1124.912"",""1122.345"",""352.76808800"",602],[1492610400,""1124.499"",""1124.980"",""1119.680"",""1122.000"",""1122.194"",""218.62127780"",713],[1492614000,""1121.311"",""1122.900"",""1120.501"",""1122.899"",""1122.266"",""445.46426003"",851],[1492617600,""1122.894"",""1124.499"",""1120.710"",""1123.291"",""1123.068"",""253.55336370"",860],[1492621200,""1124.406"",""1126.000"",""1123.017"",""1125.990"",""1124.775"",""234.27612705"",918],[1492624800,""1125.610"",""1126.231"",""1123.010"",""1126.229"",""1125.453"",""243.42246123"",772]],""last"":1495191600}}" Set Json = JsonConverter.ParseJson(JsonResponse) Set JsonRes = Json("result") TestResult = JsonToArray(JsonRes) Test.IsEqual UBound(TestResult, 1), 5 Test.IsEqual UBound(TestResult, 2), 57 Test.IsEqual TestResult(3, 11), 8 Test.IsEqual TestResult(4, 14), "1124.499" 'BTCe depth JsonResponse = "{""btc_eur"":{""asks"":[[1919.99999,0.1111724],[1920,0.30236723],[1924.41,0.00601202],[1924.41522,0.009536]]}}" Set Json = JsonConverter.ParseJson(JsonResponse) TestResult = JsonToArray(Json) Test.IsEqual UBound(TestResult, 1), 5 Test.IsEqual UBound(TestResult, 2), 15 Test.IsEqual TestResult(3, 11), 1 Test.IsEqual TestResult(4, 14), 1924.41522 'TestArrayTable Set Test = Suite.Test("TestArrayTable") 'Kraken Time JsonResponse = "{""error"":[],""result"":{""unixtime"":1495455831,""rfc1123"":""Mon, 22 May 17 12:23:51 +0000""}}" Set Json = JsonConverter.ParseJson(JsonResponse) Set JsonRes = Json("result") ResArr = JsonToArray(JsonRes) TestResult = ArrayTable(ResArr, True) Test.IsEqual UBound(TestResult, 1), 2 Test.IsEqual UBound(TestResult, 2), 2 Test.IsEqual TestResult(1, 1), "unixtime" Test.IsEqual TestResult(2, 2), "Mon, 22 May 17 12:23:51 +0000" 'Poloniex returnTicker JsonResponse = "{""BTC_BCN"":{""id"":7,""last"":""0.00000210"",""lowestAsk"":""0.00000210"",""highestBid"":""0.00000208"",""percentChange"":""0.73553719"",""baseVolume"":""26784.80209760"",""quoteVolume"":""13894501407.13100815"",""isFrozen"":""0"",""high24hr"":""0.00000280"",""low24hr"":""0.00000118""},""BTC_DASH"":{""id"":24,""last"":""0.04775443"",""lowestAsk"":""0.04781078"",""highestBid"":""0.04775443"",""percentChange"":""0.00446825"",""baseVolume"":""2884.45152468"",""quoteVolume"":""60634.59565660"",""isFrozen"":""0"",""high24hr"":""0.05035290"",""low24hr"":""0.04430738""}}" Set Json = JsonConverter.ParseJson(JsonResponse) ResArr = JsonToArray(Json) TestResult = ArrayTable(ResArr, True) Test.IsEqual UBound(TestResult, 1), 11 Test.IsEqual UBound(TestResult, 2), 3 Test.IsEqual TestResult(1, 2), "BTC_BCN" Test.IsEqual TestResult(3, 3), "0.04775443" 'Kraken OHLC JsonResponse = "{""error"":[],""result"":{""XXBTZEUR"":[[1492606800,""1121.990"",""1124.912"",""1119.680"",""1124.912"",""1122.345"",""352.76808800"",602],[1492610400,""1124.499"",""1124.980"",""1119.680"",""1122.000"",""1122.194"",""218.62127780"",713],[1492614000,""1121.311"",""1122.900"",""1120.501"",""1122.899"",""1122.266"",""445.46426003"",851],[1492617600,""1122.894"",""1124.499"",""1120.710"",""1123.291"",""1123.068"",""253.55336370"",860],[1492621200,""1124.406"",""1126.000"",""1123.017"",""1125.990"",""1124.775"",""234.27612705"",918],[1492624800,""1125.610"",""1126.231"",""1123.010"",""1126.229"",""1125.453"",""243.42246123"",772]],""last"":1495191600}}" Set Json = JsonConverter.ParseJson(JsonResponse) Set JsonRes = Json("result") ResArr = JsonToArray(Json) TestResult = ArrayTable(ResArr, True) Test.IsEqual UBound(TestResult, 1), 11 Test.IsEqual UBound(TestResult, 2), 7 Test.IsEqual TestResult(1, 2), "result" Test.IsEqual TestResult(4, 4), 1492614000 'BTCe depth JsonResponse = "{""btc_eur"":{""asks"":[[1919.99999,0.1111724],[1920,0.30236723],[1924.41,0.00601202],[1924.41522,0.009536]]}}" Set Json = JsonConverter.ParseJson(JsonResponse) ResArr = JsonToArray(Json) TestResult = ArrayTable(ResArr, True) Test.IsEqual UBound(TestResult, 1), 5 Test.IsEqual UBound(TestResult, 2), 5 Test.IsEqual TestResult(1, 2), "btc_eur" Test.IsEqual TestResult(4, 4), 1924.41 'Poloniex deposit/withdrawal, no header output JsonResponse = "{""deposits"":[{""currency"":""BTC"",""address"":""DEP1"",""amount"":""0.01006132"",""confirmations"":10,""txid"":""17f819a91369a9ff6c4a34216d434597cfc1b4a3d0489b46bd6f924137a47701"",""timestamp"":1399305798,""status"":""COMPLETE""},{""currency"":""BTC"",""address"":""DEP2"",""amount"":""0.00404104"",""confirmations"":10,""txid"":""7acb90965b252e55a894b535ef0b0b65f45821f2899e4a379d3e43799604695c"",""timestamp"":1399245916,""status"":""COMPLETE""}],""withdrawals"":[{""withdrawalNumber"":134933,""currency"":""BTC"",""address"":""1N2i5n8DwTGzUq2Vmn9TUL8J1vdr1XBDFg"",""amount"":""5.00010000"", ""timestamp"":1399267904,""status"":""COMPLETE: 36e483efa6aff9fd53a235177579d98451c4eb237c210e66cd2b9a2d4a988f8e"",""ipAddress"":""IP192""}]}" Set Json = JsonConverter.ParseJson(JsonResponse) ResArr = JsonToArray(Json) TestResult = ArrayTable(ResArr, False) Test.IsEqual UBound(TestResult, 1), 11 Test.IsEqual UBound(TestResult, 2), 3 Test.IsEqual TestResult(1, 2), "deposits" Test.IsEqual TestResult(4, 2), "DEP2" 'Test no header reply JsonResponse = "{""error"":[],""result"":{""XXBTZEUR"":[[1492606800,""1121.990"",""1124.912"",""1119.680"",""1124.912"",""1122.345"",""352.76808800"",602],[1492610400,""1124.499"",""1124.980"",""1119.680"",""1122.000"",""1122.194"",""218.62127780"",713],[1492614000,""1121.311"",""1122.900"",""1120.501"",""1122.899"",""1122.266"",""445.46426003"",851],[1492617600,""1122.894"",""1124.499"",""1120.710"",""1123.291"",""1123.068"",""253.55336370"",860],[1492621200,""1124.406"",""1126.000"",""1123.017"",""1125.990"",""1124.775"",""234.27612705"",918],[1492624800,""1125.610"",""1126.231"",""1123.010"",""1126.229"",""1125.453"",""243.42246123"",772]],""last"":1495191600}}" Set Json = JsonConverter.ParseJson(JsonResponse) Set JsonRes = Json("result") ResArr = JsonToArray(Json) TestResult = ArrayTable(ResArr, False) Test.IsEqual UBound(TestResult, 1), 11 Test.IsEqual UBound(TestResult, 2), 6 Test.IsEqual TestResult(1, 2), "result" Test.IsEqual TestResult(4, 2), 1492610400 'Empty data set returned 1 JsonResponse = "{""success"":true,""message"":"""",""result"":[]}" Set Json = JsonConverter.ParseJson(JsonResponse) ResArr = JsonToArray(Json) TestResult = ArrayTable(ResArr, True) Test.IsEqual UBound(TestResult, 1), 3 Test.IsEqual UBound(TestResult, 2), 2 Test.IsEqual TestResult(1, 2), True Test.IsEqual TestResult(3, 2), 0 'Empty data set returned 2 JsonResponse = "{""success"":false,""message"":""APISIGN_NOT_PROVIDED"",""result"":null}" Set Json = JsonConverter.ParseJson(JsonResponse) ResArr = JsonToArray(Json) TestResult = ArrayTable(ResArr, True) Test.IsEqual UBound(TestResult, 1), 3 Test.IsEqual UBound(TestResult, 2), 2 Test.IsEqual TestResult(1, 2), False Test.IsEqual TestResult(2, 2), "APISIGN_NOT_PROVIDED" 'Error set - only if Json is defined as Dictionary, as Object is okay JsonResponse = "[{""balance"":0,""pendingFunds"":0,""currency"":""BCH""},{""balance"":41,""pendingFunds"":0,""currency"":""AUD""},{""balance"":145,""pendingFunds"":0,""currency"":""BTC""},{""balance"":0,""pendingFunds"":0,""currency"":""LTC""}]" Set Json = JsonConverter.ParseJson(JsonResponse) ResArr = JsonToArray(Json) TestResult = ArrayTable(ResArr, True) Test.IsEqual UBound(TestResult, 1), 4 Test.IsEqual UBound(TestResult, 2), 5 Test.IsEqual TestResult(2, 3), 41 Test.IsEqual TestResult(4, 4), "BTC" 'NEW TEST, UNFINISHED PrTxt = "{""ret_msg"": ""ok"",""ext_code"": """",""result"": {""BTCUSD"": {""leverage"": 1},""EOSUSD"": {""leverage"": 1}},""time_now"": ""1567608910.732004""}" Set Json = JsonConverter.ParseJson(PrTxt) Set Res1 = Json("result") 'Res2 = json("result") '-> error, doesn't work... For Each elm In Json("result") 'Debug.Print elm 'Debug.Print json("result")(elm) Set Res3 = Json("result")(elm) 'Debug.Print json("result")(elm)("leverage") Next elm End Sub Function MaxDepth(ObjIn As Object, Optional MaxLvl As Integer = 1, Optional NodeLvl As Integer = 1) As Integer Dim CollIn As New Collection Dim DictIn As New Scripting.Dictionary Dim iO As Object Dim Lvl As Integer If TypeName(ObjIn) = "Collection" Then 'arrays ([]) to collections, arrays only have values Set CollIn = ObjIn For i = 1 To CollIn.Count 'item could be value, object or array, determine: Set iO = Nothing On Error Resume Next Set iO = CollIn(i) On Error GoTo 0 'item/value If Not (iO Is Nothing) Then If NodeLvl + 1 > MaxLvl Then MaxLvl = NodeLvl + 1 NextLvl = MaxDepth(iO, MaxLvl, NodeLvl + 1) End If Next i ElseIf TypeName(ObjIn) = "Dictionary" Then 'objects ({}) to dictionaries, Objects have key:values Set DictIn = ObjIn For Each k In DictIn.Keys 'item could be value, object or array, determine: IV = "" Set iO = Nothing On Error Resume Next IV = DictIn(k) Set iO = DictIn(k) On Error GoTo 0 'item/value If Not (iO Is Nothing) Then If NodeLvl + 1 > MaxLvl Then MaxLvl = NodeLvl + 1 NextLvl = MaxDepth(iO, MaxLvl, NodeLvl + 1) End If Next k End If MaxDepth = MaxLvl End Function Function JsonToArray(ObjIn As Object, Optional ParentKey As String = "MAIN", Optional NodeLvl As Integer = 1, Optional ResArr As Variant) As Variant 'Dim TempResArr() As Variant If IsMissing(ResArr) Then ReDim ResArr(1 To 5, 1 To 1) ResArr(1, 1) = "NODE_LVL" ResArr(2, 1) = "PARENT" ResArr(3, 1) = "KEY" ResArr(4, 1) = "VALUE" ResArr(5, 1) = "TYPE" End If Dim CollIn As New Collection Dim DictIn As New Scripting.Dictionary Dim iO As Object Dim CurK As String Dim Lvl As Integer If TypeName(ObjIn) = "Collection" Then 'arrays ([]) to collections, arrays only have values Set CollIn = ObjIn For i = 1 To CollIn.Count 'item could be value, object or array, determine: IV = "" Set iO = Nothing On Error Resume Next IV = CollIn(i) Set iO = CollIn(i) On Error GoTo 0 'item/value If Not (iO Is Nothing) Then 'Collection or Array, store and go one level deeper ReDim Preserve ResArr(1 To 5, 1 To UBound(ResArr, 2) + 1) ResArr(1, UBound(ResArr, 2)) = NodeLvl ResArr(2, UBound(ResArr, 2)) = ParentKey ResArr(3, UBound(ResArr, 2)) = i ResArr(4, UBound(ResArr, 2)) = iO.Count ResArr(5, UBound(ResArr, 2)) = "OBJ" 'Debug.Print "LVL: " & NodeLvl & ", PARENT: " & ParentKey & " , KEY: " & I & " VALUE: count: " & iO.Count & " , TYPE:OBJ" ParentKey = i NextLvl = JsonToArray(iO, Str(i), NodeLvl + 1, ResArr) Else 'item, write simple value 'Debug.Print "LVL: " & NodeLvl & ", PARENT: " & ParentKey & " , KEY: " & I & " VALUE:" & iV & " , TYPE:VAL" ReDim Preserve ResArr(1 To 5, 1 To UBound(ResArr, 2) + 1) ResArr(1, UBound(ResArr, 2)) = NodeLvl ResArr(2, UBound(ResArr, 2)) = ParentKey ResArr(3, UBound(ResArr, 2)) = i ResArr(4, UBound(ResArr, 2)) = IV ResArr(5, UBound(ResArr, 2)) = "VAL" End If Next i ElseIf TypeName(ObjIn) = "Dictionary" Then 'objects ({}) to dictionaries, Objects have key:values Set DictIn = ObjIn For Each k In DictIn.Keys 'item could be value, object or array, determine: IV = "" Set iO = Nothing On Error Resume Next IV = DictIn(k) Set iO = DictIn(k) On Error GoTo 0 'item/value If Not (iO Is Nothing) Then 'Collection or Array, store and go one level deeper 'Debug.Print "LVL: " & NodeLvl & ", PARENT: " & ParentKey & " , KEY: " & k & " VALUE: count: " & iO.Count & " , TYPE:OBJ" ReDim Preserve ResArr(1 To 5, 1 To UBound(ResArr, 2) + 1) ResArr(1, UBound(ResArr, 2)) = NodeLvl ResArr(2, UBound(ResArr, 2)) = ParentKey ResArr(3, UBound(ResArr, 2)) = k ResArr(4, UBound(ResArr, 2)) = iO.Count ResArr(5, UBound(ResArr, 2)) = "OBJ" CurK = k NextLvl = JsonToArray(iO, CurK, NodeLvl + 1, ResArr) Else 'item, write simple value 'Debug.Print "LVL: " & NodeLvl & ", PARENT: " & ParentKey & " , KEY: " & k & " VALUE:" & iV & " , TYPE:VAL" ReDim Preserve ResArr(1 To 5, 1 To UBound(ResArr, 2) + 1) ResArr(1, UBound(ResArr, 2)) = NodeLvl ResArr(2, UBound(ResArr, 2)) = ParentKey ResArr(3, UBound(ResArr, 2)) = k ResArr(4, UBound(ResArr, 2)) = IV ResArr(5, UBound(ResArr, 2)) = "VAL" End If Next k End If JsonToArray = ResArr End Function Function ArrayTable(ArrIn As Variant, Optional ReturnHeader As Boolean = True) As Variant 'Expected input: NODE_LVL -- PARENT -- KEY -- VALUE -- TYPE Dim NrIt As Integer Dim MaxD As Integer Dim TblHeaders As New Scripting.Dictionary 'Get max depth and max items at that level MaxD = 0 'Find maximum depth For rw = LBound(ArrIn, 2) To UBound(ArrIn, 2) If Val(ArrIn(1, rw)) > MaxD Then MaxD = ArrIn(1, rw) End If Next 'Get unique headers On Error Resume Next For rw = LBound(ArrIn, 2) To UBound(ArrIn, 2) Lvl = Val(ArrIn(1, rw)) If Lvl < MaxD And Lvl > 0 Then TblHeaders.Add "GROUP_" & Lvl, "GROUP_" & Lvl 'ElseIf Lvl = MaxD And ArrIn(5, rw) = "VAL" Then ElseIf Lvl = MaxD Then If Val(ArrIn(3, rw)) > 0 Then TblHeaders.Add "VAL_" & ArrIn(3, rw), "VAL_" & ArrIn(3, rw) Else TblHeaders.Add ArrIn(3, rw), ArrIn(3, rw) End If End If Next On Error GoTo 0 If ReturnHeader = True Then HeadRw = 1 Else HeadRw = 0 End If ReDim ResArr(1 To TblHeaders.Count, 1 To 1 + HeadRw) TempRw = 0 ResRw = 1 + HeadRw For rw = LBound(ArrIn, 2) To UBound(ArrIn, 2) Lvl = Val(ArrIn(1, rw)) If rw < UBound(ArrIn, 2) Then NextLvl = Val(ArrIn(1, rw + 1)) Else NextLvl = 0 End If If Lvl = MaxD Then 'Get result column Idx = 0 If Val(ArrIn(3, rw)) > 0 Then Idx = Application.Match("VAL_" & ArrIn(3, rw), TblHeaders.Keys, 0) If ReturnHeader = True Then ResArr(Idx, 1) = "VAL_" & ArrIn(3, rw) End If Else Idx = Application.Match(ArrIn(3, rw), TblHeaders.Keys, 0) If ReturnHeader = True Then ResArr(Idx, 1) = ArrIn(3, rw) End If End If ResArr(Idx, ResRw) = ArrIn(4, rw) For k = 1 To Lvl If IsEmpty(ResArr(k, ResRw)) Then ResArr(k, ResRw) = ResArr(k, ResRw - 1) Next k TempRw = TempRw + 1 If rw < UBound(ArrIn, 2) And NextLvl < Lvl Then TempRw = 0 ResRw = ResRw + 1 ReDim Preserve ResArr(1 To TblHeaders.Count, 1 To ResRw) End If ElseIf Lvl > 0 Then If ReturnHeader = True Then ResArr(Lvl, 1) = "GROUP_" & Lvl End If ResArr(Lvl, ResRw) = ArrIn(3, rw) End If Next 'Strip last line if that wasn't a max depth record If Lvl < MaxD Then ReDim Preserve ResArr(1 To TblHeaders.Count, 1 To ResRw - 1) End If ArrayTable = ResArr End Function ================================================ FILE: ModSrcCoinGecko.bas ================================================ Attribute VB_Name = "ModSrcCoinGecko" 'Two variables for caching, so the formulas don't update every recalculation Public Const CGCacheSeconds = 6000 'Nr of seconds cache, default >= 60 Public CGDict As New Scripting.Dictionary Sub TestSrcCoinGecko() 'https://www.coingecko.com/en/api 'https://www.coingecko.com/api/documentations/v3 ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModSrcCoinGecko" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestPublicCoinGeckoData") 'Test for errors first TestResult = PublicCoinGeckoData("unknown_command") '{"error_nr":404,"error_txt":"HTTP-Not Found","response_txt":{"error":"Incorrect path. Please check https://www.coingecko.com/api/"}} Test.IsOk InStr(TestResult, "error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("error_nr"), 404 'Test.IsEqual JsonResult("response_txt")("error"), "Incorrect path. Please check https://www.coingecko.com/api/" 'Simple ping TestResult = PublicCoinGeckoData("ping") '{"gecko_says":"(V3) To the Moon!"} Test.IsOk InStr(TestResult, "gecko") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("gecko_says"), "(V3) To the Moon!" 'Simple price Dim Params As New Dictionary Params.Add "ids", "bitcoin" Params.Add "vs_currencies", "eur" TestResult = PublicCoinGeckoData("simple/price", Params) 'e.g. {"bitcoin":{"eur":7272.72}} Test.IsOk InStr(TestResult, "bitcoin") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsOk JsonResult("bitcoin")("eur") > 0 End Sub Function PublicCoinGeckoData(Method As String, Optional ParamDict As Dictionary) As String Dim url As String Dim TempData As String Dim Sec As Double PublicApiSite = "https://api.coingecko.com/api/v3" MethodParams = "" If Not ParamDict Is Nothing Then 'Change the rest of the parameters to JSON MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams End If urlPath = Method & MethodParams url = PublicApiSite & "/" & urlPath GetNewData = False IsInDict = CGDict.Exists(urlPath) If IsInDict = True Then 'In dictionary, check time If CGDict(urlPath) + TimeSerial(0, 0, CGCacheSeconds) < Now() Then 'Has not been updated recently, update now CGDict.Remove urlPath CGDict.Add urlPath, Now() If CGDict.Exists("DATA-" & urlPath) Then CGDict.Remove "DATA-" & urlPath GetNewData = True End If Else CGDict.Add urlPath, Now() GetNewData = True End If If GetNewData = True Then TempData = WebRequestURL(url, "GET") CGDict.Add "DATA-" & urlPath, TempData Else TempData = CGDict("DATA-" & urlPath) End If PublicCoinGeckoData = TempData End Function ================================================ FILE: ModSrcCryptocompare.bas ================================================ Attribute VB_Name = "ModSrcCryptocompare" 'Two variables for caching, so the formulas don't update every recalculation Public Const CCCacheSeconds = 3000 'Nr of seconds cache, default >= 60 Public CCDict As New Scripting.Dictionary Sub TestSrcCryptocompare() 'This module contains functions to use in a sheet or in VBA 'Source: https://github.com/krijnsent/crypto_vba 'Note: the functions currently slow down the sheets massively, use max 10 functions per workbook, otherwise your workbook might CRASH 'ToDo: better error catching 'For cryptocompare, please get a free API key at https://www.cryptocompare.com 'Functions in this module: 'C_LAST_PRICE - price?fsym=BTC&tsyms=USD,EUR&e=Coinbase 'C_HIST_PRICE - pricehistorical?fsym=BTC&tsyms=USD,EUR&e=Coinbase&ts=1452680400 'C_DAY_AVG_PRICE - dayAvg?fsym=BTC&tsym=USD&toTs=1487116800&e=Bitfinex 'C_ARR_OHLCV - histoday?fsym=GBP&tsym=USD&limit=30&aggregate=1&e=CCCAGG Dim Apikey As String Apikey = "your_api_key_here" 'empty if you don't use an API key 'Remove this line, unless you define a constant somewhere ( Public Const apikey_cryptocompare = "the key to use everywhere" etc ) Apikey = apikey_cryptocompare ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModSrcCryptocompare" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestPublicCryptoCompareData") 'Error, unknown command TestResult = PublicCryptoCompareData("unknown_command") Test.IsOk InStr(TestResult, "Error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("Response"), "Error" Test.IsEqual JsonResult("Message"), "Path does not exist" Test.IsEqual JsonResult("Path"), "" 'Error, no parameters TestResult = PublicCryptoCompareData("data/histoday") Test.IsOk InStr(TestResult, "Error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("Response"), "Error" Test.IsEqual JsonResult("Message"), "fsym is a required param." Test.IsEqual JsonResult("Path"), "" 'Error, create a dictionary with ONLY the parameter fsym Dim Params As New Dictionary Params.Add "fsym", "BTC" TestResult = PublicCryptoCompareData("data/histoday", Params) Test.IsOk InStr(TestResult, "Error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("Response"), "Error" Test.IsEqual JsonResult("Message"), "tsym is a required param." Test.IsEqual JsonResult("Path"), "" 'Error, add to the same dictionary an unknown tsym Params.Add "tsym", "BLABLA" TestResult = PublicCryptoCompareData("data/histoday", Params) Test.IsOk InStr(TestResult, "Error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("Response"), "Error" Test.IsEqual JsonResult("Message"), "There is no data for the toSymbol BLABLA ." Test.IsEqual JsonResult("Path"), "" 'OK, two correct parameters for histoday, make a new dictionary Dim Params2 As New Dictionary Params2.Add "fsym", "BTC" Params2.Add "tsym", "XMR" TestResult = PublicCryptoCompareData("data/histoday", Params2) Test.IsOk InStr(TestResult, "Success") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("Response"), "Success" Test.IsEqual JsonResult("Message"), "" Test.IsEqual JsonResult("Path"), "" Test.IsOk JsonResult("Data")(1)("high") > 0 'Tests for APIkey (please get a free key at Cryptocompare.com) 'This test fails, as API key is needed: TestResult = PublicCryptoCompareData("data/social/coin/latest") '{"Response":"Error","Message":"You need a valid auth key or api key to access this endpoint","HasWarning":false,"Type":1,"RateLimit":{},"Data":{}} Test.IsOk InStr(TestResult, "Error") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("Response"), "Error" Test.IsEqual JsonResult("Message"), "You need a valid auth key or api key to access this endpoint" Test.IsEqual JsonResult("Type"), 1 'Add an API key and force caching off Dim Params3 As New Dictionary Params3.Add "apikey", Apikey TestResult = PublicCryptoCompareData("data/social/coin/latest", Params3) '{"Response":"Success","Message":"","HasWarning":false,"Type":100,"RateLimit":{},"Data":{"General":{"Points":8212774,"Name":"BTC","CoinName":"Bitcoin","Type":"Webpagecoinp"},"CryptoCompare":{"Points":6898505, etc... Test.IsOk InStr(TestResult, "Success") > 0 Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("Response"), "Success" Test.IsEqual JsonResult("Message"), "" Test.IsEqual JsonResult("Type"), 100 If JsonResult("Type") = 100 Then Test.IsEqual JsonResult("Data")("General")("Name"), "BTC" End If 'Rate limit WITHOUT an API key: 600/minute TestResult = PublicCryptoCompareData("stats/rate/limit") '{"Response":"Success","Message":"","HasWarning":false,"Type":100,"RateLimit":{},"Data":{"calls_made":{"second":1,"minute":10,"hour":138,"day":475,"month":4113},"calls_left":{"second":49,"minute":990,"hour":19862,"day":199525,"month":1995887}}} Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("Response"), "Success" If JsonResult("Response") = "Success" Then Test.IsEqual JsonResult("Data")("calls_made")("minute") + JsonResult("Data")("calls_left")("minute"), 300 End If 'Rate limit WITH an API key: 2500/minute TestResult = PublicCryptoCompareData("stats/rate/limit", Params3) '{"Response":"Success","Message":"","HasWarning":false,"Type":100,"RateLimit":{},"Data":{"calls_made":{"second":2,"minute":2,"hour":21,"day":33,"month":33},"calls_left":{"second":48,"minute":2498,"hour":24979,"day":49967,"month":99967}}} Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("Response"), "Success" If JsonResult("Response") = "Success" Then Test.IsEqual JsonResult("Data")("calls_made")("minute") + JsonResult("Data")("calls_left")("minute"), 2500 End If Set Test = Suite.Test("TestC_LAST_PRICE") JsonResult = C_LAST_PRICE("MYCOIN1", "BLABLA") Test.IsEqual JsonResult, "ERROR cccagg_or_exchange market does not exist for this coin pair (MYCOIN1-BLABLA)" JsonResult = C_LAST_PRICE("BTC", "BLABLA") Test.IsEqual JsonResult, "ERROR cccagg_or_exchange market does not exist for this coin pair (BTC-BLABLA)" JsonResult = C_LAST_PRICE("BTC", "EUR", "An_Unknown_Exchange") Test.IsEqual JsonResult, "ERROR an_unknown_exchange market does not exist for this coin pair (BTC-EUR)" JsonResult = C_LAST_PRICE("BTC", "EUR") Test.IsOk JsonResult > 0 JsonResult = C_LAST_PRICE("BTC", "EUR", "Kraken") Test.IsOk JsonResult > 0 'Optional, add an apikey, only affects the rate limit for this function JsonResult = C_LAST_PRICE("BTC", "USD", "Bittrex", Apikey) Test.IsOk JsonResult > 0 Set Test = Suite.Test("TestC_HIST_PRICE") JsonResult = C_HIST_PRICE("ETH", "USD", "2018-01-01 20:00") Test.IsOk JsonResult > 0 JsonResult = C_HIST_PRICE("ETH", "USD", #1/1/2018#, "Bittrex") Test.IsOk JsonResult > 0 'Optional, add an apikey, only affects the rate limit for this function JsonResult = C_HIST_PRICE("ETH", "USD", #1/1/2019#, , Apikey) Test.IsOk JsonResult > 0 Set Test = Suite.Test("TestC_DAY_AVG_PRICE") JsonResult = C_DAY_AVG_PRICE("ETH", "BTC", #1/1/2017#) Test.IsOk JsonResult > 0 JsonResult = C_DAY_AVG_PRICE("ETH", "BTC", #1/1/2017#, "Poloniex") Test.IsOk JsonResult > 0 'Optional, add an apikey, only affects the rate limit for this function JsonResult = C_DAY_AVG_PRICE("XMR", "BTC", #10/1/2018#, , Apikey) Test.IsOk JsonResult > 0 Set Test = Suite.Test("TestC_ARR_OHLCV") 'Function C_ARR_OHLCV( 'DayHour as String, CurrBuy As String, CurrSell As String, ReturnColumns As String -> ETCHLOFV, Optional NrHours As Long, 'Optional MaxTimeDate As Date, Optional Exchange As String, Optional exchange As String, Optional ReverseData As Boolean, 'Optional Apikey As String) As Variant() 'Test for errors first TestArr = C_ARR_OHLCV("A", "2FA", "EUR", "ECV") Test.IsEqual TestArr(1, 1), "ERROR, DayHourMin must end with D, H or M" TestArr = C_ARR_OHLCV("90M", "2FA", "EUR", "ECV") Test.IsEqual TestArr(1, 1), "ERROR, DayHourMin aggregation has to be from 1 to 60. Valid values are e.g. 7D, 2H or 30M" TestArr = C_ARR_OHLCV("H", "ETH", "EUR", "") Test.IsEqual TestArr(1, 1), "ERROR ReturnColumns, use the letters ETHLCOFV" TestArr = C_ARR_OHLCV("H", "BTC", "EUR", "ABD") Test.IsEqual TestArr(1, 1), "unknown ReturnColumn" Test.IsEqual TestArr(1, 2), "unknown ReturnColumn" Test.IsEqual TestArr(1, 3), "unknown ReturnColumn" TestArr = C_ARR_OHLCV("H", "2FA", "EUR", "ECV") Test.IsEqual TestArr(1, 1), "ERROR There is no data for the symbol 2FA ." TestArr = C_ARR_OHLCV("H", "BTC", "EUR", "TECV", 48, #1/1/2018#, "Kraken") Test.IsEqual UBound(TestArr, 1), 50 Test.IsEqual UBound(TestArr, 2), 4 Test.IsEqual TestArr(1, 1), "time" Test.IsEqual TestArr(1, 2), "time" Test.IsEqual TestArr(1, 3), "close" Test.IsEqual TestArr(1, 4), "volumeto" Test.IsEqual TestArr(2, 1), "1514592000" Test.IsEqual TestArr(2, 2), #12/30/2017# Test.IsOk TestArr(2, 3) > 1 Test.IsOk TestArr(2, 4) > 1 TestArr = C_ARR_OHLCV("H", "BTC", "EUR", "EC", 24, , "Kraken") Test.IsEqual UBound(TestArr, 1), 26 Test.IsEqual UBound(TestArr, 2), 2 Test.IsEqual TestArr(1, 1), "time" Test.IsEqual TestArr(1, 2), "close" Test.IsOk TestArr(2, 1) > #12/30/2019# Test.IsOk TestArr(2, 2) > 1 TestArr = C_ARR_OHLCV("H", "XLM", "EUR", "TEOHLCFV", 48, DateSerial(2018, 1, 1), "Kraken") Test.IsEqual UBound(TestArr, 1), 50 Test.IsEqual UBound(TestArr, 2), 8 Test.IsEqual TestArr(1, 1), "time" Test.IsEqual TestArr(1, 8), "volumeto" Test.IsEqual TestArr(2, 2), #12/30/2017# Test.IsEqual TestArr(50, 2), #1/1/2018# Test.IsEqual TestArr(50, 3), 0.0145 TestArr = C_ARR_OHLCV("4H", "XMR", "BTC", "EC", 48) Test.IsEqual UBound(TestArr, 1), 50 Test.IsEqual UBound(TestArr, 2), 2 Test.IsEqual TestArr(1, 1), "time" Test.IsEqual TestArr(1, 2), "close" Test.IsOk TestArr(50, 1) > #1/1/2020# Test.IsOk TestArr(50, 2) > 0 'Flip the result (newest row on top) TestArr = C_ARR_OHLCV("H", "XLM", "EUR", "TEOHLCFV", 24, DateSerial(2019, 1, 1), "Kraken", True, Apikey) Test.IsEqual UBound(TestArr, 1), 26 Test.IsEqual UBound(TestArr, 2), 8 Test.IsEqual TestArr(1, 1), "time" Test.IsEqual TestArr(1, 8), "volumeto" Test.IsEqual TestArr(2, 2), #1/1/2019# Test.IsEqual TestArr(26, 2), #12/31/2018# Test.IsEqual TestArr(26, 3), 0.1022 End Sub Function PublicCryptoCompareData(Method As String, Optional ParamDict As Dictionary) As String 'For documentation, see: https://min-api.cryptocompare.com/ Dim url As String Dim Apikey As String Dim TempData As String Dim Sec As Double Dim objHeaders As New Dictionary PublicApiSite = "https://min-api.cryptocompare.com/" 'Check for API key and move that to the header of the GET request. MethodParams = "" If Not ParamDict Is Nothing Then If ParamDict.Exists("apikey") Then 'move to the end tempkey = ParamDict("apikey") ParamDict.Remove "apikey" ParamDict.Add ("api_key"), tempkey End If 'Change the rest of the parameters to JSON MethodParams = DictToString(ParamDict, "URLENC") If MethodParams <> "" Then MethodParams = "?" & MethodParams End If urlPath = Method & MethodParams url = PublicApiSite & urlPath 'Debug.Print Url 'For caching, check if data already exists IsInDict = CCDict.Exists(urlPath) GetNewData = False If IsInDict = True Then 'In dictionary, check time If CCDict(urlPath) + TimeSerial(0, 0, CCCacheSeconds) < Now() Or InStr((CCDict("DATA-" & urlPath)), "Error") > 0 Then 'Has not been updated recently and/or forced no caching, update now CCDict.Remove urlPath CCDict.Add urlPath, Now() If CCDict.Exists("DATA-" & urlPath) Then CCDict.Remove "DATA-" & urlPath GetNewData = True End If Else CCDict.Add urlPath, Now() GetNewData = True End If If GetNewData = True Then TempData = WebRequestURL(url, "GET", objHeaders) CCDict.Add "DATA-" & urlPath, TempData Else TempData = CCDict("DATA-" & urlPath) End If PublicCryptoCompareData = TempData End Function Function C_LAST_PRICE(CurrBuy As String, CurrSell As String, Optional exchange As String, Optional Apikey As String) Dim PrTxt As String Dim Json As Object Dim ParamDict As New Dictionary Application.Volatile ParamDict.Add ("fsym"), CurrBuy ParamDict.Add ("tsyms"), CurrSell If Len(exchange) > 2 Then ParamDict.Add ("e"), exchange End If If Len(Apikey) > 0 Then ParamDict.Add ("apikey"), Apikey End If PrTxt = PublicCryptoCompareData("data/price", ParamDict) Set Json = JsonConverter.ParseJson(PrTxt) If Json("Response") = "Error" Then 'Error C_LAST_PRICE = "ERROR " & Json("Message") Else C_LAST_PRICE = Json(CurrSell) End If Set Json = Nothing End Function Function C_HIST_PRICE(CurrBuy As String, CurrSell As String, DateRates As Date, Optional exchange As String, Optional Apikey As String) Dim PrTxt As String Dim Json As Object Dim ParamDict As New Dictionary Application.Volatile dt = DateToUnixTime(DateRates) ParamDict.Add ("fsym"), CurrBuy ParamDict.Add ("tsyms"), CurrSell ParamDict.Add ("ts"), dt If Len(exchange) > 2 Then ParamDict.Add ("e"), exchange End If If Len(Apikey) > 0 Then ParamDict.Add ("apikey"), Apikey End If PrTxt = PublicCryptoCompareData("data/price", ParamDict) Set Json = JsonConverter.ParseJson(PrTxt) If Json("Response") = "Error" Then 'Error C_HIST_PRICE = "ERROR " & Json("Message") Else C_HIST_PRICE = Json(CurrSell) End If Set Json = Nothing End Function Function C_DAY_AVG_PRICE(CurrBuy As String, CurrSell As String, DateRates As Date, Optional exchange As String, Optional Apikey As String) Dim PrTxt As String Dim Json As Object Dim ParamDict As New Dictionary Application.Volatile dt = DateToUnixTime(DateRates) ParamDict.Add ("fsym"), CurrBuy ParamDict.Add ("tsym"), CurrSell ParamDict.Add ("toTs"), dt If Len(exchange) > 2 Then ParamDict.Add ("e"), exchange End If If Len(Apikey) > 0 Then ParamDict.Add ("apikey"), Apikey End If PrTxt = PublicCryptoCompareData("data/dayAvg", ParamDict) Set Json = JsonConverter.ParseJson(PrTxt) If Json("Response") = "Error" Then 'Error C_DAY_AVG_PRICE = "ERROR " & Json("Message") Else C_DAY_AVG_PRICE = Json(CurrSell) End If Set Json = Nothing End Function Function C_ARR_OHLCV(DayHourMin As String, CurrBuy As String, CurrSell As String, ReturnColumns As String, Optional NrLines As Long, Optional MaxTimeDate As Date, Optional exchange As String, Optional ReverseData As Boolean, Optional Apikey As String) As Variant() 'ReturnColumns: variable "TEOHLC " -> select columns you want back in the order you want them back, no spaces 'T = timestamp (unixtime) 'E = normal excel date/time 'O = open price 'H = high price 'L = Low price 'C = close price 'F = volume From 'V = volume to Dim ExchangeTxt As String Dim PrTxt As String Dim AggrVal As String Dim cmd As String Dim utime As Long Dim Json As Object Dim TempArr As Variant Dim ParamDict As New Dictionary Dim HeadDict As New Dictionary ColumnOptions = "ETHLCOFV" HeadDict("E") = "time" HeadDict("T") = "time" HeadDict("H") = "high" HeadDict("L") = "low" HeadDict("O") = "open" HeadDict("C") = "close" HeadDict("F") = "volumefrom" HeadDict("V") = "volumeto" Application.Volatile If UCase(Right(DayHourMin, 1)) = "D" Then cmd = "data/histoday" ElseIf UCase(Right(DayHourMin, 1)) = "H" Then cmd = "data/histohour" ElseIf UCase(Right(DayHourMin, 1)) = "M" Then cmd = "data/histominute" Else 'Error ReDim TempArr(1 To 1, 1 To 1) TempArr(1, 1) = "ERROR, DayHourMin must end with D, H or M" C_ARR_OHLCV = TempArr Exit Function End If ParamDict.Add ("fsym"), CurrBuy ParamDict.Add ("tsym"), CurrSell If Len(DayHourMin) > 1 Then AggrVal = Left(DayHourMin, Len(DayHourMin) - 1) If Val(AggrVal) >= 1 And Val(AggrVal) <= 60 Then ParamDict.Add ("aggregate"), Val(AggrVal) Else 'Error ReDim TempArr(1 To 1, 1 To 1) TempArr(1, 1) = "ERROR, DayHourMin aggregation has to be from 1 to 60. Valid values are e.g. 7D, 2H or 30M" C_ARR_OHLCV = TempArr Exit Function End If End If If MaxTimeDate > DateSerial(2000, 1, 1) Then dt = DateToUnixTime(MaxTimeDate) ParamDict.Add ("toTs"), dt End If If Len(exchange) > 2 Then ParamDict.Add ("e"), exchange End If If NrLines > 0 Then ParamDict.Add ("limit"), NrLines End If If Len(Apikey) > 0 Then ParamDict.Add ("apikey"), Apikey End If PrTxt = PublicCryptoCompareData(cmd, ParamDict) Set Json = JsonConverter.ParseJson(PrTxt) If Json("Response") = "Error" Then 'Error ReDim TempArr(1 To 1, 1 To 1) TempArr(1, 1) = "ERROR " & Json("Message") C_ARR_OHLCV = TempArr Else If InStr(PrTxt, """Data"":[]") > 0 Then 'Empty result from Cryptocompare API, show user error ReDim TempArr(1 To 1, 1 To 1) TempArr(1, 1) = "ERROR, cryptocompare API gave back an empty result, try other settings" C_ARR_OHLCV = TempArr Exit Function End If ResArr = JsonToArray(Json) ResTbl = ArrayTable(ResArr, True) ReturnColumns = UCase(Trim(ReturnColumns)) 'Process all columns If Len(ReturnColumns) > 0 Then ReDim TempArr(1 To UBound(ResTbl, 2), 1 To Len(ReturnColumns)) For i = 1 To Len(ReturnColumns) itm = Mid(ReturnColumns, i, 1) itmnr = 0 For c = 1 To UBound(ResTbl, 1) If ResTbl(c, 1) = HeadDict(itm) Then itmnr = c Exit For End If Next c 'Checked for valid column types, move the data to the TempArr If itmnr > 1 Then For j = 1 To UBound(ResTbl, 2) j2 = j If ReverseData = True And j > 1 Then j2 = UBound(ResTbl, 2) - j + 2 TempArr(j2, i) = ResTbl(itmnr, j) If itm = "E" Then 'Time from Unixtime to normal date/time If j > 1 Then utime = ResTbl(itmnr, j) TempArr(j2, i) = UnixTimeToDate(utime) Else TempArr(j2, i) = ResTbl(itmnr, j) End If End If Next j Else 'Unknown column, no data to return For j = 1 To UBound(ResTbl, 2) TempArr(j, i) = "unknown ReturnColumn" Next j End If Next i C_ARR_OHLCV = TempArr Else 'No returncolumns identified, return error ReDim TempArr(1 To 1, 1 To 1) TempArr(1, 1) = "ERROR ReturnColumns, use the letters " & ColumnOptions C_ARR_OHLCV = TempArr End If End If Set Json = Nothing End Function ================================================ FILE: ModWeb.bas ================================================ Attribute VB_Name = "ModWeb" 'Source: https://github.com/krijnsent/crypto_vba 'Remember to create a new API key for excel/VBA 'Based on http://www.808.dk/?code-simplewinhttprequest Sub TestWeb() ' Create a new test suite Dim Suite As New TestSuite Suite.Description = "ModWeb" ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Suite ' Create a new test Dim Test As TestCase Set Test = Suite.Test("TestWebRequestURL") 'Testing error catching and replies TestResult = WebRequestURL("myURL", "myMethod") '{"error_nr":27,"error_txt":"invalid method for WebRequestURL","response_txt":0} Test.IsEqual Len(TestResult), 90 Test.IsEqual TestResult, "{""error_nr"":27,""error_txt"":""invalid method for WebRequestURL (myMethod)"",""response_txt"":0}" Set Test = Suite.Test("TestWebRequestURL GET") TestResult = WebRequestURL("myURL", "GET") '{"error_nr":-2147012796,"error_txt":"VBA-WinHttp.WinHttpRequest etc. Test.IsEqual Left(TestResult, 36), "{""error_nr"":-2147012795,""error_txt"":" TestResult = WebRequestURL("https://github.com/empty_url_not_there", "GET") '{"error_nr":404,"error_txt":"HTTP-Not Found"} Test.IsEqual Len(TestResult), 62 Test.IsEqual TestResult, "{""error_nr"":404,""error_txt"":""HTTP-Not Found"",""response_txt"":0}" TestResult = WebRequestURL("https://api.kraken.com/0/public/Time", "GET") '{"error":[],"result":{"unixtime":1511954132,"rfc1123":"Wed, 29 Nov 17 11:15:32 +0000"}} Test.IsEqual Len(TestResult), 87 Test.IsEqual Left(TestResult, 21), "{""error"":[],""result"":" 'Test POST command Set Test = Suite.Test("TestWebRequestURL HEAD") Dim headerDict As New Dictionary headerDict.Add "Content-Type", "application/x-www-form-urlencoded" headerDict.Add "Customheader", "MyCustomHeader" TestResult = WebRequestURL("https://httpbin.org/get", "GET", headerDict) Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("url"), "https://httpbin.org/get" Test.IsEqual JsonResult("headers").Count, 6 Test.IsEqual JsonResult("headers")("Content-Type"), "application/x-www-form-urlencoded" Test.IsEqual JsonResult("headers")("Customheader"), "MyCustomHeader" Set Test = Suite.Test("TestWebRequestURL POST") 'TEST POST TestResult = WebRequestURL("https://httpbin.org/post", "POST") Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("url"), "https://httpbin.org/post" Test.IsEqual JsonResult("headers").Count, 5 Set headerDict = Nothing headerDict.Add "Content-Type", "application/x-www-form-urlencoded" headerDict.Add "Customheader", "MyCustomHeader" TestResult = WebRequestURL("https://httpbin.org/post", "POST", headerDict) Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("url"), "https://httpbin.org/post" Test.IsEqual JsonResult("headers").Count, 7 Test.IsEqual JsonResult("headers")("Content-Type"), "application/x-www-form-urlencoded" Test.IsEqual JsonResult("headers")("Customheader"), "MyCustomHeader" TestResult = WebRequestURL("https://httpbin.org/post", "POST", , "my_post_message") Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("url"), "https://httpbin.org/post" Test.IsEqual JsonResult("data"), "my_post_message" Test.IsEqual JsonResult("headers").Count, 6 TestResult = WebRequestURL("https://httpbin.org/post", "POST", headerDict, "my_post_message_2=msg") Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("url"), "https://httpbin.org/post" Test.IsEqual JsonResult("form")("my_post_message_2"), "msg" Test.IsEqual JsonResult("headers").Count, 7 Test.IsEqual JsonResult("headers")("Customheader"), "MyCustomHeader" 'DELETE -> delete action Set Test = Suite.Test("TestWebRequestURL DELETE") TestResult = WebRequestURL("https://httpbin.org/delete", "DELETE") Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("url"), "https://httpbin.org/delete" Test.IsEqual JsonResult("headers").Count, 5 Set headerDict = Nothing headerDict.Add "Content-Type", "application/x-www-form-urlencoded" headerDict.Add "Customheader", "MyCustomHeader" TestResult = WebRequestURL("https://httpbin.org/delete", "DELETE", headerDict, "my_delete_order_nr=243") Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("url"), "https://httpbin.org/delete" Test.IsEqual JsonResult("form")("my_delete_order_nr"), "243" Test.IsEqual JsonResult("headers").Count, 7 Test.IsEqual JsonResult("headers")("Customheader"), "MyCustomHeader" 'PUT -> is an update action Set Test = Suite.Test("TestWebRequestURL PUT") TestResult = WebRequestURL("https://httpbin.org/put", "PUT") Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("url"), "https://httpbin.org/put" Test.IsEqual JsonResult("headers").Count, 5 Set headerDict = Nothing headerDict.Add "Content-Type", "application/x-www-form-urlencoded" headerDict.Add "Customheader", "MyCustomHeader" TestResult = WebRequestURL("https://httpbin.org/put", "PUT", headerDict, "my_update_nr=729") Set JsonResult = JsonConverter.ParseJson(TestResult) Test.IsEqual JsonResult("url"), "https://httpbin.org/put" Test.IsEqual JsonResult("form")("my_update_nr"), "729" Test.IsEqual JsonResult("headers").Count, 7 Test.IsEqual JsonResult("headers")("Customheader"), "MyCustomHeader" End Sub Function WebRequestURL(strURL As String, strMethod As String, Optional objHeaders As Dictionary, Optional strPostMsg As String) As String ' Instantiate a WinHttpRequest object and open it ErrResp = "{""error_nr"":ERR_NR,""error_txt"":""ERR_TXT"",""response_txt"":RESP_TXT}" 'DEFAULT: WinHttp.WinHttpRequest.5.1 Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1") 'HTTP options, can be outcommented if needed 'WinHttpRequestOption_SslErrorIgnoreFlags - 13056: ignore all err, 0: accept no err objHTTP.Option(4) = 13056 'WinHttpRequestOption_SecureProtocols - 512 = TLS 1.1, 2048 for TLS 1.2 objHTTP.Option(9) = 2048 'BACKUP (OUTCOMMENT THE 3 LINES ABOVE) 'Set objHTTP = CreateObject("MSXML2.XMLHTTP") If strMethod = "GET" Then On Error Resume Next objHTTP.Open "GET", strURL, False If Not objHeaders Is Nothing Then For Each key In objHeaders.Keys() 'e.g. objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)" objHTTP.setRequestHeader key, objHeaders(key) Next key Else 'No headers End If objHTTP.send If Err.Number = 0 Then If objHTTP.Status = "200" Then objHTTP.WaitForResponse WebRequestURL = objHTTP.responseText If Left(WebRequestURL, 1) = "<" Then WebRequestURL = Replace(Replace(Replace(ErrResp, "ERR_NR", objHTTP.Status), "ERR_TXT", "NO JSON BUT HTML RETURNED"), "RESP_TXT", 0) ElseIf Left(WebRequestURL, 1) <> "{" And Left(WebRequestURL, 1) <> "[" Then WebRequestURL = Replace(Replace(Replace(ErrResp, "ERR_NR", objHTTP.Status), "ERR_TXT", "NO VALID JSON RETURNED"), "RESP_TXT", 0) End If Else If Left(objHTTP.responseText, 1) = "{" Or Left(objHTTP.responseText, 1) = "[" Then WebRequestURL = Replace(Replace(Replace(ErrResp, "ERR_NR", objHTTP.Status), "ERR_TXT", "HTTP-" & objHTTP.StatusText), "RESP_TXT", objHTTP.responseText) Else WebRequestURL = Replace(Replace(Replace(ErrResp, "ERR_NR", objHTTP.Status), "ERR_TXT", "HTTP-" & objHTTP.StatusText), "RESP_TXT", 0) End If End If Else If IsEmpty(objHTTP.Status) Then WebRequestURL = Replace(Replace(Replace(ErrResp, "ERR_NR", Err.Number), "ERR_TXT", Err.Description), "RESP_TXT", 0) Else 'Unknown error, probably no internet connection, answer in JSON WebRequestURL = Replace(Replace(Replace(ErrResp, "ERR_NR", objHTTP.Status), "ERR_TXT", "HTTP-" & objHTTP.StatusText), "RESP_TXT", objHTTP.responseText) End If End If On Error GoTo 0 ElseIf strMethod = "POST" Or strMethod = "PUT" Or strMethod = "DELETE" Then On Error Resume Next objHTTP.Open strMethod, strURL, False If Not objHeaders Is Nothing Then For Each key In objHeaders.Keys() 'e.g. objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)" objHTTP.setRequestHeader key, objHeaders(key) Next key Else 'No headers End If If strPostMsg = "" Then objHTTP.send Else objHTTP.send (strPostMsg) End If If Err.Number = 0 Then If objHTTP.Status = "200" Then objHTTP.WaitForResponse If Left(objHTTP.responseText, 1) = "{" Or Left(objHTTP.responseText, 1) = "[" Then WebRequestURL = objHTTP.responseText Else WebRequestURL = Replace(Replace(Replace(ErrResp, "ERR_NR", objHTTP.Status), "ERR_TXT", "NO VALID JSON RETURNED"), "RESP_TXT", objHTTP.responseText) End If Else If Left(objHTTP.responseText, 1) = "{" Or Left(objHTTP.responseText, 1) = "[" Then WebRequestURL = Replace(Replace(Replace(ErrResp, "ERR_NR", objHTTP.Status), "ERR_TXT", "HTTP-" & objHTTP.StatusText), "RESP_TXT", objHTTP.responseText) Else WebRequestURL = Replace(Replace(Replace(ErrResp, "ERR_NR", objHTTP.Status), "ERR_TXT", "HTTP-" & objHTTP.StatusText), "RESP_TXT", 0) End If End If Else 'Unknown error, probably no internet connection, answer in JSON If IsEmpty(objHTTP.Status) Then WebRequestURL = Replace(Replace(Replace(ErrResp, "ERR_NR", Err.Number), "ERR_TXT", Err.Description), "RESP_TXT", 0) Else 'Unknown error, probably no internet connection, answer in JSON WebRequestURL = Replace(Replace(Replace(ErrResp, "ERR_NR", objHTTP.Status), "ERR_TXT", "HTTP-" & objHTTP.StatusText), "RESP_TXT", objHTTP.responseText) End If End If On Error GoTo 0 Else WebRequestURL = Replace(Replace(Replace(ErrResp, "ERR_NR", 27), "ERR_TXT", "invalid method for WebRequestURL (" & strMethod & ")"), "RESP_TXT", "0") End If Set objHTTP = Nothing End Function ================================================ FILE: TestCase.cls ================================================ VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "TestCase" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = True '' ' TestCase v2.0.0-beta.3 ' (c) Tim Hall - https://github.com/vba-tools/vba-test ' ' Verify a single test case with assertions ' ' @class TestCase ' @author tim.hall.engr@gmail.com ' @license MIT (https://opensource.org/licenses/MIT) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Option Explicit Private pFailures As VBA.Collection ' --------------------------------------------- ' ' Events and Properties ' --------------------------------------------- ' Public Name As String Public Context As Dictionary Public Planned As Long Public Successes As Long Public Skipped As Boolean Public Suite As TestSuite Public Property Get Result() As TestResultType If Me.Skipped Then Result = TestResultType.Skipped ElseIf Me.Successes = 0 And Me.Failures.Count = 0 Then Result = TestResultType.Pending ElseIf Me.Failures.Count > 0 Then Result = TestResultType.Fail Else Result = TestResultType.Pass End If End Property Public Property Get Failures() As Collection Dim total As Long total = Me.Successes + pFailures.Count If Me.Planned > 0 And Me.Planned <> total Then Dim message As String Dim Failure As Variant Set Failures = New Collection For Each Failure In pFailures Failures.Add Failure Next Failure message = "Total assertions, ${1}, does not equal planned, ${2}" Failures.Add FormatMessage(message, total, Me.Planned) Else Set Failures = pFailures End If End Property Public Property Get Self() As TestCase Self = Me End Property ' ============================================= ' ' Public Methods ' ============================================= ' '' ' Check if two values are deep equal (including Array, Collection, and Dictionary) ' ' @param {Variant} A ' @param {Variant} B ' @param {String} [Message] '' Public Sub IsEqual(A As Variant, B As Variant, Optional message As String = _ "Expected ${1} to equal ${2}") Check IsDeepEqual(A, B), message, A, B End Sub '' ' Check if two values are not deep equal (including Array, Collection, and Dictionary) ' ' @param {Variant} A ' @param {Variant} B ' @param {String} [Message] '' Public Sub NotEqual(A As Variant, B As Variant, Optional message As String = _ "Expected ${1} to not equal ${2}") Check Not IsDeepEqual(A, B), message, A, B End Sub '' ' Check if a value is "truthy" ' ' From https://docs.microsoft.com/en-us/dotnet/visual-basic/language-reference/statements/if-then-else-statement ' ' Must evaluate to True or False, or to a data type that is implicitly convertible to Boolean. ' If the expression is a Nullable Boolean variable that evaluates to Nothing, the condition is treated as if the expression is False. ' ' @param {Variant} Value ' @param {String} [Message] '' Public Sub IsOk(Value As Variant, Optional message As String = _ "Expected ${1} to be ok") Check Value, message, Value End Sub '' ' Check if a value is not "truthy" (See .IsOk) ' ' @param {Variant} Value ' @param {String} [Message] '' Public Sub NotOk(Value As Variant, Optional message As String = _ "Expected ${1} to not be ok") Check Not CBool(Value), message, Value End Sub '' ' Check if a value is "undefined": Nothing, Empty, Null, or Missing ' ' @param {Variant} Value ' @param {String} [Message] '' Public Sub IsUndefined(Optional Value As Variant, Optional message As String = _ "Expected ${1} to be undefined") Check IsNothing(Value) Or VBA.IsEmpty(Value) Or VBA.IsNull(Value) Or VBA.IsMissing(Value), message, Value End Sub '' ' Check if a value is not "undefined": Nothing, Empty, Null, or Missing ' ' @param {Variant} Value ' @param {String} [Message] '' Public Sub NotUndefined(Value As Variant, Optional message As String = _ "Expected ${1} to not be undefined") Check Not IsNothing(Value) And Not VBA.IsEmpty(Value) And Not VBA.IsNull(Value) And Not VBA.IsMissing(Value), message, Value End Sub '' ' Check if the current Err value contains an error with values (if given) ' ' @param {Long} [Number] ' @param {String} [Source] ' @param {String} [Description] ' @param {String} [Message} '' Public Sub IsError(Optional Number As Long, Optional Source As String, Optional Description As String, Optional message As String = _ "Expected ${1} to be an error (with Number = ${2}, Source = ${3}, Description = ${4}") If Err.Number = 0 Then pFailures.Add FormatMessage(message, "[Error Number=0]", Number, Source, Description) Exit Sub End If Check (Number = 0 Or Err.Number = Number) _ And (Source = "" Or Err.Source = Source) _ And (Description = "" Or Err.Description = Description), message, FormattedErr, Number, Source, Description End Sub '' ' Check if the current Err value does not contain an error '' Public Sub NotError(Optional message As String = "Expected ${1} to not be an error") Check Err.Number = 0, message, FormattedErr End Sub '' ' Check if a value is included in an arbitrarily nested Array or Collection ' ' @param {Array|Collection} Values ' @param {Variant} Value ' @param {String} [Message] '' Public Sub Includes(Values As Variant, Value As Variant, Optional message As String = _ "Expected ${2} to be included in ${1}") If IsCollection(Values) Then Check CollectionIncludes(Values, Value), message, Values, Value ElseIf IsArray(Values) Then Check ArrayIncludes(Values, Value), message, Values, Value Else pFailures.Add FormatMessage(message, Values, Value) & " (Incompatible type for Values)" End If End Sub '' ' Check if a value is not included in an arbitrarily nested Array or Collection ' ' @param {Array|Collection} Values ' @param {Variant} Value ' @param {String} [Message] '' Public Sub NotIncludes(Values As Variant, Value As Variant, Optional message As String = _ "Expected ${2} not to be included in ${1}") If IsCollection(Values) Then Check Not CollectionIncludes(Values, Value), message, Values, Value ElseIf IsArray(Values) Then Check Not ArrayIncludes(Values, Value), message, Values, Value Else pFailures.Add FormatMessage(message, Values, Value) & " (Incompatible type for Values)" End If End Sub '' ' Check if two values are approximately equal, up to the given amount of significant figures ' ' @example ' ```vb ' .IsApproximate 1.001, 1.002, 3 ' ' ' Equivalent to .IsEqual 1.00e+0, 1.00e+0 ' ``` ' @param {Variant} A ' @param {Variant} B ' @param {String} [Message] '' Public Sub IsApproximate(A As Variant, B As Variant, SignificantFigures As Integer, Optional message As String = _ "Expected ${1} to be approximately equal to ${2} (with ${3} significant figures of precision)") If SignificantFigures < 1 Or SignificantFigures > 15 Then pFailures.Add "IsApproximate can only compare from 1 to 15 significant figures" Else Check IsApproximatelyEqual(A, B, SignificantFigures), message, A, B, SignificantFigures End If End Sub '' ' Check if two values are approximately equal, up to the given amount of significant figures ' ' @example ' ```vb ' .NotApproximate 1.001, 1.009, 3 ' ' ' Equivalent to .IsEqual 1.00e+0, 1.01e+0 ' ``` ' @param {Variant} A ' @param {Variant} B ' @param {String} [Message] '' Public Sub NotApproximate(A As Variant, B As Variant, SignificantFigures As Integer, Optional message As String = _ "Expected ${1} to not be approximately equal to ${2} (with ${3} significant figures of precision)") If SignificantFigures < 1 Or SignificantFigures > 15 Then pFailures.Add "NotApproximate can only compare from 1 to 15 significant figures" Else Check Not IsApproximatelyEqual(A, B, SignificantFigures), message, A, B, SignificantFigures End If End Sub '' ' Mark the test as passing '' Public Sub Pass() Me.Successes = 1 Set pFailures = New Collection End Sub '' ' Mark the test as failing ' ' @param {String} {Message] '' Public Sub Fail(Optional message As String = _ "Test failed unexpectedly") pFailures.Add message End Sub '' ' Set the planned number of assertions for the test ' ' @param {Long} Count '' Public Sub Plan(Count As Long) Planned = Count End Sub '' ' Mark the test as skipped '' Public Sub Skip() Me.Skipped = True End Sub ' ============================================= ' ' Private Functions ' ============================================= ' Private Sub Check(Assertion As Variant, message As String, ParamArray Values() As Variant) If Assertion Then Me.Successes = Me.Successes + 1 Else pFailures.Add FormatMessage(message, Values) End If End Sub Private Function IsDeepEqual(A As Variant, B As Variant) As Boolean Dim AType As VbVarType Dim BType As VbVarType AType = VBA.VarType(A) BType = VBA.VarType(B) If VBA.IsError(A) Or VBA.IsError(B) Then IsDeepEqual = False ElseIf VBA.IsArray(A) And VBA.IsArray(B) Then IsDeepEqual = IsArrayEqual(A, B) ElseIf AType = VBA.vbObject Or BType = VBA.vbObject Then If AType <> BType Or VBA.TypeName(A) <> VBA.TypeName(B) Then IsDeepEqual = False ElseIf VBA.TypeName(A) = "Collection" Then IsDeepEqual = IsCollectionEqual(A, B) ElseIf VBA.TypeName(A) = "Dictionary" Then IsDeepEqual = IsDictionaryEqual(A, B) Else IsDeepEqual = A Is B End If ElseIf VBA.VarType(A) = VBA.vbDouble Or VBA.VarType(B) = VBA.vbDouble Then ' It is inherently difficult/almost impossible to check equality of Double ' http://support.microsoft.com/kb/78113 ' ' -> Compare up to 15 significant figures IsDeepEqual = IsApproximatelyEqual(A, B, 15) Else IsDeepEqual = A = B End If End Function Private Function IsArrayEqual(A As Variant, B As Variant) As Boolean If UBound(A) <> UBound(B) Then IsArrayEqual = False Exit Function End If Dim i As Long For i = LBound(A) To UBound(A) If Not IsDeepEqual(A(i), B(i)) Then IsArrayEqual = False Exit Function End If Next i IsArrayEqual = True End Function Private Function IsCollectionEqual(A As Variant, B As Variant) As Boolean If A.Count <> B.Count Then IsCollectionEqual = False Exit Function End If Dim i As Long For i = 1 To A.Count If Not IsDeepEqual(A(i), B(i)) Then IsCollectionEqual = False Exit Function End If Next i IsCollectionEqual = True End Function Private Function IsDictionaryEqual(A As Variant, B As Variant) As Boolean If UBound(A.Keys) <> UBound(B.Keys) Then IsDictionaryEqual = False Exit Function End If Dim AKeys As Variant Dim BKeys As Variant Dim i As Long AKeys = A.Keys BKeys = B.Keys For i = LBound(AKeys) To UBound(AKeys) If AKeys(i) <> BKeys(i) Or A.Item(AKeys(i)) <> B.Item(BKeys(i)) Then IsDictionaryEqual = False Exit Function End If Next i IsDictionaryEqual = True End Function Private Function IsCollection(Value As Variant) As Boolean IsCollection = VBA.VarType(Value) = VBA.vbObject And VBA.TypeName(Value) = "Collection" End Function Private Function IsNothing(Value As Variant) As Boolean If VBA.IsObject(Value) Then IsNothing = Value Is Nothing Else IsNothing = False End If End Function Private Function ArrayIncludes(Values As Variant, Value As Variant) As Boolean Dim i As Long For i = LBound(Values) To UBound(Values) If VBA.IsArray(Values(i)) Then If ArrayIncludes(Values(i), Value) Then ArrayIncludes = True Exit Function End If ElseIf IsCollection(Values(i)) Then If CollectionIncludes(Values(i), Value) Then ArrayIncludes = True Exit Function End If ElseIf IsDeepEqual(Values(i), Value) Then ArrayIncludes = True Exit Function End If Next i ArrayIncludes = False End Function Private Function CollectionIncludes(Values As Variant, Value As Variant) As Boolean Dim Item As Variant For Each Item In Values If VBA.IsArray(Item) Then If ArrayIncludes(Item, Value) Then CollectionIncludes = True Exit Function End If ElseIf IsCollection(Item) Then If CollectionIncludes(Item, Value) Then CollectionIncludes = True Exit Function End If ElseIf IsDeepEqual(Item, Value) Then CollectionIncludes = True Exit Function End If Next Item CollectionIncludes = False End Function Private Function IsApproximatelyEqual(A As Variant, B As Variant, SignificantFigures As Integer) As Boolean If SignificantFigures < 1 Or SignificantFigures > 15 Or VBA.IsError(A) Or VBA.IsError(B) Then IsApproximatelyEqual = False Exit Function End If Dim AValue As String Dim BValue As String AValue = VBA.Format$(A, VBA.Left$("0.00000000000000", SignificantFigures + 1) & IIf(A > 1, "e+0", "e-0")) BValue = VBA.Format$(B, VBA.Left$("0.00000000000000", SignificantFigures + 1) & IIf(B > 1, "e+0", "e-0")) IsApproximatelyEqual = AValue = BValue End Function Private Function FormatMessage(message As String, ParamArray Values() As Variant) As String Dim Value As Variant Dim Index As Long FormatMessage = message For Each Value In IIf(VBA.IsArray(Values(0)), Values(0), Values) Index = Index + 1 FormatMessage = VBA.Replace(FormatMessage, "${" & Index & "}", PrettyPrint(Value)) Next Value End Function Private Function PrettyPrint(Value As Variant, Optional Indentation As Long = 0) As String If VBA.IsMissing(Value) Then PrettyPrint = "[Missing]" Exit Function End If Dim i As Long Dim Indented As String Indented = VBA.String$(Indentation + 1, " ") Select Case VBA.VarType(Value) Case VBA.vbObject ' Nothing If Value Is Nothing Then PrettyPrint = "[Nothing]" ' Collection ElseIf VBA.TypeName(Value) = "Collection" Then PrettyPrint = "[Collection [" & vbNewLine For i = 1 To Value.Count PrettyPrint = PrettyPrint & Indent(Indentation + 1) & _ PrettyPrint(Value(i), Indentation + 1) & _ IIf(i <> Value.Count, ",", "") & vbNewLine Next i PrettyPrint = PrettyPrint & Indent(Indentation) & "]" ' Dictionary ElseIf VBA.TypeName(Value) = "Dictionary" Then PrettyPrint = "[Dictionary {" & vbNewLine For i = LBound(Value.Keys) To UBound(Value.Keys) PrettyPrint = PrettyPrint & Indent(Indentation + 1) & _ Value.Keys(i) & ": " & _ PrettyPrint(Value.Item(Value.Keys(i)), Indentation + 1) & _ IIf(i <> Value.Count, ",", "") & vbNewLine Next i PrettyPrint = PrettyPrint & Indent(Indentation) & "}]" ' Object Else PrettyPrint = "[" & VBA.TypeName(Value) & "]" End If ' Array Case VBA.vbArray To VBA.vbArray + VBA.vbByte PrettyPrint = "[" & vbNewLine For i = LBound(Value) To UBound(Value) PrettyPrint = PrettyPrint & Indent(Indentation + 1) & _ PrettyPrint(Value(i), Indentation + 1) & _ IIf(i <> UBound(Value), ",", "") & vbNewLine Next i PrettyPrint = PrettyPrint & Indent(Indentation) & "]" ' Empty Case VBA.vbEmpty PrettyPrint = "[Empty]" ' Null Case VBA.vbNull PrettyPrint = "[Null]" ' String Case VBA.vbString PrettyPrint = """" & Value & """" ' Everything else Case Else PrettyPrint = CStr(Value) End Select End Function Private Function FormattedErr() As String Dim ErrNumberDetails As String ErrNumberDetails = IIf(Err.Number < 0, " (" & (Err.Number - vbObjectError) & " / " & VBA.LCase$(VBA.Hex$(Err.Number)) & ")", "") FormattedErr = "[Error Number=" & Err.Number & ErrNumberDetails & ", Source=" & Err.Source & ", Description=" & Err.Description & "]" End Function Private Function Indent(Optional Indentation As Long) Indent = VBA.String$(Indentation, " ") End Function Private Sub Class_Initialize() Set Me.Context = New Dictionary Set pFailures = New VBA.Collection End Sub Private Sub Class_Terminate() Me.Suite.TestComplete Me Set Me.Context = Nothing End Sub ================================================ FILE: TestSuite.cls ================================================ VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "TestSuite" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = True '' ' TestSuite v2.0.0-beta.3 ' (c) Tim Hall - https://github.com/vba-tools/vba-test ' ' A collection of tests, with events and results ' ' @class TestSuite ' @author tim.hall.engr@gmail.com ' @license MIT (https://opensource.org/licenses/MIT) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Option Explicit ' --------------------------------------------- ' ' Types, Events, and Properties ' --------------------------------------------- ' Public Enum TestResultType Pass Fail Pending Skipped End Enum Public Event BeforeEach(Test As TestCase) Public Event Result(Test As TestCase) Public Event AfterEach(Test As TestCase) '' ' (Optional) description of suite for display in runners ' ' @property Description ' @type String '' Public Description As String '' ' @property Tests ' @type Collection '' Public Tests As VBA.Collection '' ' Compute suite result from tests ' ' @property Result ' @type SpecResultType '' Public Property Get Result() As TestResultType Result = TestResultType.Pending Dim Test As TestCase For Each Test In Me.Tests If Test.Result = TestResultType.Pass Then Result = TestResultType.Pass ElseIf Test.Result = TestResultType.Fail Then Result = TestResultType.Fail Exit For End If Next Test End Property '' ' @property PassedTests ' @type Collection '' Public Property Get PassedTests() As VBA.Collection Set PassedTests = GetTestsByType(TestResultType.Pass) End Property '' ' @property FailedTests ' @type Collection '' Public Property Get FailedTests() As VBA.Collection Set FailedTests = GetTestsByType(TestResultType.Fail) End Property '' ' @property PendingTests ' @type Collection '' Public Property Get PendingTests() As VBA.Collection Set PendingTests = GetTestsByType(TestResultType.Pending) End Property '' ' @property SkippedTests ' @type Collection '' Public Property Get SkippedTests() As VBA.Collection Set SkippedTests = GetTestsByType(TestResultType.Skipped) End Property ' ============================================= ' ' Public Methods ' ============================================= ' '' ' Create a new test case with name ' ' @method Test ' @param {String} Name ' @returns {TestCase} '' Public Function Test(Name As String) As TestCase Dim Instance As New TestCase Instance.Name = Name Set Instance.Suite = Me RaiseEvent BeforeEach(Instance) Set Test = Instance End Function Public Sub TestComplete(Test As TestCase) Tests.Add Test RaiseEvent Result(Test) RaiseEvent AfterEach(Test) End Sub ' ============================================= ' ' Private Functions ' ============================================= ' Private Function GetTestsByType(ResultType As TestResultType) As Collection Dim Test As TestCase Dim Filtered As New VBA.Collection For Each Test In Me.Tests If Test.Result = ResultType Then Filtered.Add Test End If Next Test Set GetTestsByType = Filtered End Function Private Sub Class_Initialize() Set Tests = New VBA.Collection End Sub ================================================ FILE: WorkbookReporter.cls ================================================ VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "WorkbookReporter" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = True '' ' DisplayReporter v2.0.0-beta.3 ' (c) Tim Hall - https://github.com/VBA-tools/VBA-TDD ' ' Report results to Worksheet ' ' @class DisplayReporter ' @compatibility ' Platforms: Windows and Mac ' Applications: Excel-only ' @author tim.hall.engr@gmail.com ' @license MIT (https://opensource.org/licenses/MIT) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Option Explicit ' --------------------------------------------- ' ' Constants and Private Variables ' --------------------------------------------- ' Private Const ProgressWidth As Long = 128 Private pSheet As Worksheet Private pCount As Long Private pTotal As Long Private pSuites As Collection ' ============================================= ' ' Public Methods ' ============================================= ' '' ' Connect the display runner to a Worksheet to output results ' ' The given Worksheet should have names for: ' - "Progress" (Shape with width) ' - "ProgressBorder" (Shape) ' - "Result" (Cell) - Cell to output overall result ' - "Output" (Cell) - First cell to output results ' ' @method ConnectTo ' @param {Worksheet} Sheet '' Public Sub ConnectTo(Sheet As Worksheet) Set pSheet = Sheet End Sub '' ' Call this at the beginning of a test run to reset the worksheet ' (pass overall number of test suites that will be run to display progress) ' ' @method Start ' @param {Long} [NumSuites = 0] '' Public Sub Start(Optional NumSuites As Long = 0) pCount = 0 pTotal = NumSuites ClearResults ShowProgress DisplayResult "Running" End Sub '' ' Output the given suite ' ' @method Output ' @param {TestSuite} Suite '' Public Sub Output(Suite As TestSuite) pCount = pCount + 1 pSuites.Add Suite ShowProgress DisplayResults End Sub '' ' After outputing all suites, display overall result ' ' @method Done '' Public Sub Done() Dim Failed As Boolean Dim Suite As TestSuite For Each Suite In pSuites If Suite.Result = TestResultType.Fail Then Failed = True Exit For End If Next Suite DisplayResult IIf(Failed, "FAIL", "PASS") End Sub ' ============================================= ' ' Private Functions ' ============================================= ' Private Sub ShowProgress() If pTotal <= 0 Then HideProgress Exit Sub End If Dim Percent As Double Percent = pCount / pTotal If Percent > 1 Then Debug.Print "WARNING: DisplayRunner has output more suites than specified in Start" Percent = 1 End If pSheet.Shapes("Progress").Width = ProgressWidth * Percent pSheet.Shapes("Progress").Visible = True pSheet.Shapes("ProgressBorder").Visible = True End Sub Private Sub HideProgress() pSheet.Shapes("Progress").Visible = False pSheet.Shapes("ProgressBorder").Visible = False End Sub Private Sub DisplayResult(Value As String) With pSheet.Range("Result") .Font.Size = IIf(Value = "Running", 12, 14) .Value = Value End With End Sub Private Sub ClearResults() Dim StartRow As Long Dim StartColumn As Long StartRow = pSheet.Range("Output").Row StartColumn = pSheet.Range("Output").Column Dim lastrow As Long lastrow = StartRow Do While pSheet.Cells(lastrow + 1, StartColumn).Value <> "" lastrow = lastrow + 1 Loop With pSheet.Range(pSheet.Cells(StartRow, StartColumn), pSheet.Cells(lastrow, StartColumn + 1)) .Value = "" .Font.Bold = False .Borders(xlInsideHorizontal).LineStyle = xlNone End With End Sub Private Sub DisplayResults() Dim Rows As New Collection Dim Dividers As New Collection Dim Headings As New Collection Dim Suite As TestSuite Dim Test As TestCase Dim Failure As Variant For Each Suite In pSuites If Rows.Count > 0 Then Dividers.Add Rows.Count End If If Suite.Description <> "" Then Headings.Add Rows.Count Rows.Add Array(Suite.Description, ResultTypeToString(Suite.Result)) End If For Each Test In Suite.Tests If Test.Result <> TestResultType.Skipped Then Rows.Add Array(Test.Name, ResultTypeToString(Test.Result)) For Each Failure In Test.Failures Rows.Add Array(" " & Failure, "") Next Failure End If Next Test Next Suite Dim OutputValues() As String Dim Row As Variant Dim i As Long ReDim OutputValues(Rows.Count - 1, 1) i = 0 For Each Row In Rows OutputValues(i, 0) = Row(0) OutputValues(i, 1) = Row(1) i = i + 1 Next Row Dim StartRow As Long Dim StartColumn As Long StartRow = pSheet.Range("Output").Row StartColumn = pSheet.Range("Output").Column pSheet.Range(pSheet.Cells(StartRow, StartColumn), pSheet.Cells(StartRow + Rows.Count - 1, StartColumn + 1)).Value = OutputValues Dim Divider As Variant For Each Divider In Dividers With pSheet.Range(pSheet.Cells(StartRow + Divider, StartColumn), pSheet.Cells(StartRow + Divider, StartColumn + 1)).Borders(xlEdgeTop) .LineStyle = xlContinuous .Color = VBA.RGB(191, 191, 191) .Weight = xlThin End With Next Divider Dim Heading As Variant For Each Heading In Headings pSheet.Cells(StartRow + Heading, StartColumn).Font.Bold = True Next Heading End Sub Private Function ResultTypeToString(ResultType As TestResultType) As String Select Case ResultType Case TestResultType.Pass ResultTypeToString = "Pass" Case TestResultType.Fail ResultTypeToString = "Fail" Case TestResultType.Pending ResultTypeToString = "Pending" End Select End Function Private Sub Class_Initialize() Set pSuites = New Collection End Sub ================================================ FILE: _config.yml ================================================ theme: jekyll-theme-leap-day ================================================ FILE: readme.md ================================================ # crypto_vba An Excel/VBA project to communicate with various cryptocurrency exchanges APIs. Tested on Windows 10 & Excel 365, but should work for Excel 2007+. Note: project is on hold - I'm working on other things and don't have the time & energy to jump through all the KYC hoops of exchanges to keep my accounts and test my code. # Exchanges: Get information from/send information to: - [Binance](http://binance.com/) - [Bitfinex](https://www.bitfinex.com/) - [Bitmex](https://www.bitmex.com/) - [Bitstamp](https://www.bitstamp.net/) - [Bittrex](https://www.bittrex.com/) - [BitVavo](https://www.bitvavo.com/) - [Bybit](https://www.bybit.com/) - [Coinbase](https://www.coinbase.com) - [CoinbasePro](https://pro.coinbase.com/) - [Coinone](https://coinone.co.kr/) - [Coinspot](https://www.coinspot.com.au/) - [HitBTC](https://hitbtc.com/) - [Huobi](https://www.huobi.com/) - [Kraken](https://www.kraken.com/) - [Kucoin](https://www.kucoin.com/) - [OKEx](https://www.okex.com/) - [Poloniex](https://www.poloniex.com/) - [Coinigy](https://www.coinigy.com/) - not an exchange, but a service where you can access multiple exchanges for a fee - not actively maintained - [Cryptopia] -> hacked & closed - [GDAX] -> see CoinbasePro - [Liqui] -> exchange closed - [WEXnz] -> exchange closed, removed Most API messages/responses are pure JSON, for which I included https://github.com/VBA-tools/VBA-JSON to process and a function to build on that. As excel/VBA development is not very compatible with GIT, my pushes/forks/updates might be clunky. Please consider the code I provide as simple building blocks: if you want to build a project based on this code, you will have to know (some) VBA. There are plenty of courses available online, two simple ones I send starters to are: https://www.excel-pratique.com/en/ and https://homeandlearn.org/. # How to use? Import the .bas files you need or simply take the sample Excel file. In the modules you'll find some examples how to use the code. Feel free to create an issue if things don't work for you. The project uses quite some Dictionaries in VBA, check out e.g. https://excelmacromastery.com/vba-dictionary/ if you want to know a bit more about them. You do need some references in your VBA editor (already set up in the example file): - Visual Basic For Applications --- C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA7.1\VBE7.DLL - Microsoft Excel 16.0 Object Library --- C:\Program Files (x86)\Microsoft Office\Root\Office16\EXCEL.EXE - Microsoft Forms 2.0 Object Library --- C:\WINDOWS\SysWOW64\FM20.DLL - Microsoft Scripting Runtime C:\Windows\SysWOW64\scrrun.dll - Microsoft Visual Basic for Applications Extensibility 5.3 --- C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB - Microsoft HTML Object Library --- C:\Windows\SysWOW64\mshtml.tlb And you do need .NET 3.5 or greater on your system, as it's used by the hashing algorithms (System.Security.Cryptography) # Virus warnings From 2021 several issues have been filed that my example file (the xlsm file) triggers a virus warning, e.g. issue #67 & #73. I have no idea what triggers this (I didn't put any virus in) and have no idea how to solve it, suggestions are very welcome. A solution if you want to use the code is to import the .bas modules & setting up the right references yourself. An alternative: - download the Github desktop app : https://desktop.github.com/ - clone the repository "URL": https://github.com/krijnsent/crypto_vba - all files are in your local folder and the file should open without warning # ToDo - Excel formulas need better caching to prevent a stalling/crashing Excel - an RTD would be a solution, but that's out of scope for me - Better error handling - Updating/adding exchanges: do create an issue if you want an exchange added/updated, as I'm not checking them. # Done - For historical prices, included https://www.cryptocompare.com/api/ (now https://min-api.cryptocompare.com/ ) - Build excel functions to get the information directly to a sheet, has some caching, but - BETA STAGE - use at own risk - Working examples of several exchanges in the example file - Created a basic XLSM sample file for all provided exchanges - ArrayToTable improvement to handle various data types (e.g. Trade and Margin trade) in one JSON response - Post-process the Array to a more usable format (flat table) - Process the response to something you can use in Excel: an array/Range etc. - Build a function to transform the JSON to an Array - Build tests for all modules/functions - Integrate VBA-JSON into the project - Build the Binance API connector - Build the Bitfinex API connector - Build the Bitstamp API connector - Build the Bittrex API connector - Build the Bitvavo API connector - Build the Coinbase API connector - Build the CoinbasePro API connector - Build the Coinone API connector - Build the Coinspot API connector - Build the HitBTC API connector - Build the Kraken API connector - Build the Kucoin API connector - Build the OKEx API connector - Build the Poloniex API connector - Build a working and tested VBA hash function - Build a function to transform Dictionaries into JSON and URLencode - Added the UrlEncode function for e.g. Cryptopia (and Excel versions before 2016) - Removed inactive exchanges: Liqui, WEXnz/BTCe (nostalgia, that was the first exchange i got working in excel) # Donate If this project/the Excel saves you a lot of programming time, consider sending me a coffee or a beer:
BTC: 1DNFF9y3dDMLNURpgdT3wXmFpmGBsQRyPa
ETH (or ERC-20 tokens): 0x9070C5D93ADb58B8cc0b281051710CB67a40C72B
Stellar: GCRCMHEXS4BHZQSCH4O4LHT24ZK2GTKOHML5KZ6HS5E3GV5RPVBDGDGB Cheers!