[Libreoffice-commits] core.git: wizards/source
Jean-Pierre Ledure
jp at ledure.be
Sun Aug 30 07:30:45 PDT 2015
wizards/source/access2base/DoCmd.xba | 14 +---
wizards/source/access2base/Utils.xba | 104 +++++++++++++++++++++++++++++++++++
2 files changed, 108 insertions(+), 10 deletions(-)
New commits:
commit 02973251c20df031fad85b7b25a405e86d84596f
Author: Jean-Pierre Ledure <jp at ledure.be>
Date: Sun Aug 30 16:27:24 2015 +0200
Access2Base - UTF-8 encoding and %-encoding
Application to SendMailWithoutAttachment => "mailto: ... " uri
Change-Id: I53aa0325c048dca678ff134908d448afab08933d
diff --git a/wizards/source/access2base/DoCmd.xba b/wizards/source/access2base/DoCmd.xba
index ce20dac..28e2bc3 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 256ff85..321db78 100644
--- a/wizards/source/access2base/Utils.xba
+++ b/wizards/source/access2base/Utils.xba
@@ -586,6 +586,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
' Used to trace routine in/outs and to clarify error messages
@@ -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 "é" or numeric equivalent
+' http://www.w3schools.com/charsets/ref_html_utf8.asp
+
+ Select Case psChar
+ Case """" : _UTF8Encode = """
+ Case "&" : _UTF8Encode = "&"
+ Case "<" : _UTF8Encode = "<"
+ Case ">" : _UTF8Encode = ">"
+ Case "'" : _UTF8Encode = "'"
+ 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 = "€"
+ Case Else : _UTF8Encode = "&#" & Asc(psChar) & ";"
+ End Select
+
+ Exit Function
+
+End Function ' _UTF8Encode V1.4.0
+
+
</script:module>
\ No newline at end of file
More information about the Libreoffice-commits
mailing list