mir/libreoffice
2
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Access2Base - UTF-8 encoding and %-encoding

Browse Source 
Application to SendMailWithoutAttachment => "mailto: ... " uri

Change-Id: I53aa0325c048dca678ff134908d448afab08933d
This commit is contained in:
Jean-Pierre Ledure 2015-08-30 16:27:24 +02:00
parent b7f4940c15
commit 02973251c2
2 changed files with 108 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
wizards/source/access2base/DoCmd.xba
View File

@ -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())

104
wizards/source/access2base/Utils.xba
View File

@ -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 "é" 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>