VBA隐写术

描述

隐秘术是将信息隐藏在清晰的视野中的行为。

隐写术的工作原理

一种流行的实现方式是获取现有的图像文件并操纵这些位以隐藏消息，而不会明显改变图像或增加大小。 它通过获取代表像素中颜色的每个字节并仅更改最后一位来实现此目的。

未压缩的位图文件使用三到四个字节来表示图像中的每个像素。 一个代表红色，一个代表绿色，一个代表蓝色，一个可选的代表alpha。 隐藏一个ascii字符需要8个字节。 仅更改每种颜色的最后一位可确保该更改非常小，以至于人眼不会注意到图像之间的颜色变化。

隐写术的示例实现

以下代码实现了上面的示例。 它仅适用于未压缩的位图图像。

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

From: https://bytes.com/topic/access/insights/942102-steganography-vba