Vba excel шифрование текста

Sub Main()
    Dim Key As String
    Dim Msg As String
    Dim EncryptMsg As String
    Dim DecryptMsg As String

    Key = "мечта"
    Msg = "реализация шифра методом вертикальной перестановки с ключом мечта"

    EncryptMsg = VerticalShuffleEncrypt(Key, Msg)
    DecryptMsg = VerticalShuffleDecrypt(Key, EncryptMsg)

    ' реализация шифра методом вертикальной перестановки с ключом мечта '
    Cells(1, 1).Value = Msg
    ' иярт инеаил аеаш деайеосчерз аовкорн юмлифемтьптккмтациморл св оч '
    Cells(2, 1).Value = EncryptMsg
    ' реализация шифра методом вертикальной перестановки с ключом мечта '
    Cells(3, 1).Value = DecryptMsg
End Sub

Function VerticalShuffleEncrypt(ByVal Key As String, ByVal Msg As String) As String
    Dim KeyArr As Object
    Dim L As Long
    Dim Col As String
    Dim Res As String

    L = Len(Msg)  Len(Key)
    If (Len(Msg) Mod Len(Key) <> 0) Then
        L = L + 1
    End If

    Set KeyArr = CreateObject("System.Collections.ArrayList")

    For I = 1 To Len(Key)
        KeyArr.Add Mid(Key, I, 1)
    Next I

    KeyArr.Sort

    Res = ""
    For Each K In KeyArr
        I = InStr(1, Key, K, vbTextCompare)
        Col = ""
        'For J = I To Len(Msg) Step L
        '    Res = Res & Mid(Msg, J, 1)
        'Next J
        For J = I To Len(Msg) Step Len(Key)
            Col = Col & Mid(Msg, J, 1)
        Next J
        If (Len(Col) <> L) Then
            Col = Col & " "
        End If
        Res = Res & Col
    Next

    VerticalShuffleEncrypt = Res
End Function

Function VerticalShuffleDecrypt(ByVal Key As String, ByVal Msg As String) As String
    Dim KeyArr As Object
    Dim IndexArr As Object
    Dim L As Long
    Dim Res As String

    L = Len(Msg)  Len(Key)
    If (Len(Msg) Mod Len(Key) <> 0) Then
        L = L + 1
    End If

    Set KeyArr = CreateObject("System.Collections.ArrayList")
    Set IndexArr = CreateObject("System.Collections.ArrayList")

    For I = 1 To Len(Key)
        KeyArr.Add Mid(Key, I, 1)
    Next I

    KeyArr.Sort

    For I = 1 To Len(Key)
        IndexArr.Add KeyArr.IndexOf(Mid(Key, I, 1), 0) + 1
    Next I

    Res = ""
    For I = 1 To L
        For Each Index In IndexArr
            Res = Res & Mid(Msg, ((Index - 1) * L) + I, 1)
        Next
    Next I

    VerticalShuffleDecrypt = Res
End Function

Шифр вертикальной перестановки

м   е   ч   т   а

3   2   5   4   1

р   е   а   л   и
з   а   ц   и   я
    ш   и   ф   р
а       м   е   т
о   д   о   м   
в   е   р   т   и
к   а   л   ь   н
о   й       п   е
р   е   с   т   а
н   о   в   к   и
    с       к   л
ю   ч   о   м   
м   е   ч   т   а

Результат:

Исходное сообщение:

реализация шифра методом вертикальной перестановки с ключом мечта

Зашифрованное сообщение:

иярт инеаил аеаш деайеосчерз аовкорн юмлифемтьптккмтациморл св оч

Восстановленное сообщение:

реализация шифра методом вертикальной перестановки с ключом мечта

В этой статье опубликованы различные вспомогательные функции на VBA, которые порой помогают в работе.

1. Функция формирования инициалов из имени и отчества

Function CropFIO(ByVal FIO As String) As String
    ' получает в качестве параметра текстовую строку с виде "Фамилия имя отчество"
    ' обрезает имя и отчество, оставляя лишь инициалы - в виде "Фамилия И. О."
    CropFIO = Application.Trim(FIO): arr = Split(CropFIO, " ")
    If UBound(arr) <> 2 Then Exit Function    ' Если в ячейке не 3 слова - выход из процедуры
    CropFIO = Replace(CropFIO, " " & arr(1), " " & UCase(Left(arr(1), 1)) & ".")
    CropFIO = Replace(CropFIO, " " & arr(2), " " & UCase(Left(arr(2), 1)) & ".")
End Function

2. Шифрование строк на VBA

Dim s(0 To 255) As Integer, kep(0 To 255) As Integer
 
Public Function EnDeCrypt(ByVal plaintxt As String, ByVal Password As String) As String
    Dim temp As Integer, a As Integer, b As Integer, cipherby As Byte, cipher As String
    b = 0: For a = 0 To 255: b = b + 1: If b > Len(Password) Then b = 1
        kep(a) = Asc(Mid$(Password, b, 1)): Next a
    For a = 0 To 255: s(a) = a: Next a: b = 0
    For a = 0 To 255: b = (b + s(a) + kep(a)) Mod 256: temp = s(a): s(a) = s(b): s(b) = temp: Next a
    For a = 1 To Len(plaintxt): cipherby = EnDeCryptSingle(Asc(Mid$(plaintxt, a, 1)))
        cipher = cipher & Chr(cipherby): Next: EnDeCrypt = cipher
End Function
Public Function EnDeCryptSingle(plainbyte As Byte) As Byte
    Dim i As Integer, j As Integer, temp As Integer, k As Integer, cipherby As Byte
    i = (i + 1) Mod 256: j = (j + s(i)) Mod 256: temp = s(i): s(i) = s(j): s(j) = temp
    k = s((s(i) + s(j)) Mod 256): cipherby = plainbyte Xor k: EnDeCryptSingle = cipherby
End Function
 
' примеры использования
Sub Шифрование_с_расшифровкой()
    MsgBox EnDeCrypt(EnDeCrypt("123456", "passw"), "passw")
End Sub
 
Sub Тест_шифра()
    MsgBox EnDeCrypt("123456", "пароль")
End Sub

3. Сортировка двумерного массива по нулевому столбцу

Public Function CoolSort(SourceArr As Variant) As Variant
    Dim Check As Boolean, iCount As Integer, jCount As Integer, nCount As Integer
    ReDim tmpArr(UBound(SourceArr, 2)) As Variant
    Do Until Check
        Check = True
        For iCount = LBound(SourceArr, 1) To UBound(SourceArr, 1) - 1
            If Val(SourceArr(iCount, 0)) > Val(SourceArr(iCount + 1, 0)) Then
                For jCount = LBound(SourceArr, 2) To UBound(SourceArr, 2)
                    tmpArr(jCount) = SourceArr(iCount, jCount)
                    SourceArr(iCount, jCount) = SourceArr(iCount + 1, jCount)
                    SourceArr(iCount + 1, jCount) = tmpArr(jCount)
                    Check = False
                Next
            End If
        Next
    Loop
    CoolSort = SourceArr
End Function

4. Преобразование строки в набор ASC кодов

Function String2CharCodes(ByVal txt$) As String
    sep = " & "
    For i = 1 To Len(txt)
        charcode = "Chr(" & Asc(Mid(txt, i, 1)) & ")"
        String2CharCodes = String2CharCodes & sep & charcode
    Next i
    String2CharCodes = Mid(String2CharCodes, Len(sep) + 1)
End Function

5. Функции для определения нажатой клавиши

'============= Функции для определения нажатой клавиши =================================
Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As VirtualKeys) As Integer
 
Public Enum VirtualKeys    ' Virtual Keys, Standard Set
    VK_LBUTTON = &H1: VK_RBUTTON = &H2: VK_CANCEL = &H3: VK_MBUTTON = &H4    'VK_MBUTTON = &H4 -  NOT contiguous with L RBUTTON
    VK_BACK = &H8: VK_TAB = &H9: VK_CLEAR = &HC: VK_RETURN = &HD
    VK_SHIFT = &H10: VK_CONTROL = &H11: VK_MENU = &H12: VK_PAUSE = &H13: VK_CAPITAL = &H14: VK_ESCAPE = &H1B
    VK_SPACE = &H20: VK_PRIOR = &H21: VK_NEXT = &H22: VK_END = &H23: VK_HOME = &H24
    VK_LEFT = &H25: VK_UP = &H26: VK_RIGHT = &H27: VK_DOWN = &H28: VK_SELECT = &H29: VK_PRINT = &H2A
    VK_EXECUTE = &H2B: VK_SNAPSHOT = &H2C: VK_INSERT = &H2D: VK_DELETE = &H2E: VK_HELP = &H2F
 
    ' VK_A thru VK_Z are the same as their ASCII equivalents: 'A' thru 'Z'
    ' VK_0 thru VK_9 are the same as their ASCII equivalents: '0' thru '9'

    VK_NUMPAD0 = &H60: VK_NUMPAD1 = &H61: VK_NUMPAD2 = &H62: VK_NUMPAD3 = &H63: VK_NUMPAD4 = &H64
    VK_NUMPAD5 = &H65: VK_NUMPAD6 = &H66: VK_NUMPAD7 = &H67: VK_NUMPAD8 = &H68: VK_NUMPAD9 = &H69
    VK_MULTIPLY = &H6A: VK_ADD = &H6B: VK_SEPARATOR = &H6C: VK_SUBTRACT = &H6D: VK_DECIMAL = &H6E: VK_DIVIDE = &H6F
    VK_F1 = &H70: VK_F2 = &H71: VK_F3 = &H72: VK_F4 = &H73: VK_F5 = &H74: VK_F6 = &H75: VK_F7 = &H76
    VK_F8 = &H77: VK_F9 = &H78: VK_F10 = &H79: VK_F11 = &H7A: VK_F12 = &H7B
    VK_F13 = &H7C: VK_F14 = &H7D: VK_F15 = &H7E: VK_F16 = &H7F: VK_F17 = &H80: VK_F18 = &H81
    VK_F19 = &H82: VK_F20 = &H83: VK_F21 = &H84: VK_F22 = &H85: VK_F23 = &H86: VK_F24 = &H87
    VK_NUMLOCK = &H90: VK_SCROLL = &H91
 
    '   VK_L VK_R - left and right Alt, Ctrl and Shift virtual keys.
    '   Used only as parameters to GetAsyncKeyState() and GetKeyState().
    '   No other API or message will distinguish left and right keys in this way.
    VK_LSHIFT = &HA0: VK_RSHIFT = &HA1: VK_LCONTROL = &HA2: VK_RCONTROL = &HA3: VK_LMENU = &HA4: VK_RMENU = &HA5
 
    VK_ATTN = &HF6: VK_CRSEL = &HF7: VK_EXSEL = &HF8: VK_EREOF = &HF9: VK_PLAY = &HFA
    VK_ZOOM = &HFB: VK_NONAME = &HFC: VK_PA1 = &HFD: VK_OEM_CLEAR = &HFE
End Enum
'==========================================================================================

Public Function KeyPressed(ByVal VKey As VirtualKeys) As Boolean
    KeyPressed = IIf(GetKeyState(VKey) < 0, True, False)
End Function

6. Макрос для создания копии файла программы
(подразумевается наличие в программе глобальной константы или функции PROJECT_NAME)

Sub CreateBackup()
    On Error Resume Next: ThisWorkbook.Save
    BackupsPath = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, PROJECT_NAME & " Backups")
    MkDir BackupsPath
    filename = PROJECT_NAME & "_BACKUP_" & Format(Now, "DD-MM-YYYY__HH-NN-SS") & ".xls"
    ThisWorkbook.SaveCopyAs BackupsPath & filename
    'Debug.Print BackupsPath & filename
End Sub

7. Изменяем форматирование цифр в ячейке (выделяем все цифры полужирным шрифтом)

Sub BoldingDigits(ByRef celll As Range)
    For i = 1 To celll.Characters.count
        letter = celll.Characters(start:=i, Length:=1).Text
        celll.Characters(start:=i, Length:=1).Font.Bold = IsNumeric(letter)
    Next
End Sub

8. Поиск артикула (последовательности цифр заданной длины) в текстовой строке
Ссылка на примеры использования Regexp: script-coding.com/WSH/RegExp.html

Function FindDigits(ByVal txt$, ByVal DigitsCount%) As String
    ' ищет в строке txt$ подстроку цифр длиной DigitsCount%
    Set expres = CreateObject("VBScript.RegExp")
    expres.Pattern = Replace(String(DigitsCount%, "%"), "%", "[0-9]")
    If expres.test(txt$) Then FindDigits = expres.Execute(txt$)(0).Value
End Function

Function FindDigits(ByVal txt$, ByVal DigitsCount%) As String
    ' ищет в строке txt$ подстроку цифр длиной DigitsCount%
    Set RegExp = CreateObject("VBScript.RegExp"): RegExp.Global = True
    RegExp.Pattern = "[D]": txt$ = " " & RegExp.Replace(txt$, " ") & " "
    RegExp.Pattern = " [d]{" & DigitsCount% & "} "
    If RegExp.test(txt$) Then FindDigits = RegExp.Execute(txt$)(0).Value
End Function

9. Добавление значений сразу во весь столбец двумерного массива

Sub AddValueIntoColumn(ByRef arr, ByVal ColumnIndex%, ByVal NewValue)
    ' добавляет значение NewValue в столбец ColumnIndex% всех строк
    ' переданного по ссылке двумерного массива arr
    For i = LBound(arr) To UBound(arr)
        arr(i, ColumnIndex%) = NewValue
    Next i
End Sub

10. Использование Application.OnTime с задержкой меньше секунды

Sub ЗапускМакросаСНебольшойЗадержкой() ' по мотивам макроса ZVI_Timer
    ЗадержкаВСекундах = 0.3    ' в секундах
    НазваниеМакроса$ = "test"    ' этот макрос будет запущен через 0.3 сек.
    ЗадержкаВЧасах$ = Replace(Format(CDbl(TimeSerial(0, 0, 1)) * ЗадержкаВСекундах, "0.000000000"), ",", ".")
    macro = "ON.TIME(NOW()+" & ЗадержкаВЧасах$ & ", """ & НазваниеМакроса$ & """)" ' формируем команду запуска
    ExecuteExcel4Macro macro ' macro = ON.TIME(NOW()+0.000003472, "test")
End Sub

11. Преобразование коллекции в массив

Function Collection2Array(ByVal coll As Collection) As Variant
    ReDim arr(0 To coll.Count - 1): Dim i As Long
    For i = 1 To coll.Count: arr(i - 1) = coll(i): Next i
    Collection2Array = arr
End Function

12. Разрешаем Excel доступ в Интернет путем отключения брандмауэра:

' включаем файрвол Windows (доступ в интернет ограничен)
CreateObject("HNetCfg.FwMgr").LocalPolicy.CurrentProfile.FirewallEnabled = True
 
' отключаем файрвол Windows (доступ в интернет открыт)
CreateObject("HNetCfg.FwMgr").LocalPolicy.CurrentProfile.FirewallEnabled = False

Перейти к содержимому

Защита ячеек шифром Виженера

Парольная защита листов в Microsoft Excel давно стала притчей во языцех. В том плане, что ее, по-сути, нет. С регулярностью примерно раз в месяц я получаю вопросы по почте на тему «как мне защитить мои данные на листе Excel от просмотра/изменения?» и каждый раз не знаю что ответить. Можно, конечно, дать ссылочку на статью с подробным описанием всех способов защиты ячеек и листов в Excel, но такая защита остановит только начинающего. В сети можно найти кучу платных и бесплатных программ для взлома такой защиты тупым перебором за считанные минуты.

В какой-то момент мне это надоело и я стал искать способы более надежной защиты данных в Excel собственными силами. Самым простым и удобным оказался шифр Виженера.

Принцип шифра Виженера

Одним из самых древних и простых в реализации является шифр Цезаря, который использовал его для тайной переписки. Суть его в том, что каждая буква исходного шифруемого сообщения сдвигается в алфавите на заданное количество символов. Так, например, если сдвиг равен 3, то буква А превратится в Г, буква Б — в Д и так далее:

Символы в конце алфавита (Э, Ю, Я), соответственно, будут превращаться его начало (А, Б, В).

Реализовать такой шифр просто, но стойкость его невелика — найти нужное число сдвига и дешифровать сообщение можно даже прямым перебором за 20-30 итераций, что займет даже у человека не больше часа, а у современного компьютера доли секунды. Поэтому еще в 15 веке был впервые придуман, а потом в 16 веке французским дипломатом Блезом Виженером официально представлен более совершенный метод на основе шифра Цезаря, получивший впоследствии название «шифр Виженера». Его принцип в том, что каждая буква в исходном шифруемом тексте сдвигается по алфавиту не на фиксированное, а переменное количество символов. Величина сдвига каждой буквы задается ключом (паролем) — секретным словом или фразой, которая используется для шифрования и расшифровки. 

Допустим, мы хотим зашифровать фразу «КЛАД ЗАРЫТ В САДУ» используя слово ЗИМА в качестве ключа. Запишем это слово подряд несколько раз под исходной фразой:

Для удобства шифрования используем так называемый «квадрат Виженера» — таблицу, где в каждой строке алфавит сдвигается на одну позицию вправо:

Если взять строку с первой буквой ключа (З) и столбец с первой буквой исходного текста (К), то на их пересечении увидим букву «Т» — это и будет первая буква нашего зашифрованного сообщения. Затем процедура повторяется для всех остальных пар букв ключа и исходного сообщения по очереди и в результате мы получаем зашифрованный вариант нашей исходной фразы:

Заметьте, что одна и та же буква (например А) в исходном сообщений превратилась в разные буквы на выходе (Н, Й и Б), т.к. сдвиг при шифровании для них был разный. Именно поэтому вскрыть шифр Виженера простыми способами невозможно — вплоть до 19 века он считался невзламываемым и успешно использовался военными, дипломатами и шпионами многих стран, частности — конфедератами во время Гражданской войны в США.

Реализация формулами по квадрату Виженера

Если использовать готовый квадрат Виженера как в примере выше, то реализовать шифрование можно одной формулой с помощью функций ИНДЕКС (INDEX) и ПОИСКПОЗ (MATCH), как это было описано в статье про двумерный поиск в таблице. Выглядеть это может примерно так:

Логика этой формулы следующая:

• Первая функция ПОИСКПОЗ (подсвечена зеленым) ищет первую букву ключа (З) в зеленом столбце (B9:B40) и выдает порядковый номер ячейки, где она ее нашла, т.е. номер строки в квадрате Виженера по которому идет шифрование.
• Вторая функция ПОИСКПОЗ (подсвечена розовым) аналогичным образом ищет первую букву исходного сообщения (К) в красной строке и выдает порядковый номер столбца.
• Функция ИНДЕКС выдает содержимое ячейки из квадрата (C9:AH40) с пересечения строки и столбца с найденными номерами.

Реализация формулами по кодам символов

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

Внутри компьютера и операционной системы каждый символ имеет свой числовой код от 0 до 255 (его еще называют ASCII-кодом). Microsoft Excel имеет в своем стандартном наборе две функции, которые умеют с ними работать:

• Функция КОДСИМВ (CODE) — выдает числовой код символа, указанного в качестве аргумента. Например КОДСИМВ(«Ж») выдаст 198.
• Функция СИМВОЛ (CHAR) — выдает символ, соответствующий указанному в аргументе коду, т.е. наоборот СИМВОЛ(198) даст нам букву Ж. 

Для применения шифра Виженера запишем наш исходный текст и ключ друг под другом как раньше и выведем коды каждой буквы с помощью функции КОДСИМВ:

Теперь сложим коды символов ключа и исходного текста, добавив функцию ОСТАТ (MOD), чтобы при превышении максимально допустимого количества символов (256) остаться в пределах 0-255:

Теперь осталось использовать функцию СИМВОЛ, чтобы вывести символы по полученным кодам и сформировать зашифрованное сообщение:

Само-собой, можно было бы обойтись и без дополнительных строк, уложив все функции в одну формулу для компактности:

Расшифровка производится совершенно аналогично, только знак «плюс» в формуле меняется на «минус»:

Для шпионских игр шифрование такими спецсимволами, конечно, не очень удобно — так и представляю себе глаза радистки Кэт при попытке передать третий и пятый символы нашей шифровки Но нам их, отстреливаясь из именного ТТ во время погони, на бумажке не писать, так что для наших целей — сойдет.

Макросы для шифрования-дешифрования

Ну, а теперь самое интересное. Чтобы применить шифр Виженера в реальной жизни лучше будет воспользоваться простым макросом, который проводит все описанные в предыдущем пункте операции с каждой ячейкой текущего листа автоматически. Откройте редактор Visual Basic с помощью сочетания клавиш Alt+F11 или кнопкой Visual Basic на вкладке Разработчик (Developer). Вставьте новый модуль с помощью команды меню Insert — Module и скопируйте туда текст наших макросов:

 
'Шифрование текущего листа
Sub Encrypt()
    Dim Pass$, Key$
    Pass = InputBox("Введите ключ для шифрования:")
    Key = WorksheetFunction.Rept(Pass, 100)
    
    For Each cell In ActiveSheet.UsedRange
        Out = ""
        Txt = cell.Formula
        For i = 1 To Len(Txt)
            Out = Out & Chr((Asc(Mid(Txt, i, 1)) + Asc(Mid(Key, i, 1))) Mod 256)
        Next i
        cell.Value = Out
    Next cell
End Sub

'Дешифрация текущего листа
Sub Decrypt()
    Dim Pass$, Key$
    Pass = InputBox("Введите ключ для расшифровки:")
    Key = WorksheetFunction.Rept(Pass, 100)
    
    For Each cell In ActiveSheet.UsedRange
        Out = ""
        Txt = cell.Value
        For i = 1 To Len(Txt)
            Out = Out & Chr((Asc(Mid(Txt, i, 1)) - Asc(Mid(Key, i, 1)) + 256) Mod 256)
        Next i
        cell.Formula = Out
    Next cell
End Sub
 

Первый макрос запрашивает у пользователя ключ и шифрует все ячейки текущего листа. Второй макрос производит обратную операцию дешифрования. Запустить получившиеся макросы можно с помощью сочетания клавиш Alt+F8 или кнопки Макросы (Macros) на вкладке Разработчик (Developer). Выглядеть все это может примерно так:

Важные нюансы

• ВНИМАНИЕ! Если вы внимательно прочитали статью, то должны четко понимать — не существует легкого способа узнать или подобрать ключ! Есть несколько методик взлома шифра Виженера, но все они весьма сложны для неспециалиста и не дают 100% гарантии. Если вы забудете ключ — потеряете данные навсегда с большой вероятностью. Если что — я вас предупредил.
• При шифровании не нарушаются формулы, ссылки и форматирование — после дешифрации все отлично работает.
• Если при дешифрации вы неправильно введете ключ, то получите бессмысленную «кашу» из спецсимволов вместо своего текста (т.к. сдвиг кодов будет неправильным). Тогда придется откатиться на шаг назад повторным шифрованием с тем же паролем и потом снова попробовать расшифровать документ еще раз (на этот раз используя правильный ключ).

Ссылки по теме

• 4 способа защиты данных в Microsoft Excel
• Суперскрытый лист в книге Excel
• Выборочное отображение листов книги пользователям по паролю