From 76ca2974e076d272c247bc71fb58010a21730755 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Sebastian=20Bj=C3=B6rkqvist?= Date: Fri, 4 Nov 2016 09:31:16 +0200 Subject: [PATCH] Change string conversion in WebHelpers.Base64Encode to support UTF8 strings (for instance Scandinavian letters). Fixes error where HTTP Basic Authentication fails when username or passwowrd contains special characters. Base64Decode is not changed in a corresponding way. --- src/StringConverter.bas | 38 ++++++++++++++++++++++++++++++++++ src/WebHelpers.bas | 46 ++++++++++++++++++++--------------------- 2 files changed, 61 insertions(+), 23 deletions(-) create mode 100644 src/StringConverter.bas diff --git a/src/StringConverter.bas b/src/StringConverter.bas new file mode 100644 index 00000000..ab5ccb78 --- /dev/null +++ b/src/StringConverter.bas @@ -0,0 +1,38 @@ +Attribute VB_Name = "StringConverter" +'' +' Module used for converting string to UTF8 byte array. +' +' Code taken from page http://www.di-mgt.com.au/howto-convert-vba-unicode-to-utf8.html +' Modified to work in 64-bit Excel using guide at http://stackoverflow.com/questions/21982682/code-does-not-work-on-64-bit-office +' +' Used in WebHelpers.Base64Encode so that the HttpBasicAuthenticator works correctly with Scandinavian letters in username or password. +'' + +''' WinApi function that maps a UTF-16 (wide character) string to a new character string +Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" ( _ + ByVal CodePage As LongPtr, _ + ByVal dwFlags As LongPtr, _ + ByVal lpWideCharStr As LongPtr, _ + ByVal cchWideChar As LongPtr, _ + ByVal lpMultiByteStr As LongPtr, _ + ByVal cbMultiByte As LongPtr, _ + ByVal lpDefaultChar As LongPtr, _ + ByVal lpUsedDefaultChar As LongPtr) As LongPtr + +' CodePage constant for UTF-8 +Private Const CP_UTF8 = 65001 + +''' Return byte array with VBA "Unicode" string encoded in UTF-8 +Public Function Utf8BytesFromString(strInput As String) As Byte() + Dim nBytes As Variant + Dim abBuffer() As Byte + ' Get length in bytes *including* terminating null + + nBytes = WideCharToMultiByte(CP_UTF8, 0&, ByVal StrPtr(strInput), -1, vbNull, 0&, 0&, 0&) + ' We don't want the terminating null in our byte array, so ask for `nBytes-1` bytes + ReDim abBuffer(nBytes - 2) ' NB ReDim with one less byte than you need + nBytes = WideCharToMultiByte(CP_UTF8, 0&, ByVal StrPtr(strInput), -1, ByVal VarPtr(abBuffer(0)), nBytes - 1, 0&, 0&) + Utf8BytesFromString = abBuffer + +End Function + diff --git a/src/WebHelpers.bas b/src/WebHelpers.bas index 32cf44e8..430bba9a 100644 --- a/src/WebHelpers.bas +++ b/src/WebHelpers.bas @@ -709,23 +709,23 @@ End Function ' @return {Dictionary|Collection|Object} ' @throws 11000 - Error during parsing '' -Public Function ParseByFormat(Value As String, Format As WebFormat, _ +Public Function ParseByFormat(value As String, Format As WebFormat, _ Optional CustomFormat As String = "", Optional Bytes As Variant) As Object On Error GoTo web_ErrorHandling ' Don't attempt to parse blank values - If Value = "" And CustomFormat = "" Then + If value = "" And CustomFormat = "" Then Exit Function End If Select Case Format Case WebFormat.Json - Set ParseByFormat = ParseJson(Value) + Set ParseByFormat = ParseJson(value) Case WebFormat.FormUrlEncoded - Set ParseByFormat = ParseUrlEncoded(Value) + Set ParseByFormat = ParseUrlEncoded(value) Case WebFormat.Xml - Set ParseByFormat = ParseXml(Value) + Set ParseByFormat = ParseXml(value) Case WebFormat.Custom #If EnableCustomFormatting Then Dim web_Converter As Dictionary @@ -739,15 +739,15 @@ Public Function ParseByFormat(Value As String, Format As WebFormat, _ Set web_Instance = web_Converter("Instance") If web_Converter("ParseType") = "Binary" Then - Set ParseByFormat = VBA.CallByName(web_Instance, web_Callback, VBA.vbMethod, Bytes) + Set ParseByFormat = VBA.CallByName(web_Instance, web_Callback, VBA.VbMethod, Bytes) Else - Set ParseByFormat = VBA.CallByName(web_Instance, web_Callback, VBA.vbMethod, Value) + Set ParseByFormat = VBA.CallByName(web_Instance, web_Callback, VBA.VbMethod, value) End If Else If web_Converter("ParseType") = "Binary" Then Set ParseByFormat = Application.Run(web_Callback, Bytes) Else - Set ParseByFormat = Application.Run(web_Callback, Value) + Set ParseByFormat = Application.Run(web_Callback, value) End If End If #Else @@ -799,7 +799,7 @@ Public Function ConvertToFormat(Obj As Variant, Format As WebFormat, Optional Cu If web_Converter.Exists("Instance") Then Dim web_Instance As Object Set web_Instance = web_Converter("Instance") - ConvertToFormat = VBA.CallByName(web_Instance, web_Callback, VBA.vbMethod, Obj) + ConvertToFormat = VBA.CallByName(web_Instance, web_Callback, VBA.VbMethod, Obj) Else ConvertToFormat = Application.Run(web_Callback, Obj) End If @@ -1046,8 +1046,8 @@ Public Function Base64Encode(Text As String) As String Base64Encode = ExecuteInShell(web_Command).Output #Else Dim web_Bytes() As Byte - - web_Bytes = VBA.StrConv(Text, vbFromUnicode) + + web_Bytes = StringConverter.Utf8BytesFromString(Text) Base64Encode = web_AnsiBytesToBase64(web_Bytes) #End If @@ -1402,11 +1402,11 @@ End Function ' @param {Variant} Value ' @return {Dictionary} '' -Public Function CreateKeyValue(Key As String, Value As Variant) As Dictionary +Public Function CreateKeyValue(Key As String, value As Variant) As Dictionary Dim web_KeyValue As New Dictionary web_KeyValue("Key") = Key - web_KeyValue("Value") = Value + web_KeyValue("Value") = value Set CreateKeyValue = web_KeyValue End Function @@ -1470,12 +1470,12 @@ End Function ' @param {Variant} Value ' @return {Variant} '' -Public Sub AddOrReplaceInKeyValues(KeyValues As Collection, Key As Variant, Value As Variant) +Public Sub AddOrReplaceInKeyValues(KeyValues As Collection, Key As Variant, value As Variant) Dim web_KeyValue As Dictionary Dim web_Index As Long Dim web_NewKeyValue As Dictionary - Set web_NewKeyValue = CreateKeyValue(CStr(Key), Value) + Set web_NewKeyValue = CreateKeyValue(CStr(Key), value) web_Index = 1 For Each web_KeyValue In KeyValues @@ -1888,25 +1888,25 @@ End Function ' ============================================= ' ' Helper for url-encoded to create key=value pair -Private Function web_GetUrlEncodedKeyValue(Key As Variant, Value As Variant, Optional EncodingMode As UrlEncodingMode = UrlEncodingMode.FormUrlEncoding) As String - Select Case VBA.VarType(Value) +Private Function web_GetUrlEncodedKeyValue(Key As Variant, value As Variant, Optional EncodingMode As UrlEncodingMode = UrlEncodingMode.FormUrlEncoding) As String + Select Case VBA.VarType(value) Case VBA.vbBoolean ' Convert boolean to lowercase - If Value Then - Value = "true" + If value Then + value = "true" Else - Value = "false" + value = "false" End If Case VBA.vbDate ' Use region invariant date (ISO-8601) - Value = WebHelpers.ConvertToIso(CDate(Value)) + value = WebHelpers.ConvertToIso(CDate(value)) Case VBA.vbDecimal, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency ' Use region invariant number encoding ("." for decimal separator) - Value = VBA.Replace(VBA.CStr(Value), ",", ".") + value = VBA.Replace(VBA.CStr(value), ",", ".") End Select ' Url encode key and value (using + for spaces) - web_GetUrlEncodedKeyValue = UrlEncode(Key, EncodingMode:=EncodingMode) & "=" & UrlEncode(Value, EncodingMode:=EncodingMode) + web_GetUrlEncodedKeyValue = UrlEncode(Key, EncodingMode:=EncodingMode) & "=" & UrlEncode(value, EncodingMode:=EncodingMode) End Function ''