When using QueryTables what is .PostText syntax to click a button on webpage

chuckchuckit

Well-known Member
Joined
Sep 18, 2010
Messages
541
Below QueryTables code works to import Annual data table from Yahoo Finance. But I need to click the “Quarterly” button for Quarterly data. Quarterly button must be clicked because both Annual and Quarterly use the same URL.

What is syntax for QueryTables.PostText to click the Quartery button (I think .PostText is how to do it)?

QueryTables is fast, so I don’t want to use an Internet Explorer objects version because IE is slow and has lockup issues etc. Although I did get IE to click the Quarterly button after looping through the objects from the button class object. Here is the Yahoo page source code for the Quarterly button class:

"button class=P(0px) M(0px) C($actionBlue) Bd(0px) O(n)"

What is the syntax for this to work with WebTables? Thank you.

Working code for the Annual data:

Code:
Sub PostTextQuery()
    
    Dim i As Integer
    Dim MyPost As String
    Dim URLstr As String
    
    URLstr = "URL;http://finance.yahoo.com/quote/IBM/financials?p=IBM"

    Range("J10:O47").Clear 'Clear any previous data from query area.

    'Delete any previous query tables (or file size grows when saving file).
    With Worksheets("Sheet1")
        For i = .QueryTables.Count To 1 Step -1
            .QueryTables(i).Delete
        Next
    End With

    MyPost = "" 'Is this where the click Quarterly button code goes??

    With ActiveSheet.QueryTables.Add(Connection:=URLstr, Destination:=Range("J10"))
        .PostText = MyPost
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = True
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = False
        .RefreshStyle = x1OverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0 'is 0 cuz just a 1 time query
        .WebSelectionType = xlSpecifiedTables 
        .WebFormatting = xlWebFormattingNone 
        .WebTables = "1,2,3,4,5,6,7,8,9" 'display any possible page tables
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False 'False = query will finish before any more code will run
    End With
            
    'Remove connection
    Dim TheConnectionName As String
    For Each objWBConnect In ThisWorkbook.Connections
        TheConnectionName = objWBConnect.Name 'found
        ActiveWorkbook.Connections(TheConnectionName).Delete 'removes connection
    Next objWBConnect
  
End Sub
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
In reply to your PM I've had a long, detailed look at this and was only successful with IE automation. I didn't get anywhere with a web query/QueryTables on the Quarterly data.

If you use your browser's developer tools and click Quarterly you will see it sends 2 POST requests to a long URL (http://udc.yahoo.com/v2/public/yql?.....), but the response is empty. Therefore, even if you could construct the same URL with the correct POST data (form data) you wouldn't receive the Quarterly data. I don't know how the page is getting the data.

I also tried Yahoo Query Language (YQL), using the Yahoo Console, as explained at Getting data from Yahoo Finance - Stack Overflow. I searched for tables containing "income" and found yahoo.finance.incomestatement. I changed the select query to SELECT * FROM yahoo.finance.incomestatement WHERE symbol='IBM', and clicked Test, however no results are returned - they are meant to be in the < results > tag. The problem is explained in detail at finance - YQL not returning data from balance sheet or income statement - Stack Overflow, although that analysis is 2 years old and slightly out of date because the Yahoo page no longer has the table with class "yfnc_tabledata1".

I also tried CreateDocumentFromUrl, but it didn't retrieve anything useful, probably because the page uses iframes.

Here is the IE automation code which works for me - it retrieves the Annual and Quarterly Income Statement data. You must set the references shown at the top of the code via Tools -> References in the VBA editor.

Code:
'Required references
'Microsoft Internet Controls
'Microsoft HTML Object Library


Option Explicit

'https://msdn.microsoft.com/en-us/library/office/gg264421.aspx
'64-Bit Visual Basic for Applications Overview

#If VBA7 Then
    'New VBA version 7 compiler, therefore >= Office 2010
    'PtrSafe means function works in 32-bit and 64-bit Office
    'LongPtr type alias resolves to Long (32 bits) in 32-bit Office, or LongLong (64 bits) in 64-bit Office
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
    Private Declare PtrSafe Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
#Else
    'Old VBA version 6 or earlier compiler, therefore <= Office 2007
    Private Declare Sub Sleep Lib "kernel32" (ByVal milliseconds As Long)
    Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
#End If


Public Sub IE_Yahoo_Finance_Income_Statement()

    Dim IE As InternetExplorer
    Dim URL As String
    Dim HTMLdoc As HTMLDocument
    Dim newIEwindow As Boolean
    Dim buttons As IHTMLElementCollection, button As HTMLButtonElement
    Dim dataTable As HTMLTable, tRow As HTMLTableRow, tCell As HTMLTableCell
    Dim destCell As Range
    Dim i As Long
    
    With Worksheets(1)
        .Cells.Clear
        Set destCell = .Range("A1")
    End With
    
    URL = "http://finance.yahoo.com/quote/IBM/financials?p=IBM"
        
    newIEwindow = False
    Set IE = Get_IE_Window2(URL)        'get the existing Yahoo IE window
    If IE Is Nothing Then
        Set IE = New InternetExplorer
        newIEwindow = True
    End If
    
    'Navigate to the web site
    
    With IE
        SetForegroundWindow .hwnd
        .navigate URL
        While .Busy Or .readyState <> READYSTATE_COMPLETE: DoEvents: Wend
        .Visible = True
        Set HTMLdoc = .document
    End With

    destCell.Value = "Annual"
    Set destCell = destCell.Offset(1)
    
    'Get table containing Annual Income Statement data
    '< table class="Lh(1.7) W(100%) M(0)" >

    Do
        Set dataTable = HTMLdoc.getElementsByClassName("Lh(1.7) W(100%) M(0)")(0)
        DoEvents
    Loop While dataTable Is Nothing
    
    For Each tRow In dataTable.Rows
        For Each tCell In tRow.Cells
            'Debug.Print tCell.innerText
            destCell.Offset(tRow.RowIndex, tCell.cellIndex).Value = tCell.innerText
        Next
    Next
    
    Set destCell = destCell.Offset(dataTable.Rows.Length + 2)
    destCell.Value = "Quarterly"
    Set destCell = destCell.Offset(1)
    
    'Find Quarterly button
    '< button class="P(0px) M(0px) C($actionBlue) Bd(0px) O(n)" >
    '< div class="Fz(s) Fw(500) D(ib) Pend(15px) H(18px) C($finDarkLink):h Mend(15px) C($actionBlue)" >
    '< span >Quarterly< /span >
    '< /div >< /button >
    
    Set buttons = HTMLdoc.getElementsByClassName("P(0px) M(0px) C($actionBlue) Bd(0px) O(n)")
    Set button = Nothing
    i = 0
    While i < buttons.Length
        If buttons(i).innerText = "Quarterly" Then Set button = buttons(i)
        i = i + 1
    Wend
    
    If Not button Is Nothing Then
        button.Click
    
        While IE.Busy Or IE.readyState <> READYSTATE_COMPLETE: DoEvents: Wend
    
        'Get table containing Quarterly Income Statement data
        '< table class="Lh(1.7) W(100%) M(0)" >
    
        Do
            Set dataTable = HTMLdoc.getElementsByClassName("Lh(1.7) W(100%) M(0)")(0)
            DoEvents
        Loop While dataTable Is Nothing
        
        For Each tRow In dataTable.Rows
            For Each tCell In tRow.Cells
                'Debug.Print tCell.innerText
                destCell.Offset(tRow.RowIndex, tCell.cellIndex).Value = tCell.innerText
            Next
        Next
        
    Else
    
        MsgBox "Quarterly link button not found on " & IE.LocationURL
    
    End If
    
    If newIEwindow Then IE.Quit
    Set IE = Nothing
        
End Sub


Private Function Get_IE_Window2(URLorName As String) As SHDocVw.InternetExplorer

    'Look for an IE browser window or tab already open at the (partial) URL or location name and, if found, return
    'that browser as an InternetExplorer object.  Otherwise return Nothing

    Dim Shell As Object
    Dim IE As SHDocVw.InternetExplorer
    Dim i As Variant 'Must be a Variant to index Shell.Windows.Item() array
    
    Set Shell = CreateObject("Shell.Application")
    
    i = 0
    Set Get_IE_Window2 = Nothing
    While i < Shell.Windows.Count And Get_IE_Window2 Is Nothing
        Set IE = Shell.Windows.Item(i)
        If Not IE Is Nothing Then
            'Debug.Print IE.LocationURL, IE.LocationName
            If TypeOf IE Is SHDocVw.InternetExplorer And InStr(IE.LocationURL, "file://") <> 1 Then
                'Debug.Print IE.LocationName, IE.LocationURL
                If InStr(1, IE.LocationURL, URLorName, vbTextCompare) > 0 Or InStr(1, IE.LocationName, URLorName, vbTextCompare) > 0 Then
                    Set Get_IE_Window2 = IE
                End If
            End If
        End If
        i = i + 1
    Wend
    
End Function
 
Last edited:
Upvote 0
Hi John,
That is some very nice code work with IE to click the Quarterly button and get the data. I’ll be going over it in more detail to learn more. Works flawlessly appreciate your extensive efforts!

I have spent days on this and also have a version of IE working but not as elaborate, I’ll learn more from your code and those link examples. Many, many, of my projects have a lot of pieces of your VBA code that I have found while searching the internet for solutions. RS-232, HTML node searching etc. So your various coding is definitely used a lot in my projects.

I have found using IE here works for small quantity use, but for hundreds of times compiling data IE browser for my requirements is too slow and starts hanging, locks up occasionally and eventually seems to bring in Malware/computer issues.

Querytables is much faster but I too could not get the .PostText to click the Quarterly button. I tried everything. Even if Querytables.PostText did click, perhaps a timing issue might come into play to get the data from that same query if the clicked Quarterly screen did not update right away from Yahoo? It seems to be some sort of internal Yahoo page update to display the clicked Quarterly (since the URL does not change with the click). So Querytables seems a nogo.

So I tried other approaches that were faster than IE and I got responses back, but could never figure the button click syntax there either. They use Open POST procedures such as:

MSXML2.XMLHTTP60
Link: internet explorer - VBA hanging on ie.busy and readystate check - Stack Overflow

MSXML2.XMLHttp
Link: https://codingislove.com/http-requests-excel-vba/

Below is “MSXML2.XMLHttp” code that is close to working. MsgBox shows some Yahoo source code coming back, and I coded IE after that “only” as a way of looking at the Yahoo page itself as the response back. But I was not able to get the syntax right for “XMLHttp.send” it’s syntax is supposed to be something vaguely along the lines of “input1=Hello&input2=World&idValue=12345” which I have not been able to understand yet.


Code:
Public Sub httpclient()
'link: https://codingislove.com/http-requests-excel-vba/
'Will need Microsoft HTML object Library in Tools References.
'This MSXML format much faster, less prone to hanging than IE browser

    Dim XMLHttp As New MSXML2.XMLHttp 'I think this is the required early binding.
    Dim MyUrl As String

    MyUrl = "http://finance.yahoo.com/quote/IBM/financials?p=IBM"

    XMLHttp.Open "POST", MyUrl, False

    XMLHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"

    XMLHttp.send "" '...put Quarterly click code here??

    MsgBox (XMLHttp.responseText) 'This gets back some of the source code for the IBM Yahoo finance page!!!!
    
    '*** Now check the response back, through IE browser ***
    
    Dim objIE As Object

    Set objIE = CreateObject("InternetExplorer.Application")
    'While objIE.Busy Or objIE.ReadyState <> READYSTATE_COMPLETE: DoEvents: Wend
    objIE.Navigate "about:blank"
    objIE.Visible = True

    objIE.document.Write XMLHttp.responseText 'This displays the yahoo page as it after POST send.
    
    objIE.Quit
    Set objIE = Nothing
    Set XMLHttp = Nothing
End Sub


Thanks again.

Chuck
 
Upvote 0
Hi John,

Been going over your code and I now understand how to find table data. Doubt I would have obtained it without your code assistance as previously I had only figured out the button click.

Did you originally find the table class using the Yahoo page “Inspect Element”, then looping through from there with the MS HTML Library table elements? Didn’t realize there was a DOM Explorer, which must be built into Windows 7 O/S?

Makes sense now how to see HTML elements of IE loaded pages.

Still trying to figure out how to use those other HTML approaches that don’t load the IE browser, for a much faster table read.

Thanks.

Chuck
 
Upvote 0
Actually, you did mention the built in browser developer tools which has that DOM explorer, debugger etc. Lot of good info I am just starting to digest from your links etc. - Thanks.
 
Upvote 0
I have further analysed the Yahoo Finance webpage to see how it works and the code below uses XMLhttp requests and a JSON parser to extract the Annual and Quarterly Income Statement History data.

Here's what I found, using the symbol IBM as an example.

When a browser requests the webpage http://finance.yahoo.com/quote/IBM/financials?p=IBM, the page also requests https://query1.finance.yahoo.com/v1...arterly,earnings&corsDomain=finance.yahoo.com, and the response is a JSON data string containing the financial data.

The modules parameter in the query string of the 2nd URL is a comma-separated list of the different subjects (Income Statement, Cash Flow, Balance Sheet) shown on the webpage Financials tab, including "incomeStatementHistory" for the Annual Income Statement data and "incomeStatementHistoryQuarterly" for the Quarterly Income Statement data. The %2C's are URL-encoded comma characters.

Another important part of the query string is the crumb=XBOjLoYE5PS parameter. The crumb value comes from a large JSON data structure contained within a script element in the webpage HTML. This JSON data starts with "root.App.main" and the path to the crumb value is context->dispatcher->stores->CrumbStore->crumb.

The VBA code below first requests the main page http://finance.yahoo.com/quote/IBM/financials?p=IBM using XMLhttp and extracts the cookie from the response headers. This cookie is specified in the 2nd XMLhttp. It also extracts the crumb value by searching for "CrumbStore":{"crumb" in the JSON data within the HTML response.

The VBA code then constructs the query1.finance.yahoo.com URL using the crumb value and just the "incomeStatementHistory,incomeStatementHistoryQuarterly" modules, since we only want the Income Statement History data, and requests it using XMLhttp. The response is a JSON data string containing the financial data. The code parses this JSON string using the JsonConverter module and gets the Annual data from quoteSummary->result->(1)->incomeStatementHistory->incomeStatementHistory, and the Quarterly data from quoteSummary->result->(1)->incomeStatementHistoryQuarterly->incomeStatementHistory. The JsonConverter.Parse code represents the JSON data as a combination of VBA Dictionary and Collection objects, which makes it fairly easy to access different parts of the data.

To aid debugging and understanding of the JSON data response to the query1.finance.yahoo.com request, the code calls the function JsonToCells which writes the JSON data to Excel cells in a hierarchical layout, and creates a comment in each 'end' value cell showing the reference path to that JSON field.

In the macro workbook you will need two sheets: the extracted Income Statement data is written to the first sheet and the JSON data is written to the second.

You must also set references to Microsoft XML v6.0 and Microsoft Scripting Runtime via Tools -> References in the VBA editor.

Note that the lineItems array in the main module contains a list of the JSON field names for the various items of financial data. When an item on the webpage is zero or blank, e.g. the Non Recurring item, the JSON field name is missing from the response. Therefore, I have guessed the JSON field name, e.g. "nonRecurring". You would have to find a symbol where this item is not zero or blank and examine the JSON response to determine the exact JSON field name for a specific item of financial data.

The main module code:

Code:
'References needed
'Microsoft XML v6.0
'Microsoft Scripting Runtime (for Dictionary object)

Option Explicit

#If VBA7 Then
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" Alias "DeleteUrlCacheEntryA" _
    (ByVal lpszUrlName As String) As Long
#Else
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" Alias "DeleteUrlCacheEntryA" _
    (ByVal lpszUrlName As String) As Long
#End If


Public Sub Yahoo_Finance_Income_Statement()

    #If VBA7 Then
        Dim httpReq As XMLHTTP60
        Set httpReq = New XMLHTTP60
    #Else
        Dim httpReq As XMLhttp
        Set httpReq = New XMLhttp
    #End If
    
    Dim lineItems As Variant
    Dim destCell As Range
    Dim symbol As String
    Dim headers As Variant, parts As Variant, cookie As String
    Dim findCrumb As String, crumb As String
    Dim URL As String, queryURL As String
    Dim i As Long, n As Long, p1 As Long, p2 As Long
    Dim JSONcell As Range
    Dim ParsedJSONDict As Dictionary
    Dim incomeStatements As Collection
    Dim columnDict As Dictionary
    
    symbol = InputBox("Enter stock symbol")
    If symbol = "" Then Exit Sub
    symbol = UCase(symbol)
    
    With Worksheets(1)
        Set destCell = .Range("A1")
        .Cells.Clear
    End With
    
    lineItems = Array( _
        "Revenue", "endDate", "Total Revenue", "totalRevenue", "Cost of Revenue", "costOfRevenue", "Gross Profit", "grossProfit", _
        "Operating Expenses", "", "Research Development", "researchDevelopment", "Selling General And Administrative", "sellingGeneralAdministrative", _
            "Non Recurring", "nonRecurring", "Others", "otherOperatingExpenses", "Total Operating Expenses", "totalOperatingExpenses", _
            "Operating Income Or Loss", "operatingIncome", _
        "Income from Continuing Operations", "", "Total Other Income/Expenses Net", "totalOtherIncomeExpenseNet", "Earnings Before Interest and Taxes", "ebit", _
            "Interest Expense", "interestExpense", "Income Before Tax", "incomeBeforeTax", "Income Tax Expense", "incomeTaxExpense", _
            "Minority Interest", "minorityInterest", "Net Income From Continuing Ops", "netIncomeFromContinuingOps", _
        "Non-recurring Events", "", "Discontinued Operations", "discontinuedOperations", "Extraordinary Items", "extraordinaryItems", _
            "Effect Of Accounting Changes", "effectOfAccountingChanges", "Other Items", "otherItems", _
        "Net Income", "", "Net Income", "netIncome", "Preferred Stock And Other Adjustments", "preferredStockAndOtherAdjustments", _
            "Net Income Applicable To Common Shares", "netIncomeApplicableToCommonShares")

    URL = "https://finance.yahoo.com/quote/" & symbol & "/financials?p=" & symbol
    
    DeleteUrlCacheEntry URL
    
    With httpReq
        .Open "GET", URL, False
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64; rv:52.0) Gecko/20100101 Firefox/52.0"
        .setRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8"
        .setRequestHeader "Accept-Language", "en-US,en;q=0.5"
        .setRequestHeader "Upgrade-Insecure-Requests", "1"
        .send
        Debug.Print .Status, .statusText
        Debug.Print .getAllResponseHeaders
        'Log_HTML .responseText
        
        crumb = ""
        
        If .statusText = "OK" Then
        
            'Extract cookie from Set-Cookie headers
                
            headers = Split(.getAllResponseHeaders, vbCrLf)
            cookie = ""
            For i = 0 To UBound(headers)
                parts = Split(headers(i), "Set-Cookie: ")
                If UBound(parts) > 0 Then
                    cookie = cookie & Left(parts(1), InStr(parts(1), ";")) & " "
                End If
            Next
         
            'Extract crumb value from JSON data within webpage HTML
            '"CrumbStore":{"crumb":"Wu708EJQ4DB"}
            
            findCrumb = """CrumbStore"":{""crumb"":"
            p1 = InStr(1, .responseText, findCrumb)
            If p1 > 0 Then
                p1 = p1 + Len(findCrumb) + 1
                p2 = InStr(p1, .responseText, Chr(34))
                crumb = Mid(.responseText, p1, p2 - p1)
            End If
        
        End If
        
        If crumb <> "" Then
        
            'Crumb value found, so request Income Statement data
            
            queryURL = "https://query2.finance.yahoo.com/v10/finance/quoteSummary/" & symbol & "?formatted=true&crumb=" & Escape(crumb) & _
                  "&lang=en-US&region=US&corsDomain=finance.yahoo.com" & _
                  "&modules=" & Escape("incomeStatementHistory,incomeStatementHistoryQuarterly")
                  '"&modules=" & Escape("incomeStatementHistory,cashflowStatementHistory,balanceSheetHistory,incomeStatementHistoryQuarterly,cashflowStatementHistoryQuarterly,balanceSheetHistoryQuarterly,earnings")
    
            .Open "GET", queryURL, False
            .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64; rv:52.0) Gecko/20100101 Firefox/52.0"
            .setRequestHeader "Accept", "*/*"
            .setRequestHeader "Referer", URL
            If cookie <> "" Then .setRequestHeader "Set-Cookie", cookie
            .send
            Debug.Print .Status, .statusText
            Debug.Print .getAllResponseHeaders
            
            If .statusText = "OK" Then
            
                Set ParsedJSONDict = JsonConverter.ParseJson(.responseText)
                
                With Worksheets(2)
                    .Cells.Clear
                    Set JSONcell = .Range("A1")
                End With
                JsonToCells ParsedJSONDict, JSONcell
                
                'Extract Income Statement History Yearly data into Excel cells
                
                Set incomeStatements = ParsedJSONDict.Item("quoteSummary").Item("result")(1).Item("incomeStatementHistory").Item("incomeStatementHistory")
                
                destCell.Value = symbol & " Yearly"
                For i = 0 To UBound(lineItems) Step 2
                    destCell.Offset(i / 2 + 1, 0).Value = lineItems(i)
                Next
                
                For n = 1 To incomeStatements.Count
                    Set columnDict = incomeStatements(n)
                    For i = 0 To UBound(lineItems) Step 2
                        If lineItems(i + 1) <> "" Then
                            If columnDict.Exists(lineItems(i + 1)) Then
                                'Debug.Print lineItems(i + 1), columnDict(lineItems(i + 1)).Item("longFmt"), columnDict(lineItems(i + 1)).Item("raw")
                                If lineItems(i + 1) <> "endDate" Then
                                    destCell.Offset(i / 2 + 1, n).Value = columnDict(lineItems(i + 1)).Item("longFmt")
                                Else
                                    destCell.Offset(i / 2 + 1, n).Value = columnDict(lineItems(i + 1)).Item("fmt")
                                End If
                            End If
                        End If
                    Next
                Next
                Set destCell = destCell.Offset(UBound(lineItems) / 2 + 2)
                
                'Extract Income Statement History Quarterly data into Excel cells
                
                Set incomeStatements = ParsedJSONDict.Item("quoteSummary").Item("result")(1).Item("incomeStatementHistoryQuarterly").Item("incomeStatementHistory")
                
                destCell.Value = symbol & " Quarterly"
                For i = 0 To UBound(lineItems) Step 2
                    destCell.Offset(i / 2 + 1, 0).Value = lineItems(i)
                Next
                
                For n = 1 To incomeStatements.Count
                    Set columnDict = incomeStatements(n)
                    For i = 0 To UBound(lineItems) Step 2
                        If lineItems(i + 1) <> "" Then
                            If columnDict.Exists(lineItems(i + 1)) Then
                                'Debug.Print lineItems(i + 1), columnDict(lineItems(i + 1)).Item("longFmt"), columnDict(lineItems(i + 1)).Item("raw")
                                If lineItems(i + 1) <> "endDate" Then
                                    destCell.Offset(i / 2 + 1, n).Value = columnDict(lineItems(i + 1)).Item("longFmt")
                                Else
                                    destCell.Offset(i / 2 + 1, n).Value = columnDict(lineItems(i + 1)).Item("fmt")
                                End If
                            End If
                        End If
                    Next
                Next
                Set destCell = destCell.Offset(UBound(lineItems) / 2 + 2)
                    
            End If
            
        End If
    
    End With
        
End Sub


'Output parsed JSON object to Excel cells in a hierarchical structure and create a comment in each final value cell showing the reference path.
'Based on toString function in VBJSON (http://www.ediy.co.nz/vbjson-json-parser-library-in-vb6-xidc55680.html)

Private Function JsonToCells(ByRef obj As Variant, destCell As Range, Optional ByVal path As String) As Long

    Dim n As Long
    
    'Debug.Print destCell.Address, path
    n = 1 'default number of rows written by current call
    
    Select Case VarType(obj)
        
        Case vbNull
            destCell.Value = "null"
            CreateComment destCell, path
        
        Case vbDate
            destCell.Value = CStr(obj)
            CreateComment destCell, path
        
        Case vbString
            destCell.Value = obj 'Encode(obj)
            CreateComment destCell, path

        Case vbObject
        
            If TypeName(obj) = "Dictionary" Then
            
                Dim i As Long
                Dim keys As Variant, key As Variant
                
                keys = obj.keys
                n = 0
                For i = 0 To obj.Count - 1
                    key = keys(i)
                    destCell.Offset(n, 0).Value = key
                    n = n + JsonToCells(obj.Item(key), destCell.Offset(n, 1), IIf(path = "", key, path & "->" & key))
                Next i
                   
            ElseIf TypeName(obj) = "Collection" Then
            
                Dim colValue As Variant
                
                i = 0
                n = 1
                For Each colValue In obj
                    destCell.Offset(n, 0).Value = i
                    n = n + JsonToCells(colValue, destCell.Offset(n, 1), IIf(path = "", "(" & i & ")", path & "->(" & i & ")"))
                    i = i + 1
                Next colValue
                
            End If
            
        Case vbBoolean
            If obj Then destCell.Value = "true" Else destCell.Value = "false"
            CreateComment destCell, path
            
        Case vbVariant, vbArray, vbArray + vbVariant
            'Case not handled yet because not seen a vbVariant or vbArray in testing
            'Dim sEB
            'destCell.Value = multiArray(obj, 1, "", sEB) 'multiArray is part of VBJSON
            Stop
            
        Case Else
            destCell.Value = Replace(obj, ",", ".")
            CreateComment destCell, path
            
    End Select

    JsonToCells = n
    
End Function


Private Sub CreateComment(cell As Range, commentText As String)
    
    Dim parts As Variant, cellComment As String, i As Long, maxLen As Long, numLines As Long
    
    cellComment = ""
    maxLen = 0
    parts = Split(commentText, "->")
    For i = 0 To UBound(parts)
        cellComment = cellComment & parts(i) & "->" & vbCrLf
        If Len(parts(i)) > maxLen Then maxLen = Len(parts(i))
    Next
    
    With cell
        If .Comment Is Nothing Then .AddComment
        .Comment.Visible = False
        .Comment.Text Text:=Left(cellComment, Len(cellComment) - 4)
        .Comment.Shape.Width = (maxLen + 2) * 5.9
        .Comment.Shape.Height = (UBound(parts) + 1) * 12
    End With
    
End Sub


'http://www.tushar-mehta.com/publish_train/xl_vba_cases/vba_web_pages_services/
'With bug fix.  The "%" should be first in the BadChars string because it is used as the escape character.

Private Function Escape(ByVal param As String) As String

    Dim i As Integer, BadChars As String

    BadChars = "%<>=&!@#$^()+{[}]|\;:'"",/?"
    'BadChars = "<>%=&!@#$^()+{[}]|\;:'"",/?"        'original code
    For i = 1 To Len(BadChars)
        param = Replace(param, Mid(BadChars, i, 1), "%" & Hex(Asc(Mid(BadChars, i, 1))))
    Next
    param = Replace(param, " ", "+")
    Escape = param

End Function


Private Sub Log_HTML(HTML As String)
    Static num As Integer
    num = num + 1
    Open Environ("TEMP") & "\HTML" & num & Format(Now, " hh mm ss") & ".txt" For Output As #1
    Print #1, HTML
    Close #1
End Sub

The JSON parser code, in a module which must be named JsonConverter:

Code:
'JsonConverter.bas v2.2.3 (VBA module) downloaded from https://github.com/VBA-tools/VBA-JSON
'
'Reference required:
'Microsoft Scripting Runtime  (for Dictionary object)
'--------------------------------------------------------------------------------------------------

' VBA-JSON v2.2.3
' (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 "libc.dylib" Alias "popen" _
    (ByVal utc_Command As String, ByVal utc_Mode As String) As LongPtr
Private Declare PtrSafe Function utc_pclose Lib "libc.dylib" Alias "pclose" _
    (ByVal utc_File As Long) As LongPtr
Private Declare PtrSafe Function utc_fread 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 "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

#If Mac Then
#ElseIf VBA7 Then

Private Declare PtrSafe Sub json_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (json_MemoryDestination As Any, json_MemorySource As Any, ByVal json_ByteLength As Long)

#Else

Private Declare Sub json_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (json_MemoryDestination As Any, json_MemorySource As Any, ByVal json_ByteLength As Long)

#End If

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, json_BufferLength)

    ' 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, json_BufferLength)
    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_BufferLength)
            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, json_BufferLength)
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
        Dim json_Index As Long

        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)
#If Mac Then
    json_buffer = json_buffer & json_Append
#Else
    ' 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
    '
    ' Copy memory for "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

    Dim json_AppendLength As Long
    Dim json_LengthPlusPosition As Long

    json_AppendLength = VBA.LenB(json_Append)
    json_LengthPlusPosition = json_AppendLength + json_BufferPosition

    If json_LengthPlusPosition > json_BufferLength Then
        ' Appending would overflow buffer, add chunks until buffer is long enough
        Dim json_TemporaryLength As Long

        json_TemporaryLength = json_BufferLength
        Do While json_TemporaryLength < json_LengthPlusPosition
            ' Initially, initialize string with 255 characters,
            ' then add large chunks (8192) after that
            '
            ' Size: # Characters x 2 bytes / character
            If json_TemporaryLength = 0 Then
                json_TemporaryLength = json_TemporaryLength + 510
            Else
                json_TemporaryLength = json_TemporaryLength + 16384
            End If
        Loop

        json_buffer = json_buffer & VBA.Space$((json_TemporaryLength - json_BufferLength) \ 2)
        json_BufferLength = json_TemporaryLength
    End If

    ' Copy memory from append to buffer at buffer position
    json_CopyMemory ByVal json_UnsignedAdd(StrPtr(json_buffer), _
                    json_BufferPosition), _
                    ByVal StrPtr(json_Append), _
                    json_AppendLength

    json_BufferPosition = json_BufferPosition + json_AppendLength
#End If
End Sub

Private Function json_BufferToString(ByRef json_buffer As String, ByVal json_BufferPosition As Long, ByVal json_BufferLength As Long) As String
#If Mac Then
    json_BufferToString = json_buffer
#Else
    If json_BufferPosition > 0 Then
        json_BufferToString = VBA.Left$(json_buffer, json_BufferPosition \ 2)
    End If
#End If
End Function

#If VBA7 Then
Private Function json_UnsignedAdd(json_Start As LongPtr, json_Increment As Long) As LongPtr
#Else
Private Function json_UnsignedAdd(json_Start As Long, json_Increment As Long) As Long
#End If

    If json_Start And &H80000000 Then
        json_UnsignedAdd = json_Start + json_Increment
    ElseIf (json_Start Or &H80000000) < -json_Increment Then
        json_UnsignedAdd = json_Start + json_Increment
    Else
        json_UnsignedAdd = (json_Start + &H80000000) + (json_Increment + &H80000000)
    End If
End Function

''
' VBA-UTC v1.0.3
' (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 = utc_fread(utc_Chunk, 1, Len(utc_Chunk) - 1, utc_File)
        If utc_Read > 0 Then
            utc_Chunk = VBA.Left$(utc_Chunk, utc_Read)
            utc_ExecuteInShell.utc_Output = utc_ExecuteInShell.utc_Output & utc_Chunk
        End If
    Loop

utc_ErrorHandling:
    utc_ExecuteInShell.utc_ExitCode = 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
 
Upvote 0

Forum statistics

Threads
1,213,513
Messages
6,114,072
Members
448,546
Latest member
KH Consulting

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top