Steganography for VBA

[Rabbit]

Description
Steganography is the act of hiding a message in plain sight.

How Steganography Works
One popular implementation is to take an existing image file and manipulate the bits to hide a message without noticeably changing the image or increasing the size. It does this by taking each byte that represents a color in a pixel and changing only the last bit.

An uncompressed bitmap file uses three to four bytes to represent each pixel in the image. One for red, one for green, one for blue, and an optional one for alpha. To hide a single ascii character would take 8 bytes. Changing only the last bit of each color ensures that the change is so slight that the human eye would not notice the change in color from picture to picture.

Sample Implementation of Steganography
The following code implements the above example. It only works on uncompressed bitmap images.

Option Explicit
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim oldFile, newFile, oFS, iSize, strMessage, i, ch, strPath
strPath = InputBox("File Path of Bitmap File:")
Set oFS = CreateObject("Scripting.FileSystemObject")
Set oldFile = oFS.OpenTextFile(strPath, ForReading)
 
If InputBox("1 for encode, 2 to decode") = 1 Then
    Set newFile = oFS.OpenTextFile(Replace(strPath, ".bmp", "-e.bmp"), ForWriting, True)
    iSize = (oFS.GetFile(strPath).Size \ 8) - 1
 
    Do
        strMessage = InputBox("Enter your message. The maximum number of characters is " & iSize & ".")
    Loop Until Len(strMessage) <= iSize
 
    newFile.Write(oldFile.Read(10))
 
    ch = oldFile.Read(1)
    newFile.Write(ch)
    iSize = Asc(ch)
 
    ch = oldFile.Read(1)
    newFile.Write(ch)
    iSize = iSize + Asc(ch) * 256
 
    ch = oldFile.Read(1)
    newFile.Write(ch)
    iSize = iSize + Asc(ch) * 65536
 
    ch = oldFile.Read(1)
    newFile.Write(ch)
    iSize = iSize + Asc(ch) * 16777216
 
    newFile.Write(oldFile.Read(iSize - 14))
 
    For i = 1 To Len(strMessage)
        ch = Asc(Mid(strMessage, i, 1))
 
        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
        newFile.Write(Chr(Asc(oldFile.Read(1)) And 254))
    Next
 
    Do Until oldFile.AtEndOfStream
        newFile.Write(oldFile.Read(1024))
    Loop
 
    newFile.Close
    Set newFile = Nothing
 
    MsgBox "Message Encoded!"
Else
    i = 0
    ch = 0
    strMessage = ""
 
    oldFile.Read(10)
    iSize = Asc(oldFile.Read(1))
    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 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

[twinnyfo]

Thanks, Rabbit! I always wondered how they did that... Now we all can be super secret squirrels!

[Frinavale]

I remember reading about the history of Steganography...

I remember one of the first usages of it.

There was of a slave who had their head shaved. A message tattooed to their scalp and their hair was left to grow back in. Once the hair was back, the slave was was sent to deliver the message.