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
You can’t perform that action at this time.