84 lines
2.6 KiB
QBasic
84 lines
2.6 KiB
QBasic
Attribute VB_Name = "HttpHandler"
|
|
Option Explicit
|
|
|
|
Function makeHttpRequest(method As String, route As String, doc As String, ByRef errorMsg As String) As Object
|
|
Dim req As New WinHttp.WinHttpRequest
|
|
Dim json As Object
|
|
Dim wr As String
|
|
Dim res() As Variant
|
|
|
|
On Error GoTo errHandler
|
|
|
|
Set makeHttpRequest = Nothing
|
|
|
|
If doc = "" Then
|
|
errorMsg = "No message to send to the server."
|
|
Exit Function
|
|
End If
|
|
|
|
' Inject the user's name and the current version of this file into the request body.
|
|
Set json = JsonConverter.ParseJson(doc)
|
|
json("version") = shConfig.Range("version").value
|
|
json("username") = Application.UserName
|
|
doc = JsonConverter.ConvertToJson(json)
|
|
|
|
Dim server As String
|
|
server = shConfig.Range("server").value
|
|
|
|
With req
|
|
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
|
|
.Open method, server & "/" & route, True
|
|
.SetRequestHeader "Content-Type", "application/json"
|
|
.Send doc
|
|
Debug.Print method & " /" & route & " (";
|
|
Dim t As Single
|
|
t = Timer
|
|
.WaitForResponse
|
|
wr = .ResponseText
|
|
Debug.Print Timer - t; "sec): "; Left(wr, 200)
|
|
End With
|
|
|
|
' This is a poor man's self-upgrade mechanism for this application.
|
|
If Mid(wr, 1, 24) = "Obsolete client workbook" Then
|
|
If MsgBox("Your workbook is an older version and needs to be upgraded. Download now? This workbook will be closed so your download can overwrite it.", vbYesNo + vbQuestion) = vbYes Then
|
|
ActiveWorkbook.FollowHyperlink server & "/template"
|
|
ActiveWorkbook.Close False
|
|
Else
|
|
errorMsg = "You won't be able to use this workbook until you upgrade it. Please download the new one the next time you're prompted."
|
|
Exit Function
|
|
End If
|
|
End If
|
|
|
|
If Mid(wr, 1, 1) <> "{" Or _
|
|
Mid(wr, 2, 5) = "error" Or _
|
|
Mid(wr, 1, 6) = "<body>" Or _
|
|
Mid(wr, 1, 6) = "<!DOCT" _
|
|
Then
|
|
errorMsg = "Unexpected Result from Server: " & wr
|
|
Exit Function
|
|
End If
|
|
|
|
If Mid(wr, 1, 6) = "null" Then
|
|
errorMsg = "API route not implemented."
|
|
Exit Function
|
|
End If
|
|
|
|
Set json = JsonConverter.ParseJson(wr)
|
|
|
|
If IsNull(json("x")) Then
|
|
errorMsg = "Empty response from the server."
|
|
Exit Function
|
|
End If
|
|
|
|
Set makeHttpRequest = json
|
|
|
|
exitFunction:
|
|
' Any final clean-up goes here. This will get hit even after errHandler does its thing.
|
|
Exit Function
|
|
|
|
errHandler:
|
|
MsgBox Err.Description
|
|
Resume exitFunction
|
|
End Function
|
|
|