[Excel][VBA] ゼロ幅スペースを利用した情報隠蔽の試み

0.README.md

[Excel][VBA] ゼロ幅スペースを利用した情報隠蔽の試み

Unicode ゼロ幅スペースを利用して情報を隠して仕込むというネタを見かけ、面白そうだったので Excel でも文字列のエンコード／デコードができるようにコードを書いてみました。

使い方

情報隠蔽ツールのソースコードを標準モジュールとして貼り付ければ、ユーザー定義関数として使えます。

エンコード時

変換した結果の隠蔽用文字列（ゼロ幅スペースなので見た目空欄に見えてしまいますが）をコピーして、ツイートに貼り付けてやったりできます。

ZwsEncode(SourceString, [UseUtf8])

  SourceString
    対象文字列もしくは文字列が入った単独のセル参照
  UseUtf8 [省略可]
    True: UTF-8に変換してエンコード(デフォルト)
    False: UTF-16LEのままエンコード

• UseUtf8 が True の場合、出力されたゼロ幅スペース文字列は元ツールと互換性があります（デフォルト）
• UseUtf8 を False にすると、日本語が多い文章の場合には True の場合と比べて出力文字列が短くなります。ただし、元ツールとの互換性は失われます

デコード時

たとえば、隠蔽文字列が含まれるツイート のテキストをコピーして指定してやると、隠蔽された文字列が得られます。

---

ZwsDncode(SourceString, [RetainNonZwsChars], [UseUtf8])

  SourceString
    対象文字列もしくは文字列が入った単独のセル参照
  RetainNonZwsChars [省略可]
    True: デコード対象外の文字も残す
    False: デコード対象外の文字は削除（デフォルト）
  UseUtf8 [省略可]
    True: UTF-8とみなしてデコード（デフォルト）
    False: UTF-16LEとみなしてデコード

• UseUtf8 は、エンコード時の指定に合わせる必要があります

ソースコード

1. ゼロ幅スペースを利用した情報隠蔽ツール

参照

• Unicode ゼロ幅スペースを利用して情報を隠して仕込む - A painter and a black cat
• kanata2003/ZeroWidthSpace: Unicode Steganography tool using zero-width space. Unicodeゼロ幅スペースを利用した情報の隠蔽ツール

ZeroWidthSpaceTool.vba

Option Explicit

' ■ ゼロ幅スペースを用いた情報隠蔽ツール
'
'   元ネタ：[kanata2003/ZeroWidthSpace: Unicode Steganography tool using zero-width space. Unicodeゼロ幅スペースを利用した情報の隠蔽ツール](https://github.com/kanata2003/ZeroWidthSpace)

' 変換に用いるゼロ幅スペースのコード定義
Const ZWS0 = &H200B, ZWS1 = &H200C, ZWS2 = &H200D, ZWS3 = &H2062

Function ZwsEncode(ByVal SourceString, Optional UseUtf8 = True)
    Dim HexString: HexString = ConvertStringToHexString(CStr(SourceString), UseUtf8)
    Dim ZwsString As String
    Dim Index
    
    For Index = 1 To Len(HexString)
        ZwsString = ZwsString & ConvertHexDigitToZwsUnit(Val("&h" & Mid(HexString, Index, 1)))
    Next

    ZwsEncode = ZwsString
End Function

Function ZwsDecode(ByVal SourceString, Optional RetainNonZwsChars = False, Optional UseUtf8 = True)
    Static RegExp As Object: If RegExp Is Nothing Then Set RegExp = CreateObject("VBScript.RegExp")

    With RegExp
        .Global = True

        Dim ZwsNumberChars: ZwsNumberChars = Join(GetZwsNumberCharArray, "")
        Dim ZwsString: ZwsString = CStr(SourceString)
        
        If Not RetainNonZwsChars Then
            .Pattern = "[^" & ZwsNumberChars & "]+"
            ZwsString = .Replace(ZwsString, "")
        End If
        
        Dim HexString
        Dim MatchPart
        Dim Position
        
        .Pattern = "[" & ZwsNumberChars & "]+"
        Position = 0
        ZwsDecode = ""
        
        For Each MatchPart In .Execute(ZwsString)
            If Position < MatchPart.FirstIndex Then ZwsDecode = ZwsDecode & Mid(ZwsString, 1 + Position, MatchPart.FirstIndex - Position)
            ZwsDecode = ZwsDecode & DecodeZwsString(MatchPart.Value, UseUtf8)
            Position = MatchPart.FirstIndex + MatchPart.Length
        Next
        
        If Position < Len(ZwsString) Then ZwsDecode = ZwsDecode & Right(ZwsString, Len(ZwsString) - Position)
    End With
End Function

Private Function DecodeZwsString(ByVal ZwsString, Optional UseUtf8 = True)
    Static RegExp As Object: If RegExp Is Nothing Then Set RegExp = CreateObject("VBScript.RegExp")

    With RegExp
        .Global = True
        
        Dim HexString
        Dim MatchPart
        
        .Pattern = "[" & Join(GetZwsNumberCharArray, "") & "]{2}"
        
        For Each MatchPart In .Execute(ZwsString)
            HexString = HexString & Hex(ConvertZwsUnitToHexDigit(MatchPart.Value))
        Next
        
        DecodeZwsString = ConvertHexStringToString(HexString, UseUtf8)
    End With
End Function

Private Function ConvertHexDigitToZwsUnit(SourceHexDigit)
    Static HexDigitToZwsUnitMap As Object
    
    If HexDigitToZwsUnitMap Is Nothing Then
        Set HexDigitToZwsUnitMap = CreateObject("Scripting.Dictionary")
        
        Dim ZwsNumberCharArray: ZwsNumberCharArray = GetZwsNumberCharArray
        Dim HexDegit
        
        For HexDegit = 0 To 15
            HexDigitToZwsUnitMap(HexDegit) = ZwsNumberCharArray(Fix(HexDegit / 4)) & ZwsNumberCharArray(HexDegit Mod 4)
        Next
    End If
    ConvertHexDigitToZwsUnit = HexDigitToZwsUnitMap(SourceHexDigit Mod 16)
End Function

Private Function ConvertZwsUnitToHexDigit(SourceZwsUnit)
    Static ZwsUnitToHexDigitMap As Object
    
    If ZwsUnitToHexDigitMap Is Nothing Then
        Set ZwsUnitToHexDigitMap = CreateObject("Scripting.Dictionary")
        
        Dim HexDegit
        
        For HexDegit = 0 To 15
            ZwsUnitToHexDigitMap(ConvertHexDigitToZwsUnit(HexDegit)) = HexDegit
        Next
    End If
    ConvertZwsUnitToHexDigit = ZwsUnitToHexDigitMap(SourceZwsUnit)
End Function

Private Function GetZwsNumberCharArray()
    Static ZwsNumberCharArray
    
    If IsEmpty(ZwsNumberCharArray) Then
        ZwsNumberCharArray = VBA.Array(ChrW(ZWS0), ChrW(ZWS1), ChrW(ZWS2), ChrW(ZWS3))
    End If
    GetZwsNumberCharArray = ZwsNumberCharArray
End Function

Private Function ConvertStringToHexString(ByVal SourceString, Optional UseUtf8 = True)
    ConvertStringToHexString = ""
    If SourceString = "" Then Exit Function
    
    Dim BinChars() As Byte
    
    If UseUtf8 Then
        BinChars = Utf8Encode(CStr(SourceString))
    Else
        BinChars = CStr(SourceString)
    End If
    
    Dim HexChars: ReDim HexChars(LBound(BinChars) To UBound(BinChars)) As String
    
    Dim Char As Long
    For Char = LBound(BinChars) To UBound(BinChars)
        HexChars(Char) = Right("00" & Hex(BinChars(Char)), 2)
    Next Char
    ConvertStringToHexString = Join(HexChars, "")
End Function

Private Function ConvertHexStringToString(ByVal HexString, Optional UseUtf8 = True)
    ConvertHexStringToString = ""
    If HexString = "" Or Len(HexString) Mod 2 <> 0 Then Exit Function
    
    Dim BinChars() As Byte: ReDim BinChars(0 To Len(HexString) / 2 - 1)
    Dim Index As Long
    
    For Index = 0 To Len(HexString) / 2 - 1
        BinChars(Index) = Val("&H" & Mid(HexString, Index * 2 + 1, 2))
    Next
    
    Dim ResultString As String
    
    If UseUtf8 Then
        ResultString = Utf8Decode(BinChars)
    Else
        ResultString = BinChars
    End If
    
    ConvertHexStringToString = ResultString
End Function

Private Function Utf8Encode(SourceString)
    Static AdoStream As Object: If AdoStream Is Nothing Then Set AdoStream = CreateObject("ADODB.Stream")
    
    With AdoStream
        .Mode = 3
        .Open
        .Type = 2
        .Charset = "UTF-8"
        .WriteText SourceString
        .Position = 0
        .Type = 1
        .Position = 3
        Utf8Encode = .Read
        .Close
    End With
End Function

Private Function Utf8Decode(SourceBinary)
    Static AdoStream As Object: If AdoStream Is Nothing Then Set AdoStream = CreateObject("ADODB.Stream")
    
    With AdoStream
        .Mode = 3
        .Open
        .Type = 1
        .Write SourceBinary
        .Position = 0
        .Type = 2
        .Charset = "UTF-8"
        Utf8Decode = .ReadText(-1)
        .Close
    End With
End Function