LotusScript(3)-编码为BASE64格式

Option Public
Option Explicit

%REM

函数转换字符或文件为Base64格式
%END REM



Const b64chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"


Sub Initialize
'例子：代理
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

 On Error Goto endOfFunction

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

'** 删除空字符
encText = RemoveWhitespace(encText)

For i = 1 To Len(encText) Step 4
'** 
  encNum = (Instr(b64chars, Mid$(encText, i, 1)) - 1) * (2 ^ 18)
encNum = encNum Or ((Instr(b64chars, Mid$(encText, i+1, 1)) - 1) * (2 ^ 12))

'** 
  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
'加密字符
'
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

  chunk = Left$(Mid$(decText, i, 3) & Chr(0) & Chr(0), 3)
  

  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))
  
  encText = encText & Mid$(b64chars, (Fix(decNum / (2 ^ 18)) And &H3F) + 1, 1)
encText = encText & Mid$(b64chars, (Fix(decNum / (2 ^ 12)) And &H3F) + 1, 1)
  

 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
'
Dim legalString As String
Dim i As Integer

IsBase64 = False
legalString = b64chars & "="

'
If (Len(someString) Mod 4 > 0) Then
Exit Function
End If

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

'
Select Case (Instr(someString, "="))
Case 0 :
'
Case Is < (Len(someString) - 1) :
Exit Function
Case (Len(someString) - 1) :
If (Right$(someString, 1) <> "=") Then
Exit Function
End If
End Select

' IsBase64 = True

End Function

Function BreakString (text As String, lineLength As Integer) As String
%Rem @Author:
@Date:
@Description:
%end rem

 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
'**

%Rem @Author:
@Date:
@Description:
%end rem

 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
 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
 
fin = Freefile()
Open fileIn For Input As fin
finOpen = True
fout = Freefile
Open fileOut For Output As fout
foutOpen = True

'
datain = GetFileChunk(fin, CHUNKSIZE)
Do While (Len(datain) > 0)

  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
 

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
 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

'
Dim session As New NotesSession
Dim lineTermLen As Integer
If (Instr(session.Platform, "Windows") > 0) Then
lineTermLen = 2
Else
lineTermLen = 1
End If
 

fin = Freefile()
Open fileIn For Input As fin
finOpen = True
fout = Freefile
Open fileOut For Output As fout
foutOpen = True
 

datain = GetFileChunk(fin, CHUNKSIZE)
Do While (Len(datain) > 0)
datain = RemoveWhitespace(datain)
  

  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
'
  Seek #fout, Seek(fout) - lineTermLen

datain = GetFileChunk(fin, CHUNKSIZE)
Loop
 

If (Len(leftover) > 0) Then
Print #fout, leftover
End If

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

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

 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
 

dataLength = Lof(fin) - Seek(fin) + 1 - bytesToTrim
Do While (dataLength > 1)
If (dataLength > CHUNKSIZE) Then
lineLength = CHUNKSIZE
Else
lineLength = Cint(dataLength)
End If
  

  
  data = Space$(Fix(lineLength / 2))
Get #fin, , data
Put #fout, , data

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

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

'
Kill fileName
Name tempFileName As fileName
Exit Function

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

End Function