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 <j...@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
"&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
+
+
</script:module>
\ No newline at end of file
_______________________________________________
Libreoffice-commits mailing list
libreoffice-comm...@lists.freedesktop.org
http://lists.freedesktop.org/mailman/listinfo/libreoffice-commits
