Sub SteganographyTest()
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim oldFile, newFile, oFS, iSize, strMessage, i, ch, strPath 'all variants
'get the name of the bmp file to be used
strPath = InputBox("File Path of Bitmap File:")
Set oFS = CreateObject("Scripting.FileSystemObject")
Set oldFile = oFS.OpenTextFile(strPath, ForReading) 'set file for read only
' Switch for program to 1 encode or 2 decode
If InputBox("1 for encode, 2 to decode") = 1 Then
'encoding so create a new file using oldfile name with suffix "-e"
'and set up for writing
Set newFile = oFS.OpenTextFile(Replace(strPath, ".bmp", "-e.bmp"), ForWriting, True)
'isize is size of oldfile after integer divide by 8, then subtract 1
'This determines the number of bytes you can use for message
iSize = (oFS.GetFile(strPath).Size \ 8) - 1
Do
'get the message from the user
strMessage = InputBox("Enter your message. The maximum number of characters is " & iSize & ".")
Loop Until Len(strMessage) <= iSize
'write the first 10 byts of old file (bmp header info probably)
newFile.Write (oldFile.Read(10))
'ch ?? is next 1 byte from old file
ch = oldFile.Read(1)
'write that byte to the new file
newFile.Write (ch)
'reuse isize it's now the asc representation of that byte
iSize = Asc(ch)
'reuse ch and assign it the next byte of the old file
ch = oldFile.Read(1) '''space/NUL in my case
newFile.Write (ch)
iSize = iSize + Asc(ch) * 256
'assign next byte of old file to ch
ch = oldFile.Read(1)
'write that byte to new file
newFile.Write (ch) 'another space/NUL in my case
iSize = iSize + Asc(ch) * 65536 'my isize is 54 jed
ch = oldFile.Read(1)
newFile.Write (ch)
iSize = iSize + Asc(ch) * 16777216 'isize is still 54
newFile.Write (oldFile.Read(iSize - 14))
' Loop through the message
'set ch to the ASC of the next byte
For i = 1 To Len(strMessage)
ch = Asc(Mid(strMessage, i, 1))
'ANDing bits of the BYTE (algorithm??) and writing the byte to new file
newFile.Write (Chr((Asc(oldFile.Read(1)) And 254) Or ((ch And 128) \ 128)))
newFile.Write (Chr((Asc(oldFile.Read(1)) And 254) Or ((ch And 64) \ 64)))
newFile.Write (Chr((Asc(oldFile.Read(1)) And 254) Or ((ch And 32) \ 32)))
newFile.Write (Chr((Asc(oldFile.Read(1)) And 254) Or ((ch And 16) \ 16)))
newFile.Write (Chr((Asc(oldFile.Read(1)) And 254) Or ((ch And 8) \ 8)))
newFile.Write (Chr((Asc(oldFile.Read(1)) And 254) Or ((ch And 4) \ 4)))
newFile.Write (Chr((Asc(oldFile.Read(1)) And 254) Or ((ch And 2) \ 2)))
newFile.Write (Chr((Asc(oldFile.Read(1)) And 254) Or ((ch And 1) \ 1)))
Next
For i = 1 To 8 'repeat 8 times
'get the CHR for the ASC of the byte in the Old File anded with 254 (2^^8) -2
'
'*** The number 254 in base 10 = 11111110 in base 2
'
newFile.Write (Chr(Asc(oldFile.Read(1)) And 254))
Next
' repeat writing 1024 byte chunks to new file until oldfile is at eof
Do Until oldFile.AtEndOfStream
newFile.Write (oldFile.Read(1024))
Loop
newFile.Close
Set newFile = Nothing
MsgBox "Message Encoded!" 'give user notice that encoding is finished
Else
'this is the decoding part (when decoding the old file is the encoded file)
i = 0
ch = 0
strMessage = ""
' read 10 bytes from the oldfile
oldFile.Read (10)
'read next byte of old file - get the asc representation of that byte and assign to isize
iSize = Asc(oldFile.Read(1))
'isize
iSize = iSize + Asc(oldFile.Read(1)) * 256
iSize = iSize + Asc(oldFile.Read(1)) * 65536
iSize = iSize + Asc(oldFile.Read(1)) * 16777216
oldFile.Read (iSize - 14)
' do the following until encoded file is at eof
Do Until oldFile.AtEndOfStream
i = i + 1
ch = ch Or ((Asc(oldFile.Read(1)) And 1) * (2 ^ (8 - i)))
If i = 8 Then
strMessage = strMessage & Chr(ch)
If ch = 0 Then
Exit Do
Else
ch = 0
i = 0
End If
End If
Loop
MsgBox strMessage
End If
oldFile.Close
Set oldFile = Nothing
Set oFS = Nothing
End Sub
