Jak šifrovat obsah listu

Předpokládejme, že tentýž sešit sdílí několik uživatelů, každý s jinými pravomocemi a funkcí. Údaje na jednom listu přitom chceme zobrazovat jen určeným osobám. Tohle za nás bezpečně nevyřeší zámek listu ani snadno zobrazitelné (super)skryté listy. Nabízí se ovšem jedna převážně matematická disciplína – šifrování.

Jestliže matkou algoritmů je funkce MOD, pak pro šifrování je jí funkce XOR, známá z oblasti booleovské algebry a logiky. Pokud ji zkombinujeme s možností šifrovacího klíče (zjednodušeně hesla), dostaneme účinnou zbraň (ale také sobě nebezpečnou v případě zapomenutí klíče). Tím, že zveřejním kód pro šifrování v jinak děravém VBA, se také příliš nezmění. Bez znalosti klíče je rozluštění „ve hvězdách“.

Odkryté hodnoty a vzorce na listu

Odkryté hodnoty a vzorce na listu

Zašifrované hodnoty a vzorce na listu

Zašifrované hodnoty a vzorce na listu

Pozn. Nejsem si jistý, proč se při šifrování mění barva v grafu, nicméně podoba grafu závislého na tabulce se samozřejmě změní také. Texty bez provázanosti na hodnoty v buňkách zohledněny nejsou.

Důrazně upozorňuji, že aplikování níže uvedeného kódu provádíte „na vlastní triko“. Teoreticky je limitní množství znaků v buňce, nicméně běžný sešit by neměl v buňkách obsahovat více jak 255 znaků (novodobé verze Excelu mají tento limit už řádově jinde). Procedury byly vyzkoušeny na formátovaných hodnotách (číslo, datum, text) i na vzorcích. O případných chybách mě informujte.

'http://www.freevbcode.com/ShowCode.asp?ID=5676

'autor níže uvedeného kódu nenese žádnou odpovědnost
'za škody způsobené jeho užíváním
'doporučena je nešifrovaná záloha sešitu

Private Sub Sifrovani()

    Dim strKlic As String
    Dim rngOblast As Range
    Dim rngBunka As Range

    'strKlic = InputBox("Zadejte heslo:", "Šifrování listu")

    strKlic = "Ježibaba"

    'zákaz překreslování
    Application.ScreenUpdating = False

    'zákaz přepočítávání listu
    Application.Calculation = xlCalculationManual

    'z využité oblasti listu
    With ActiveSheet.UsedRange

        'převzetí neprázdných buněk (konstanty, vzorce)
        Set rngOblast = Union(.SpecialCells(xlCellTypeConstants), _
            .SpecialCells(xlCellTypeFormulas))

    End With

    'pro každou buňku
    For Each rngBunka In rngOblast

        'zašifrování obsahu
        rngBunka.Value = XOREncryption(strKlic, rngBunka.FormulaLocal)

    Next rngBunka

    'povolení přepočítávání listu
    Application.Calculation = xlCalculationAutomatic

    'povolení překreslování
    Application.ScreenUpdating = True

End Sub

Private Sub Desifrovani()

    Dim strKlic As String
    Dim rngOblast As Range
    Dim rngBunka As Range
   
   'strKlic = InputBox("Zadejte heslo:", "Dešifrování listu")
   
    strKlic = "Ježibaba"
   
    'zákaz překreslování
    Application.ScreenUpdating = False
   
    'zákaz přepočítávání listu
    Application.Calculation = xlCalculationManual
   
    'z využité oblasti listu
    With ActiveSheet.UsedRange

        'převzetí neprázdných buněk (konstanty)
        Set rngOblast = .SpecialCells(xlCellTypeConstants)

    End With

    'pro každou buňku
    For Each rngBunka In rngOblast

        'dešifrování obsahu
        rngBunka.FormulaLocal = XORDecryption(strKlic, rngBunka.Value)

    Next rngBunka
   
    'povolení přepočítávání listu
    Application.Calculation = xlCalculationAutomatic
   
    'povolení překreslování
    Application.ScreenUpdating = True
   
End Sub


Public Function XOREncryption(CodeKey As String, DataIn As String) As String

    Dim lonDataPtr As Long
    Dim strDataOut As String
    Dim temp As Integer
    Dim tempstring As String
    Dim intXOrValue1 As Integer
    Dim intXOrValue2 As Integer


    For lonDataPtr = 1 To Len(DataIn)
        intXOrValue1 = Asc(Mid$(DataIn, lonDataPtr, 1))
        intXOrValue2 = Asc(Mid$(CodeKey, ((lonDataPtr Mod Len(CodeKey)) + 1), 1))
        temp = (intXOrValue1 Xor intXOrValue2)
        tempstring = Hex(temp)
        If Len(tempstring) = 1 Then tempstring = "0" & tempstring
        strDataOut = strDataOut + tempstring
    Next lonDataPtr
   
    XOREncryption = strDataOut
   
End Function


Public Function XORDecryption(CodeKey As String, DataIn As String) As String

    Dim lonDataPtr As Long
    Dim strDataOut As String
    Dim intXOrValue1 As Integer
    Dim intXOrValue2 As Integer

    For lonDataPtr = 1 To (Len(DataIn) / 2)
        intXOrValue1 = Val("&H" & (Mid$(DataIn, (2 * lonDataPtr) - 1, 2)))
        intXOrValue2 = Asc(Mid$(CodeKey, ((lonDataPtr Mod Len(CodeKey)) + 1), _
            1))
        strDataOut = strDataOut + Chr(intXOrValue1 Xor intXOrValue2)
    Next lonDataPtr
   
    XORDecryption = strDataOut
   
End Function

V procedurách je klíč obsažen natvrdo a nad jím jen lehce v komentáři naznačen způsob, jak kód zadávat (InputBox). V praxi si heslo před šifrováním ověřujte (dvojí užití InputBoxu a kontrola), ať se vyvarujete chyby překlepu. Z pohledu fungování i bezpečnosti neexistuje žádná kontrola před pokusem o dešifrování špatným klíčem…

Hádanka s trochou nadsázky: Víte, kdo má dnes nejlepší přehled o šifrách a hodně z nich si osvojí? (Geokačeři, tj. hráči geocachingu, kteří luští mystery cache.)

Příloha:
sifrovani_listu_xor.zip

Klikni a stahuj!