Kodowanie danych - base64   strona główna:
A po co ten Excel ;-)
 
Może się komuś przyda. :-)  
Do napisanie tego kodu wykorzystywałem opis algorytmu kodowania z linku z prawej.   Opis kodowania Base64
"Kodowanie polega na przedstawieniu kodowanego ciągu w postaci binarnej, pogrupowaniu bitów w grupy 6-bitowe i przedstawieniu każdej grupy za pomocą jednego z 64 specjalnie przyporządkowanych znaków (…)"  
 
 
 
A wygląda to tak:
 
 
 
 
 
 
Jak coś takiego napisać?  
 
Option Explicit  
Private Const strChr As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"  
 
'---------------Koder-------------------------  
Function Base64_Koder(sText As String) As String  
    Dim i  
    Dim s8Bit As String, ii  
    Dim sWynik As String  
      
    For i = 1 To Len(sText)  
        s8Bit = s8Bit & Dec2Bin(Asc(Mid(sText, i, 1)), 8)  
    Next  
    If (Len(s8Bit) Mod 6) > 0 Then s8Bit = s8Bit & String(6 - (Len(s8Bit) Mod 6), "0")  
      
    For ii = 1 To Len(s8Bit) Step 6  
        sWynik = sWynik & Bit6NaZnak(Mid(s8Bit, ii, 6))  
    Next  
    If (Len(sWynik) Mod 4) > 0 Then sWynik = sWynik & String(4 - (Len(sWynik) Mod 4), "=")  
      
    Dim iW  
    For iW = 1 To Len(sWynik) Step 76  
        Base64_Koder = Base64_Koder & Mid(sWynik, iW, 76)  
        If i + 76 < Len(sWynik) Then Base64_Koder = Base64_Koder & vbNewLine  
    Next  
End Function  
 
Function Bit6NaZnak(strBit6 As String) As String  
    Bit6NaZnak = Mid(strChr, Bin2Dec(strBit6) + 1, 1)  
End Function  
 
Fragmentami, analizując opis algorytmu.  
 
"1. Każdy znak ciągu do zakodowania przedstawiamy w postaci binarnej"  
    For i = 1 To Len(sText)  
        s8Bit = s8Bit & Dec2Bin(Asc(Mid(sText, i, 1)), 8)  
    Next  
 
Mid(sText, i, 1) - każdy znak  
Asc(Mid(sText, i, 1)) - pozycja każdego znaku w zbiorze ASCII  
Dec2Bin(Asc(Mid(sText, i, 1)), 8) - zapis binarny pozycji każdego znaku w zbiorze ASCII (8 znaków)  
 
"2. Grupujemy zapis binarny w grupy po sześć bitów, zaczynając od lewej strony"  
"4. W tabeli kodów znajdujemy odpowiedniki kolejnych grup sześciobitowych i zapisujemy je"  
 
    For ii = 1 To Len(s8Bit) Step 6  
        sWynik = sWynik & Bit6NaZnak(Mid(s8Bit, ii, 6))  
    Next  
 
Mid(s8Bit, ii, 6) - sześcio-znakowy fragment ciągu  
Bit6NaZnak(Mid(s8Bit, ii, 6)) - ww. fragment zamieniamy na odpowiedni znak z ciągu strChr.  
Bit6NaZnak = Mid(strChr, Bin2Dec(strBit6) + 1, 1)  
 
"3. W przypadku, gdy ostatnia grupa zawiera mniej niż sześć bitów, dopisujemy na końcu taką liczbę zer, by grupa zawierała sześć bitów"  
 
 
    s8Bit = s8Bit & String(6 - (Len(s8Bit) Mod 6), "0")  
 
"5. Jeżeli w otrzymanym ciągu ilość znaków nie jest wielokrotnością czterech, należy uzupełnić go do wielokrotności znakami równości"  
 
 
    sWynik = sWynik & String(4 - (Len(sWynik) Mod 4), "=")  
 
ostatni fragment funkcji dodaje "enter" po każdym 76znaku. - to już moje.  
 
Dekoder działa odwrotnie.  
 
'-----------------Dekoder-----------------------------  
Function Base64_DeKoder(sText As String) As String  
    Dim i, bit6 As String  
    Dim ii, sWynik As String  
 
    sText = Replace(sText, "=", "")  
    For i = 1 To Len(sText)  
        bit6 = bit6 & ZnakNaBit6(Mid(sText, i, 1))  
    Next  
    'Stop  
    For ii = 1 To (Len(bit6) - (8 - (Len(bit6) Mod 8))) Step 8  
        Base64_DeKoder = Base64_DeKoder & Chr(Bin2Dec(Mid(bit6, ii, 8)))  
    Next  
          
End Function  
 
Function ZnakNaBit6(sZnak As String) As String  
    Select Case Asc(sZnak)  
        Case 9, 10, 13: ZnakNaBit6 = ""  
        Case Else  
            If InStr(strChr, sZnak) > 0 Then  
                ZnakNaBit6 = Dec2Bin(InStr(strChr, sZnak) - 1, 6)  
            End If  
    End Select  
End Function  
 
'------------wspólne-------------------------------  
 
Function Bin2Dec(sMyBin As String) As Long   Funkcja Bin2Dec pochodzi z:
    Dim x   Using BIN2DEC In a Macro
    Dim iLen  
      
    iLen = Len(sMyBin) - 1  
    For x = 0 To iLen  
        Bin2Dec = Bin2Dec + Mid(sMyBin, iLen - x + 1, 1) * 2 ^ x  
    Next  
End Function  
 
Function Dec2Bin(ByVal DecVal As Integer, bLen As Byte) As String   Funkcja Dec2Bin własna - na
    Dim sBin As String   podstawie algorytmów z sieci.
    Dim intLiczba: intLiczba = DecVal   Jedynie ostatnia linijka moja - 
  ciągi  muszą mieć określoną
    Do   długość  (w przykładzie 8 znaków)
        sBin = intLiczba Mod 2 & sBin  
        intLiczba = (intLiczba - (intLiczba Mod 2)) / 2  
    Loop While intLiczba > 0  
    Dec2Bin = String(bLen - Len(sBin), "0") & sBin  
End Function  
 
'----------------------------------------------------------------------  
 
Wymienione funkcje mogą działać jako Funkcje Arkuszowe. (obrazki pod tytułem artykułu)  
 
Można jednak wykorzystywać te funkcje do kodowania/rozkodowania wszelkich danych - choćby nawet całych plików :-)  
Trzeba jedynie odczytać dany plik Binarnie i następnie zakodować otrzymane dane tworząc nowy plik. Np.:  
 
'----------------------Kodowanie Plików--------------------------------  
Sub kodowanie(strFile As String)  
    Dim nr As Integer: nr = VBA.FreeFile  
    Dim strBinFile As String  
      
    Open strFile For Binary Access Read As nr  
        strBinFile = String(LOF(nr), " ")  
        Get nr, , strBinFile  
    Close nr  
      
    Dim strFile_C64 As String: strFile_C64 = Right(strFile, Len(strFile) - InStrRev(strFile, "\"))  
    Dim strPath As String: strPath = Left(strFile, InStrRev(strFile, "\"))  
    nr = VBA.FreeFile  
    Open strPath & Base64_Koder(strFile_C64) For Binary Access Write As #nr  
        Put #nr, , Base64_Koder(strBinFile)  
    Close nr  
End Sub  
 
Sub rozkodowanie(strFileCoded As String)  
    Dim nr As Integer: nr = VBA.FreeFile  
    Dim strBinFile As String  
      
    Open strFileCoded For Binary Access Read As nr  
        strBinFile = String(LOF(nr), " ")  
        Get nr, , strBinFile  
    Close nr  
      
    Dim strFile_C64 As String: strFile_C64 = Right(strFileCoded, Len(strFileCoded) - InStrRev(strFileCoded, "\"))  
    Dim strPath As String: strPath = Left(strFileCoded, InStrRev(strFileCoded, "\"))  
      
    nr = VBA.FreeFile  
    Open strPath & Base64_DeKoder(strFile_C64) For Binary Access Write As #nr  
        Put #nr, , Base64_DeKoder(strBinFile)  
    Close nr  
End Sub  
 
'----------------------------------------------------------------------  
 
Sub kodowanie(strFile As String) - strFile to ściezka do pliku jaki chcemy zakodować.  
 
    Open strFile For Binary Access Read As nr  
        strBinFile = String(LOF(nr), " ")  
        Get nr, , strBinFile  
    Close nr  
 
Binarny odczyt pliku strFile do zmiennej strBinFile  
 
    Dim strFile_C64 As String: strFile_C64 = Right(strFile, Len(strFile) - InStrRev(strFile, "\"))  
    Dim strPath As String: strPath = Left(strFile, InStrRev(strFile, "\"))  
 
Ze ścieżki do kodowanego pliku wyciągam nazwę pliku i ścieżkę do oddzielnych zmiennych.  
 
    Open strPath & Base64_DeKoder(strFile_C64) For Binary Access Write As #nr  
        Put #nr, , Base64_DeKoder(strBinFile)  
    Close nr  
 
Tworzę plik o zakodowanej nazwie umieszczając w nim zakodowaną treść.  
 
Rozkodowanie działa odwrotnie.  
 
Dla przykładu: zakoduję i rozkoduję plik QR.xlsm  
 
Sub TTT()  
    kodowanie "C:\Users\tkuchta\Desktop\QR.xlsm"  
End Sub  
Sub DeTTT()  
    rozkodowanie "C:\Users\tkuchta\Desktop\UVIueGxzbQ=="  
End Sub  
 
Po zakodowaniu pliku. Dodaję do nazwy oryginału _ żeby   
rozkodowywanie nie nadpisało pierwotnego pliku.  
 
W efekcie otrzymuję:  
 - plik UVIueGxzbQ== a po jego rozkodowaniu  
 - plik QR.xlsm identycznej wielkości co poprzednik.  
Plik działa. Excel nie zgłasza informacji o uszkodzeniu pliku.  
Wszystko wygląda dobrze. :-)  
 
 
 
A plik: UVIueGxzbQ== ??  
Otwarty w notatniku wygląda tak (fragment):  
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
Stwierdzicie.. No fajne ale dekodery base64 są w sieci.. Za free.. Co za problem rozkodować dane? Racja :-) ale przecież sami  
napisaliśmy koder - gdzie podany jest ciąg znaków kodujących.  
 
Private Const strChr As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"  
 
a gdyby tak zamienić ich kolejność... :D  
-------------------------------------Miłej Zabawy-----------------------------------  
 
Jeszcze dwa słowa o czasie wykonania procedur kodowania/rozkodowanie..  
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
Kolumny 1 i 2: Wielkość pliku (KB, B)  
Kolumna 3: czas kodowania w sekundach  
Kolumna 4: czas rozkodowania w sekundach  
Kolumny 6 i 7 i wykres: średni czas kodowania i rozkodowania 1000B przy danej wielkości plików.  
Ostatnie dwie kolumny wskazujące czas potrzebny na kodowanie/dekodowanie danego pliku jest tym dłuższy im większy plik.  
Jednak czas ten nie rośnie liniowo. :|