'Base64 1.4: 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 '** 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") 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 ReplaceSubstring (text As String, find As String, replace As String) Dim pos As Integer pos = Instr(text, find) Do While (pos > 0) text = Left$(text, pos - 1) & replace & Mid$(text, pos + Len(find)) pos = Instr(pos + Len(replace), text, find) Loop End Function Function EncodeFile (fileIn As String, fileOut As String) As Integer '** 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 '** 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 Wend datain = GetFileChunk(fin, CHUNKSIZE) Loop '** encode anything we had left, and close the files If (Len(leftover) > 0) Then Print #fout, EncodeBase64(leftover) End If Close #fin, #fout EncodeFile = True Exit Function processError: If (finOpen) Then Close #fin If (foutOpen) Then Close #fout EncodeFile = False 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