Lotus Notes

'Base64:

Option Public
Option Explicit

%REM
This set of functions will allow you to encode and decode strings and files
in Base64 format. The implementation is all in LotusScript, and requires no
external DLLs or tricks. It was written and tested in R5, but it should be
backwards compatible to at least 4.6

This is the 1.4 "release" of the functions, from December 28, 2002.
The code was originally written by Julian Robichaux, and is maintained
by him on the http://www.nsftools.com website.

Release History:
1.4 (Dec 28, 2002)
-- fixed TrimBytesFromFile function to properly handle writing odd numbers
of bytes to a new file (thanks to Peter Leugner at www.as-computer.de)

1.3 (Dec 26, 2002)
-- Modified DecodeFile function to properly handle the line terminators
that the Print statement adds
-- Fixed GetFileChunk function to properly read the last byte in a file

1.2 (Dec 17, 2002)
-- Added functions for encrypting and decrypting entire files

1.1 (Nov 5, 2002)
-- Fixed typo/error in EncodeBase64 function

1.0 (Nov 1, 2002)
-- Initial release
%END REM

'** the characters used to encode in Base64, in order of appearance
Const b64chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Sub Initialize
%REM
'** examples of using the Base64 functions in this agent
Dim eString As String, dString As String
Dim isOkay As Integer

eString = "QUJDREVGRw==" '** ABCDEFG
dString = DecodeBase64(eString)

isOkay = IsBase64(eString)

eString = EncodeBase64("AbCdEfG" & Chr(0) & "123")
eString = BreakString(eString, 5)
dString = DecodeBase64(eString)

isOkay = IsBase64(RemoveWhitespace(eString))
isOkay = IsBase64(dString)

isOkay = EncodeFile("C:\Autoexec.bat", "C:\Autoexec.enc")
isOkay = DecodeFile("C:\Autoexec.enc", "C:\Autoexec.dec")
%ENDREM
End Sub
Function DecodeBase64 (Byval encText As String) As String
'** This function will decode a Base64 string. It's probably a good
'** idea to check the validity of the string with the IsBase64 function
'** prior to processing it, to avoid strange errors.
'** by Julian Robichaux -- http://www.nsftools.com
On Error Goto endOfFunction

Dim encNum As Long
Dim decText As String
Dim i As Integer

'** remove any line termination characters and whitespace first
encText = RemoveWhitespace(encText)

For i = 1 To Len(encText) Step 4
'** convert the next 2 of 4 characters to a number we can decode
encNum = (Instr(b64chars, Mid$(encText, i, 1)) - 1) * (2 ^ 18)
encNum = encNum Or ((Instr(b64chars, Mid$(encText, i+1, 1)) - 1) * (2 ^ 12))

'** deal with trailing '='
If (Mid$(encText, i+2, 1) = "=") Then
decText = decText & Chr(Fix(encNum / (2 ^ 16)) And &HFF)
Elseif (Mid$(encText, i+3, 1) = "=") Then
encNum = encNum Or ((Instr(b64chars, Mid$(encText, i+2, 1)) - 1) * (2 ^ 6))
decText = decText & Chr(Fix(encNum / (2 ^ 16)) And &HFF)
decText = decText & Chr(Fix(encNum / (2 ^ 8)) And &HFF)
Else
encNum = encNum Or ((Instr(b64chars, Mid$(encText, i+2, 1)) - 1) * (2 ^ 6))
encNum = encNum Or (Instr(b64chars, Mid$(encText, i+3, 1)) - 1)
decText = decText & Chr(Fix(encNum / (2 ^ 16)) And &HFF)
decText = decText & Chr(Fix(encNum / (2 ^ 8)) And &HFF)
decText = decText & Chr(encNum And &HFF)
End If

Next

endOfFunction:
DecodeBase64 = decText
Exit Function

End Function
Function EncodeBase64 (decText As String) As String
'** This function will Base64 encode a string. The string doesn't have to
'** be text-only, either. You can also encode strings of non-ASCII data,
'** like the contents of a binary file. If you're encoding a whole file,
'** make sure you break the contents into lengths divisible by three, so
'** you can concatenate them together properly.
'** by Julian Robichaux -- http://www.nsftools.com
On Error Goto endOfFunction

Dim decNum As Long
Dim encText As String
Dim chunk As String
Dim i As Integer

For i = 1 To Len(decText) Step 3
'** pad the 3-character string with Chr(0), if need be
chunk = Left$(Mid$(decText, i, 3) & Chr(0) & Chr(0), 3)

'** get the number we'll use for encoding
decNum = Asc(Mid$(chunk, 1, 1)) * (2 ^ 16)
decNum = decNum Or Asc(Mid$(chunk, 2, 1)) * (2 ^ 8)
decNum = decNum Or Asc(Mid$(chunk, 3, 1))

'** calculate the first 2 of 4 encoded characters
encText = encText & Mid$(b64chars, (Fix(decNum / (2 ^ 18)) And &H3F) + 1, 1)
encText = encText & Mid$(b64chars, (Fix(decNum / (2 ^ 12)) And &H3F) + 1, 1)

'** pad with '=' as necessary when we reach the end of the string
Select Case ( Len(decText) - i )
Case 0 :
encText = encText & "=="
Case 1 :
encText = encText & Mid$(b64chars, (Fix(decNum / (2 ^ 6)) And &H3F) + 1, 1)
encText = encText & "="
Case Else :
encText = encText & Mid$(b64chars, (Fix(decNum / (2 ^ 6)) And &H3F) + 1, 1)
encText = encText & Mid$(b64chars, (decNum And &H3F) + 1, 1)
End Select

Next

endOfFunction:
EncodeBase64 = encText
Exit Function

End Function
Function IsBase64 (someString As String) As Integer
'** check to see if the string is a well-formed Base64 string
Dim legalString As String
Dim i As Integer

IsBase64 = False
legalString = b64chars & "="

'** check for bad string length (must be a multiple of 4)
If (Len(someString) Mod 4 > 0) Then
Exit Function
End If

'** check for illegal characters
For i = 1 To Len(someString)
If (Instr(legalString, Mid$(someString, i, 1)) = 0) Then
Exit Function
End If
Next

'** make sure any '=' are only at the end
Select Case (Instr(someString, "="))
Case 0 :
'** no equals signs is okay
Case Is < (Len(someString) - 1) : Exit Function Case (Len(someString) - 1) : If (Right$(someString, 1) <> "=") Then
Exit Function
End If
End Select

'** if we made it through all the conditions, then the string looks good
IsBase64 = True

End Function
Function BreakString (text As String, lineLength As Integer) As String
'** add line terminators to a string at the given interval
Dim newText As String
Dim lineTerm As String
Dim i As Integer

lineTerm = Chr(13) & Chr(10)

For i = 1 To Len(text) Step lineLength
newText = newText & Mid$(text, i, lineLength) & lineTerm
Next

newText = Left$(newText, Len(newText) - Len(lineTerm))
BreakString = newText
End Function
Function RemoveWhitespace (Byval text As String) As String
'** remove line terminators, spaces, and tabs from a string
Call ReplaceSubstring(text, Chr(13), "")
Call ReplaceSubstring(text, Chr(10), "")
Call ReplaceSubstring(text, Chr(9), "")
Call ReplaceSubstring(text, " ", "")

RemoveWhitespace = text
End Function
Function EncodeFile (fileIn As String ) As String

'** Base64 encode an entire file (fileIn) and write the output to
'** another file (fileOut). We're writing the output to another file
'** because there's a possibility that the output will be larger than
'** 32,000 characters, which would overflow an output String.

On Error Goto processError

Dim fin As Integer, fout As Integer
Dim finOpen As Integer, foutOpen As Integer
Dim datain As String, dataout As String
Dim worktext As String, leftover As String
Const CHUNKSIZE = 15000
Dim resp As String

'** open the files for input/output (if there are any errors here,
'** we'll exit in the processError section at the bottom)
fin = Freefile()
Open fileIn For Input As fin
finOpen = True

' fout = Freefile
' Open fileOut For Output As fout
' foutOpen = True

'** start getting data from the input file, encoding it, and sending it
'** to the output file
datain = GetFileChunk(fin, CHUNKSIZE)
Do While (Len(datain) > 0)
'** encode in groups of 57 characters, which will give us output
'** in lines of 76 characters (fairly standard)
leftover = leftover & datain
While (Len(leftover) > 57)
worktext = Left$(leftover, 57)
leftover = Mid$(leftover, 58)
dataout = EncodeBase64(worktext)
' Print #fout, dataout
resp = resp + dataout
Wend
datain = GetFileChunk(fin, CHUNKSIZE)
Loop

'** encode anything we had left, and close the files
If (Len(leftover) > 0) Then
' Print #fout, EncodeBase64(leftover)
resp = resp + EncodeBase64(leftover)
End If

' Close #fin, #fout
Close #fin
EncodeFile = resp
Exit Function

processError:
If (finOpen) Then Close #fin
' If (foutOpen) Then Close #fout
EncodeFile = "Erro"
Exit Function

End Function
Function DecodeFile (fileIn As String, fileOut As String) As Integer
'** Base64 decode an entire file (fileIn) and write the output to
'** another file (fileOut). We're writing the output to another file
'** because there's a possibility that the output will be larger than
'** 32,000 characters, which would overflow an output String.
On Error Goto processError

Dim fin As Integer, fout As Integer
Dim finOpen As Integer, foutOpen As Integer
Dim datain As String, dataout As String
Dim worktext As String, leftover As String
Const CHUNKSIZE = 16000

'** figure out how long the line terminator character is
Dim session As New NotesSession
Dim lineTermLen As Integer
If (Instr(session.Platform, "Windows") > 0) Then
lineTermLen = 2
Else
lineTermLen = 1
End If

'** open the files for input/output (if there are any errors here,
'** we'll exit in the processError section at the bottom)
fin = Freefile()
Open fileIn For Input As fin
finOpen = True
fout = Freefile
Open fileOut For Output As fout
foutOpen = True

'** start getting data from the input file, encoding it, and sending it
'** to the temporary output file
datain = GetFileChunk(fin, CHUNKSIZE)
Do While (Len(datain) > 0)
datain = RemoveWhitespace(datain)

'** make sure we're decoding in groups of characters
'** that are multiples of 4
leftover = leftover & datain
worktext = Left$(leftover, Len(leftover) - (Len(leftover) Mod 4))
leftover = Right$(leftover, Len(leftover) Mod 4)
dataout = DecodeBase64(worktext)
Print #fout, dataout
'** adjust the cursor position so we overwrite the line terminator that's
'** automatically been appended to the end of the line by Print
Seek #fout, Seek(fout) - lineTermLen

datain = GetFileChunk(fin, CHUNKSIZE)
Loop

'** decode anything we had left, and close the files
If (Len(leftover) > 0) Then
Print #fout, leftover
End If

Close #fin, #fout
finOpen = False
foutOpen = False

'** okay, so here's the problem: the Print statement automatically appends
'** a line terminator to the end of all the lines it printed. We accounted for
'** this while we were writing to the output file in the Do While loop, but
'** there's going to be an extra line terminator at the end of the file that we
'** couldn't do anything about. So we'll need to copy all but the last one or
'** two bytes (depending on the length of the line terminator on this platform)
'** from the temporary output file to the output file that the user wants using
'** Get and Put commands. We couldn't use Put before because when Put
'** writes a text string to a file, it always writes the Unicode version of the
'** string, which isn't what we wanted (try it sometime and see how it looks...)
'** The TrimBytesFromFile function will take care of the problem.
Call TrimBytesFromFile(fileOut, lineTermLen)

DecodeFile = True
Exit Function

processError:
If (finOpen) Then Close #fin
If (foutOpen) Then Close #fout
DecodeFile = False
Exit Function

End Function
Function GetFileChunk (fileNum As Integer, size As Integer) As String
'** get the next chunk of text from a Random file, up to a given size
On Error Goto processError
Dim dataLength As Long

dataLength = Lof(fileNum) - Seek(fileNum) + 1
Select Case (dataLength)
Case Is <= 0 GetFileChunk = "" Case Is > size
GetFileChunk = Input$(size, fileNum)
Case Else
GetFileChunk = Input$(Cint(dataLength), fileNum)
End Select

Exit Function

processError:
GetFileChunk = ""
Exit Function

End Function
Function TrimBytesFromFile (fileName As String, bytesToTrim As Integer)
'** trim the specified number of bytes from the end of the specified
'** file by copying the file contents to a temporary file using Get and
'** Put, and then deleting the specified file and replacing it with
'** the temporary file
On Error Goto processError

Dim tempFileName As String
Dim fin As Integer, fout As Integer
Dim finOpen As Integer, foutOpen As Integer
Dim dataLength As Long
Dim lineLength As Integer
Dim data As String
Dim dataInt As Integer
Const CHUNKSIZE = 15000

tempFileName = fileName & ".tmp"

fin = Freefile()
Open fileName For Binary As fin
finOpen = True
fout = Freefile()
Open tempFileName For Binary As fout
foutOpen = True

'** this works almost exactly like the GetFileChunk function, subtracting
'** bytesToTrim when we reach the last "chunk" of the file
dataLength = Lof(fin) - Seek(fin) + 1 - bytesToTrim
Do While (dataLength > 1)
If (dataLength > CHUNKSIZE) Then
lineLength = CHUNKSIZE
Else
lineLength = Cint(dataLength)
End If

'** a LotusScript string is actually 2 bytes per character, so we only
'** want to get a string that's half the length of the number of bytes
'** that we need
data = Space$(Fix(lineLength / 2))
Get #fin, , data
Put #fout, , data

dataLength = Lof(fin) - Seek(fin) + 1 - bytesToTrim
Loop

'** if there's only one more byte to read, we need to back up one byte
'** because there are no one-byte data types in LotusScript prior to R6,
'** so we're always writing an even number of bytes at a time
If (dataLength = 1) Then
Seek #fin, Seek(fin) - 1
Seek #fout, Seek(fout) - 1
Get #fin, , dataInt
Put #fout, , dataInt
End If

Close #fin, #fout
finOpen = False
foutOpen = False

'** once all the files are closed, delete the original file and rename the
'** temporary file so it becomes the original
Kill fileName
Name tempFileName As fileName
Exit Function

processError:
If (finOpen) Then Close #fin
If (foutOpen) Then Close #fout
Exit Function

End Function

Sub Terminate

End Sub
Function ReplaceSubstring(text As String, find As String, strreplace As String)
Dim pos As Integer
pos = Instr(text, find)

Do While (pos > 0)
text = Left$(text, pos - 1) & strreplace & Mid$(text, pos + Len(find))
pos = Instr(pos + Len(strreplace), text, find)
Loop
End Function

Lotus Notes

terça-feira, 19 de julho de 2011

Rotina completa para envio de e-mail

Base64

segunda-feira, 14 de fevereiro de 2011

Envia HTML Mail com Anexo aberto no corpo do e-mail