From 02973251c20df031fad85b7b25a405e86d84596f Mon Sep 17 00:00:00 2001 From: Jean-Pierre Ledure Date: Sun, 30 Aug 2015 16:27:24 +0200 Subject: Access2Base - UTF-8 encoding and %-encoding Application to SendMailWithoutAttachment => "mailto: ... " uri Change-Id: I53aa0325c048dca678ff134908d448afab08933d --- wizards/source/access2base/DoCmd.xba | 14 ++--- wizards/source/access2base/Utils.xba | 104 +++++++++++++++++++++++++++++++++++ 2 files changed, 108 insertions(+), 10 deletions(-) (limited to 'wizards') diff --git a/wizards/source/access2base/DoCmd.xba b/wizards/source/access2base/DoCmd.xba index ce20dac48ce3..28e2bc38b944 100644 --- a/wizards/source/access2base/DoCmd.xba +++ b/wizards/source/access2base/DoCmd.xba @@ -2420,29 +2420,23 @@ Private Function _SendWithoutAttachment(ByVal pvTo As Variant _ , ByVal psBody As String _ ) As Boolean 'Send simple message with mailto: syntax -Dim sMailTo As String, sTo As String, sCc As String, sBcc As String, sSubject As String, sBody As String, oDispatch As Object +Dim sMailTo As String, sTo As String, sCc As String, sBcc As String, oDispatch As Object Const cstComma = "," -Const cstSpace = "%20" -Const cstLF = "%0A" If _ErrorHandler() Then On Local Error Goto Error_Function If UBound(pvTo) >= 0 Then sTo = Trim(Join(pvTo, cstComma)) Else sTo = "" If UBound(pvCc) >= 0 Then sCc = Trim(Join(pvCc, cstComma)) Else sCc = "" If UBound(pvBcc) >= 0 Then sBcc = Trim(Join(pvBcc, cstComma)) Else sBcc = "" - If psSubject <> "" Then sSubject = Join(Split(psSubject, " "), cstSpace) Else sSubject = "" - If psBody <> "" Then - sBody = Join(Split(Join(Split(psBody, Chr(13)), ""), Chr(10), cstLF) - sBody = Join(Split(sBody, " "), cstSpace) - End If sMailTo = "mailto:" _ & sTo & "?" _ & Iif(sCc = "", "", "cc=" & sCc & "&") _ & Iif(sBcc = "", "", "bcc=" & sBcc & "&") _ - & Iif(sSubject = "", "", "subject=" & sSubject & "&") _ - & Iif(sBody = "", "", "body=" & sBody & "&") + & Iif(psSubject = "", "", "subject=" & psSubject & "&") _ + & Iif(psBody = "", "", "body=" & psBody & "&") If Right(sMailTo, 1) = "&" Or Right(sMailTo, 1) = "?" Then sMailTo = Left(sMailTo, Len(sMailTo) - 1) + sMailTo = Utils._URLEncode(sMailTo) oDispatch = createUnoService( "com.sun.star.frame.DispatchHelper") oDispatch.executeDispatch(StarDesktop, sMailTo, "", 0, Array()) diff --git a/wizards/source/access2base/Utils.xba b/wizards/source/access2base/Utils.xba index 256ff853231b..321db78bac67 100644 --- a/wizards/source/access2base/Utils.xba +++ b/wizards/source/access2base/Utils.xba @@ -585,6 +585,42 @@ Dim vSubStrings() As Variant, i As Integer, iLen As Integer End Function ' PCase V0.9.0 +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PercentEncode(ByVal psChar As String) As String +' Percent encoding of single psChar character +' https://en.wikipedia.org/wiki/UTF-8 + +Dim lChar As Long, sByte1 As String, sByte2 As String, sByte3 As String + lChar = Asc(psChar) + + Select Case lChar + Case 48 To 57, 65 To 90, 97 To 122 ' 0-9, A-Z, a-z + _PercentEncode = psChar + Case "-", ".", "_", "~" + _PercentEncode = psChar + Case "!", "$", "&", "'", "(", ")", "*", "+", ",", ";", "=" ' Reserved characters used as delimitors in query strings + _PercentEncode = psChar + Case " ", "%" + _PercentEncode = "%" & Right("00" & Hex(lChar), 2) + Case 0 To 127 + _PercentEncode = psChar + Case 128 To 2047 + sByte1 = "%" & Right("00" & Hex(Int(lChar / 64) + 192), 2) + sByte2 = "%" & Right("00" & Hex((lChar Mod 64) + 128), 2) + _PercentEncode = sByte1 & sByte2 + Case 2048 To 65535 + sByte1 = "%" & Right("00" & Hex(Int(lChar / 4096) + 224), 2) + sByte2 = "%" & Right("00" & Hex(Int(lChar - (4096 * Int(lChar / 4096))) /64 + 128), 2) + sByte3 = "%" & Right("00" & Hex((lChar Mod 64) + 128), 2) + _PercentEncode = sByte1 & sByte2 & sByte3 + Case Else ' Not supported + _PercentEncode = psChar + End Select + + Exit Function + +End Function ' _PercentEncode V1.4.0 + REM ----------------------------------------------------------------------------------------------------------------------- Public Sub _ResetCalledSub(ByVal psSub As String) ' Called in bottom of each public function. _A2B_.CalledSub variable is used for error handling @@ -690,4 +726,72 @@ Dim sTrim As String, vTrim() As Variant, i As Integer, j As Integer, iCount As I _TrimArray() = vTrim() End Function ' TrimArray V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _URLEncode(ByVal psToEncode As String) As String +' http://www.w3schools.com/tags/ref_urlencode.asp +' http://xkr.us/articles/javascript/encode-compare/ +' http://tools.ietf.org/html/rfc3986 + +Dim sEncoded As String, sChar As String +Dim lCurrentChar As Long, bQuestionMark As Boolean + + sEncoded = "" + bQuestionMark = False + For lCurrentChar = 1 To Len(psToEncode) + sChar = Mid(psToEncode, lCurrentChar, 1) + Select Case sChar + Case " ", "%" + sEncoded = sEncoded & _PercentEncode(sChar) + Case "?" ' Is it the first "?" ? + If bQuestionMark Then ' "?" introduces in a URL the arguments part + sEncoded = sEncoded & _PercentEncode(sChar) + Else + sEncoded = sEncoded & sChar + bQuestionMark = True + End If + Case "\" + If bQuestionMark Then + sEncoded = sEncoded & _PercentEncode(sChar) + Else + sEncoded = sEncoded & "/" ' If Windows file naming ... + End If + Case Else + If bQuestionMark Then + sEncoded = sEncoded & _PercentEncode(sChar) + Else + sEncoded = sEncoded & _UTF8Encode(sChar) ' Because IE does not support %encoding in first part of URL + End If + End Select + Next lCurrentChar + + _URLEncode = sEncoded + +End Function ' _URLEncode V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _UTF8Encode(ByVal psChar As String) As String +' &-encoding of single psChar character (e.g. "é" becomes "&eacute;" or numeric equivalent +' http://www.w3schools.com/charsets/ref_html_utf8.asp + + Select Case psChar + Case """" : _UTF8Encode = "&quot;" + Case "&" : _UTF8Encode = "&amp;" + Case "<" : _UTF8Encode = "&lt;" + Case ">" : _UTF8Encode = "&gt;" + Case "'" : _UTF8Encode = "&apos;" + Case ":", "/", "?", "#", "[", "]", "@" ' Reserved characters + _UTF8Encode = psChar + Case Chr(13) : _UTF8Encode = "" ' Carriage return + Case Chr(10) : _UTF8Encode = "<br>" ' Line Feed + Case < Chr(126) : _UTF8Encode = psChar + Case "€" : _UTF8Encode = "&euro;" + Case Else : _UTF8Encode = "&#" & Asc(psChar) & ";" + End Select + + Exit Function + +End Function ' _UTF8Encode V1.4.0 + + \ No newline at end of file -- cgit