Skip to content

Instantly share code, notes, and snippets.

@furyutei

furyutei/0.README.md

Last active Nov 15, 2020
Embed
What would you like to do?
[Excel][VBA] ゼロ幅スペースを利用した情報隠蔽の試み

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

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

ZwsEncode/Decode 002

使い方

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

エンコード時

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

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. ゼロ幅スペースを利用した情報隠蔽ツール

参照

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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment