22c2375f44
It's not completely seamless, but it should work adequately well. The workbook (aka client) inserts the workbook version into the http request body. The server code compares that version number against its minimum supported client version. If the client is too old, an error message is sent back to the client. When the client receives the "Obsolete" error message, it launches the https://<server>:<port>/template URL in the default browser, which enables the user to save the downloaded new workbook file.
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
|
|
|