I discovered a way to get around the problem of web bowsers (eg. Google Chrome) and mail servers (eg. Gmail) blocking executable files without any notification or bypass method. The servers do not identify potential malware based upon the file extension, but rather on the file format itself. So the logical solution is to change the format.
This program has the added advantage of encrypting the file using the outdated RC4 encryption technique. Speed and ease of use are among RC4's major benefits. But RC4 can be hacked, especially if you use the same key repeatedly. Also, RC4 isn't ideal if you have small bits of data to send.
To combat these issues, the key is different with each file and is shuffled. To identify and separate the original and encrypted files, the encrypted file has an extra ".edf" (Encrypted Data File) extension added to the file name.
The RC4 code that I found was for VBA and included an extra loop routine to advance the byte table. I really don't know if that makes the results more secure or not, but for now I have commented it out.
J.A. Coutts
This program has the added advantage of encrypting the file using the outdated RC4 encryption technique. Speed and ease of use are among RC4's major benefits. But RC4 can be hacked, especially if you use the same key repeatedly. Also, RC4 isn't ideal if you have small bits of data to send.
To combat these issues, the key is different with each file and is shuffled. To identify and separate the original and encrypted files, the encrypted file has an extra ".edf" (Encrypted Data File) extension added to the file name.
The RC4 code that I found was for VBA and included an extra loop routine to advance the byte table. I really don't know if that makes the results more secure or not, but for now I have commented it out.
J.A. Coutts
Code:
Option Explicit
Dim AllBytes(255) As Byte
Private ByteBuffer() As Byte
Private eBuffer() As Byte
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cbMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Sub cmdDecrypt_Click()
Dim FileName As String
With Dialog1
.DialogTitle = "Select a File"
.InitDir = App.Path '"C:\"
.Filter = "All Files|*.*"
.ShowOpen
FileName = .FileName
End With
Me.Caption = FileName
If Len(FileName) = 0 Then
MsgBox "Nothing Selected!", vbExclamation
Exit Sub
End If
GetFile (FileName)
'DebugPrintByte FileName, ByteBuffer
If Right$(FileName, 4) = ".edf" Then
FileName = Left$(FileName, Len(FileName) - 4)
Else
MsgBox "Improper file name!", vbExclamation
Exit Sub
End If
eBuffer = RunRC4(ByteBuffer, FileName)
'DebugPrintByte "RC4 Decrypted", eBuffer
Erase ByteBuffer
PutFile (FileName)
End Sub
Private Sub cmdEncrypt_Click()
Dim FileName As String
With Dialog1
.DialogTitle = "Select a File"
.InitDir = App.Path '"C:\"
.Filter = "All Files|*.*"
.ShowOpen
FileName = .FileName
End With
Me.Caption = FileName
If Len(FileName) = 0 Then
MsgBox "Nothing Selected!", vbExclamation
Exit Sub
End If
GetFile (FileName)
'DebugPrintByte FileName, ByteBuffer
eBuffer = RunRC4(ByteBuffer, FileName)
'DebugPrintByte "RC4 Encrypted", eBuffer
Erase ByteBuffer
FileName = FileName & ".edf"
PutFile (FileName)
End Sub
Private Sub Form_Load()
Dim lPtr As Long
For lPtr = 0 To 255
AllBytes(lPtr) = lPtr
Next
End Sub
Private Function RunRC4(bText() As Byte, sKey As String) As Byte()
Dim S() As Byte
Dim NewKey As String
Dim bKey() As Byte
Dim kLen As Long
Dim bTmp As Byte
Dim I As Long
Dim J As Long
Dim lPtr As Long
Dim sLen As Long
Dim bResult() As Byte
S = AllBytes
NewKey = Mid$(sKey, InStrRev(sKey, "\") + 1)
bKey = StrToUtf8(Shuffle(NewKey, False))
kLen = GetbSize(bKey)
For I = 0 To 255
J = (J + S(I) + bKey(I Mod kLen)) Mod 256
bTmp = S(I)
S(I) = S(J)
S(J) = bTmp
Next I
I = 0
J = 0
'DebugPrintByte "Initial", S
'For lPtr = 0 To 3071
' I = (I + 1) Mod 256
' J = (J + S(I)) Mod 256
' bTmp = S(I)
' S(I) = S(J)
' S(J) = bTmp
'Next lPtr
'DebugPrintByte "Cycled", S
sLen = GetbSize(bText)
ReDim bResult(sLen - 1)
For lPtr = 0 To sLen - 1
I = (I + 1) Mod 256
J = (J + S(I)) Mod 256
bTmp = S(I)
S(I) = S(J)
S(J) = bTmp
bResult(lPtr) = S((CLng(S(I)) + S(J)) Mod 256) Xor bText(lPtr)
Next lPtr
RunRC4 = bResult
End Function
Private Function StrToUtf8(strInput As String) As Byte()
Const CP_UTF8 = 65001
Dim nBytes As Long
Dim abBuffer() As Byte
If Len(strInput) < 1 Then Exit Function
' Get length in bytes *including* terminating null
nBytes = WideCharToMultiByte(CP_UTF8, 0&, ByVal StrPtr(strInput), -1, 0&, 0&, 0&, 0&)
' We don't want the terminating null in our byte array, so ask for `nBytes-1` bytes
ReDim abBuffer(nBytes - 2) ' NB ReDim with one less byte than you need
nBytes = WideCharToMultiByte(CP_UTF8, 0&, ByVal StrPtr(strInput), -1, ByVal VarPtr(abBuffer(0)), nBytes - 1, 0&, 0&)
StrToUtf8 = abBuffer
End Function
Public Function Shuffle(sInput As String, flgRev As Boolean, Optional bHex As Byte) As String
Dim bTmp As Byte
Dim bInput() As Byte
Dim iLen As Integer
Dim bKey As Byte
Dim I%, N%
Dim iStart As Integer
Dim iEnd As Integer
Dim iStep As Integer
bInput = StrToUtf8(sInput)
If bHex Then
bKey = bHex
Else
For N% = 0 To UBound(bInput) Step 1
bKey = bKey Xor bInput(N%) + CByte(N%)
Next N%
If bKey = 0 Then bKey = 255
End If
iLen = GetbSize(bInput)
If flgRev Then
iStart = iLen - 1
iEnd = 0
iStep = -1
Else
iStart = 0
iEnd = iLen - 1
iStep = 1
End If
For I% = iStart To iEnd Step iStep
N% = ((bKey Mod (I% + 1)) + I%) Mod iLen
bTmp = bInput(I%)
bInput(I%) = bInput(N%)
bInput(N%) = bTmp
Next I%
Shuffle = Utf8ToStr(bInput)
End Function
Private Function Utf8ToStr(abUtf8Array() As Byte) As String
Const CP_UTF8 = 65001
Dim nBytes As Long
Dim nChars As Long
Dim strOut As String
' Catch uninitialized input array
nBytes = GetbSize(abUtf8Array)
If nBytes <= 0 Then Exit Function
' Get number of characters in output string
nChars = MultiByteToWideChar(CP_UTF8, 0&, VarPtr(abUtf8Array(0)), nBytes, 0&, 0&)
' Dimension output buffer to receive string
strOut = String(nChars, 0)
nChars = MultiByteToWideChar(CP_UTF8, 0&, VarPtr(abUtf8Array(0)), nBytes, StrPtr(strOut), nChars)
Utf8ToStr = Replace(strOut, Chr$(0), "") 'Remove Null terminating characters
End Function
Private Sub DebugPrintByte(sDescr As String, bArray() As Byte)
Dim lPtr As Long
On Error GoTo Done
Debug.Print sDescr & ":"
For lPtr = 0 To UBound(bArray)
Debug.Print Right$("0" & Hex$(bArray(lPtr)), 2) & " ";
If (lPtr + 1) Mod 16 = 0 Then Debug.Print
Next lPtr
Done:
Debug.Print
End Sub
Private Sub GetFile(FileName As String)
Dim iFile As Integer
iFile = FreeFile()
Open FileName For Binary Shared As iFile
ReDim ByteBuffer(LOF(iFile) - 1)
Get #iFile, , ByteBuffer
Close #iFile
End Sub
Private Sub PutFile(NewFile As String)
Dim iFile As Integer
On Error GoTo PutErr
iFile = FreeFile()
Open NewFile For Binary Shared As iFile
Put #iFile, , eBuffer
Close #iFile
Exit Sub
PutErr:
MsgBox "Error: " & CStr(Err)
End Sub
Private Function GetbSize(bArray() As Byte) As Long
On Error GoTo GetSizeErr
GetbSize = UBound(bArray) + 1
Exit Function
GetSizeErr:
GetbSize = 0
End Function