Формат XXEncode на VBA, или как загрузить бинарник в документ

в 16:47, , рубрики: vba, XXE, Песочница, метки: ,

При работе в связке Excel+VBA бывает нужно хранить бинарные данные в контейнере, который накладывает ограничения содержимое. Для этих задач были разработан формат XXEncode. И вот, допустим, Вам захотелось иметь необходимые библиотеки и утилиты, связанные с вашим проектом VBA всегда при себе, внутри Рабочей книги .xls. Ниже я покажу, как я реализовал у себя хранение бинарных файлов в комментариях стандартных модулей проектов VBA.

Кодирование бинарных данных в XXE и обратное преобразование — лкодирование — я рализовал двумя функциями, bin2xxt и xxe2bin соответственно. Чтобы код был более-менее переносим между разными задачами, бинарные данные представлены массивом байт, а закодированные в XXE данные храню в строках.

'' Кодирование массива байт в строку xxe
Function bin2xxe(src() As Byte, fname As String) As String
    Dim i As Long, n As Long, t As Byte, xxe() As String, s As String, sz As Long, pt As Long
    
    xxe = Split("+ - 0 1 2 3 4 5 6 7 8 9 A B C D E F G H I J K L M N O P Q R S T U V W X Y Z a b c d e f g h i j k l m n o p q r s t u v w x y z")
    
    i = 0
    n = UBound(src)
    s = Space(((n + 1)  45) * 63 + ((n + 1) Mod 45) * 4  3 + 280)
    pt = 1
    sz = 12 + Len(fname)
    Mid$(s, 1, sz) = "begin 644 " & fname & vbCrLf
    pt = pt + sz + 1
    sz = pt - 1
    Do While i <= n
        If i Mod 3 = 0 Then
            Mid$(s, pt, 1) = xxe(src(i)  4): pt = pt + 1
            t = (src(i) And 3) * 16
        ElseIf i Mod 3 = 1 Then
            Mid$(s, pt, 1) = xxe(t + (src(i)  16)): pt = pt + 1
            t = (src(i) And 15) * 4
        ElseIf i Mod 3 = 2 Then
            Mid$(s, pt, 2) = xxe(t + src(i)  64) & xxe(src(i) And 63): pt = pt + 2
            t = 0
        End If
        If i Mod 45 = 44 Then
            Mid$(s, sz, 1) = "h"
            Mid$(s, pt, 2) = vbCrLf: pt = pt + 3: sz = pt - 1
        End If
        i = i + 1
    Loop
    If (n + 1) Mod 3 <> 0 Then
        Mid$(s, pt, 1) = xxe(t): pt = pt + 1
    End If
    
    t = (n Mod 45) + 1
    If t <> 45 Then
        Mid$(s, sz, 1) = xxe(t)
        Mid$(s, pt, 3) = "+" & vbCrLf: pt = pt + 3
    End If
    
    Mid$(s, pt, 3) = "end": sz = pt + 2
    bin2xxe = Left(s, sz)
End Function

Function xxe2bin(src As String, fname As String) As Byte()
    Dim t() As String, t0() As String, i As Long, j As Long, k As Long
    Dim xxe As String, bStrLen As Byte, lStart As Long, h As Byte, x As Byte
    Dim dst() As Byte, xxeIdx(43 To 122) As Byte
    
    xxeIdx(43) = 0: xxeIdx(45) = 1
    For i = 48 To 57: xxeIdx(i) = i - 46: Next
    For i = 65 To 90: xxeIdx(i) = i - 53: Next
    For i = 97 To 122: xxeIdx(i) = i - 59: Next
    
    t = Split(src, vbCrLf)
    t0 = Split(t(0))
    If t0(0) <> "begin" Then Exit Function
    If UBound(t0) = 2 Then fname = t0(2) Else Exit Function
    
    j = 1
    Do While t(j) <> "end" And j <= UBound(t)
        lStart = lStart + xxeIdx(Asc(Left$(t(j), 1)))
        j = j + 1
    Loop
    ReDim dst(0 To lStart - 1)
    
    j = 1: lStart = 0: x = 0
    Do While t(j) <> "end" And j <= UBound(t)
        bStrLen = xxeIdx(Asc(Left$(t(j), 1)))
        
        i = 2
        k = 0
        Do While i <= Len(t(j)) And k <= bStrLen - 1
            h = xxeIdx(Asc(Mid$(t(j), i, 1)))
            Select Case i And 3
            Case 0:
                dst(lStart + k) = x + h  4
                x = (h And 3) * 64
                k = k + 1
            Case 1:
                dst(lStart + k) = x + h
                x = 0
                k = k + 1
            Case 2:
                x = h * 4
            Case 3:
                dst(lStart + k) = x + h  16
                x = (h And 15) * 16
                k = k + 1
            End Select
            i = i + 1
        Loop
        lStart = lStart + bStrLen
        j = j + 1
    Loop
    xxe2bin = dst
End Function

Кроме того, для поставленной задачи написаны также пара процедур оболочек к кодированию/декодированию: file2stdm загрузка бинарного файла в стандартный модуль проекта VBA (xxe-код размещается в отдельном модуле в комментариях) и обратное преобразование — распаковка файла из того, что закодировано в стандартный модуль stdm2file. Здесь надо отметить, что для свободных манипуляций в VBProject на целевой машине должен быть разрешен доступ к проектам VBA. Ниже привожу пару процедур-оболочек:

' Сохранение файла в стандартном модуле VBA
Sub file2stdm(fpath As String, fname As String, wbk As Workbook)
    Dim src() As Byte, s As String, i As Long, t() As String
    Dim stdm As VBComponent, f As Long
    
    f = FreeFile
    Open fpath & "" & fname For Binary Access Read As #f
    ReDim src(0 To LOF(f) - 1) As Byte
    Get #f, 1, src
    Close #f
    
    s = bin2xxe(src, fname)
    
    t = Split(s, vbCrLf)
    For i = 0 To UBound(t)
        t(i) = "'" & t(i)
    Next
    s = Join(t, vbCrLf)
    
    Set stdm = wbk.VBProject.VBComponents.Add(vbext_ct_StdModule)
    stdm.Name = "m" & Replace(fname, ".", "")
    stdm.CodeModule.AddFromString s
    Set stdm = Nothing
End Sub

' Распаковка файла из стандартного модуля VBA
Sub stdm2file(fpath As String, fname As String, wbk As Workbook)
    Dim stdm As VBComponent, i As Long, m As Long, n As Long
    Dim s As String, t() As String, dst() As Byte, f As Long
    
    Set stdm = wbk.VBProject.VBComponents("m" & Replace(fname, ".", ""))
    For i = 1 To stdm.CodeModule.CountOfLines
        If stdm.CodeModule.Lines(i, 1) Like "'begin *" Then m = i
        If stdm.CodeModule.Lines(i, 1) Like "'end*" Then n = i - m + 1
    Next
    s = stdm.CodeModule.Lines(m, n)
    Set stdm = Nothing
    
    t = Split(s, vbCrLf)
    For i = 0 To UBound(t)
        t(i) = Mid(t(i), 2)
    Next
    s = Join(t, vbCrLf)
    
    dst = xxe2bin(s, fname)
    
    f = FreeFile
    Open ThisWorkbook.Path & "" & fname For Binary Access Write As #f
    Put #f, 1, dst
    Close #f
End Sub

Разумеется, надо теперь все, что имеем — задействовать в работе. Две тестовые процедуры, одна загружает файл в модуль, другая — распаковывает файл из модуля на диск.

Sub test1()
    ' Распаковать файл из модуля (в формате xxe)
    stdm2file ThisWorkbook.Path, "dzp.exe", ThisWorkbook
    ' И запустить, проверим ваши антивирусы
    'Shell ThisWorkbook.Path & "" & "dzp.exe", vbNormalNoFocus
End Sub

Sub test2()
    ' Удалить модуль mdzpexe перед созданием
    On Error Resume Next
    With ThisWorkbook.VBProject.VBComponents
        .Remove .Item("mdzpexe")
    End With
    ' Упаковать файл в модуль (в формате xxe)
    file2stdm ThisWorkbook.Path, "dzp.exe", ThisWorkbook
End Sub

Кроме, того, кодировка в формат XXE может применяется в e-mail (наряду с base64) для хранения вложений, а набор символов кодировки (+-A-Za-z) позволяет запостить бинарник почти на любом интерактивном сайте, скажем в комментариях, если это не противоречит правилам ресурса.

Источники:
Статья Xxencoding в Wikipedia

Автор: mcblack

* - обязательные к заполнению поля


https://ajax.googleapis.com/ajax/libs/jquery/3.4.1/jquery.min.js