Attribute VB_Name = "Base64"
Option Explicit
' ---------------------------------------------------------------
' 2003 ymaingoy@free.fr.
' http://www.noepatents.org
' ---------------------------------------------------------------
' This is an european code, free code for 10,000 years and up.
' You are free to use this code within your own applications,
' but you are expressly forbidden from getting a patent with it.
' ---------------------------------------------------------------

'====================================================================
'
'About the Eurolinux Alliance -- www.eurolinux.org
'
'The EuroLinux Alliance for a Free Information Infrastructure is an open
'coalition of commercial companies and non-profit associations united to
'promote and protect a vigourous European Software Culture based on
'copyright, open standards, open competition and open source software such as
'Linux. Corporate members or sponsors of EuroLinux develop or sell software
'under free, semi-free and non-free licenses for operating systems such as
'GNU/Linux, MacOS or MS Windows.
'
'
'About the FFII -- www.ffii.org
'
'The Foundation for a Free Information Infrastructure (FFII) is a non-profit
'association registered in Munich, which is dedicated to the spread of data
'processing literacy. FFII supports the development of public information
'goods based on copyright, free competition, open standards. More than 250
'members, 300 companies and 15,000 supporters have entrusted the FFII to act
'as their voice in public policy questions in the area of exclusivity rights
'(intellectual property) in the field of software.
'
'
'About the LUG of Strasbourg -- strasbourg.linuxfr.org
'
'The LUG of Strasbourg is a group of Linux and Open Source Software users in
'Strasbourg. This group works for popular education through Open Source
'Software adoption by every one by organizing conferences, information
'stands, presentations and install-parties opened to the public.
'
'====================================================================

'====================================================================
'
'À propos de l'Alliance Eurolinux -- www.eurolinux.org
'
'L 'Alliance EuroLinux pour une Infrastructure Informationnelle Libre est une
'coalition ouverte de sociétés commerciales et d'associations sans buts
'lucratifs unies pour promouvoir et protéger une culture logicielle
'européenne forte, basée sur les standards ouverts, la concurrence, Linux et
'les Logiciels Libres. Les sociétés membres ou associées à EuroLinux
'développent ou commercialisent des logiciels pour des systèmes
'd 'exploitation tels que Windows, MacOS ou Linux.
'
'À propos de FFII -- www.ffii.org
'
'La Fondation pour une Infastructure d'Information Libre est une association
'allemande à but non lucratif qui promeut les interfaces ouvertes, la
'concurrence, les logiciels libres et le libre accès à l'information
'publique. Plus de 250 membres, 300 entreprises et 15.000 supporters ont fait
'confiance à la FFII pour parler publiquement en leur nom des questions
'relatives aux droits d'exclusivité (propriété intellectuelle) liées au
'logiciels.
'
'À propos du LUG de Strasbourg -- strasbourg.linuxfr.org
'
'Le LUG de Strasbourg est un groupe d'utilisateurs de Linux et de Logiciel
'Libre actif sur la ville de Strasbourg et ses environs. Ce groupe fait
'oeuvre d 'éducation populaire en banalisant l'usage des Logiciels Libres et
'en organisant occasionnellement des conférences, des stands d'information,
'des journées de présentation ou des "install-party" ouvertes à tout public.
'
'====================================================================


Private Const EOL_SIZE      As Long = 2                ' Size of vbCrLf
Private Const LINE_SIZE     As Long = 40 + EOL_SIZE    ' Size of a line

' Base64 official const
Private Const Base64        As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Private Const Base64_EOF    As String = "="

' ---------------------------------------------------------------
' Encode a string to a Base-64 string
' ymaingoy@free.fr
' ---------------------------------------------------------------
Public Function Encode64(ByRef lpConvString As String) As String
    
    
    Dim pt          As Long
    Dim ptMax       As Long
    Dim dwBuffer    As Long
    Dim cbSize      As Long
    Dim cbBits      As Byte
    Dim cbLines     As Long
    Dim aByte       As Byte
    Dim lpBuffer    As String
    
    
    dwBuffer = 0
    cbBits = 0
    cbSize = EOL_SIZE                       ' Tips for the NewLine
    cbLines = 1
    pt = 1
    ptMax = Len(lpConvString)
    lpBuffer = String$(LINE_SIZE + ptMax * 2, 0)
    
    Do Until pt > ptMax
        
        ' Add 8 bits to the buffer
        dwBuffer = dwBuffer * 256 + Asc(Mid$(lpConvString, pt, 1))
        cbBits = cbBits + 8
        
        Do
            
            Select Case cbBits
            Case 6
                aByte = dwBuffer
                dwBuffer = 0
                cbBits = 0
            Case 8
                aByte = dwBuffer \ 4
                dwBuffer = dwBuffer And 3
                cbBits = 2
            Case 10
                aByte = dwBuffer \ 16
                dwBuffer = dwBuffer And 15
                cbBits = 4
            Case 12
                aByte = dwBuffer \ 64
                dwBuffer = dwBuffer And &H3F
                cbBits = 6
                
            Case 2 ' Only when pt = ptmax
                aByte = dwBuffer * 16
                dwBuffer = 0
                cbBits = 0
            Case 4 ' Only when pt = ptmax
                aByte = dwBuffer * 4
                dwBuffer = 0
                cbBits = 0
            
            End Select
        
            ' Add a character to the buffer
            cbSize = cbSize + 1
            Mid$(lpBuffer, cbSize, 1) = Mid$(Base64, 1 + aByte, 1)
            
            ' Add the NewLine to the buffer
            If (cbSize Mod LINE_SIZE) = 0 Then
                Mid$(lpBuffer, cbSize + 1, EOL_SIZE) = vbCrLf
                cbSize = cbSize + EOL_SIZE
                cbLines = cbLines + 1
            End If
        
        ' Loop while not done with this byte
        Loop While (cbBits = 6) Or ((pt = ptMax) And (cbBits > 0))
        
        pt = pt + 1
    
    Loop
    
    ' Add one or two bytes Base64_EOF
    Select Case (cbSize - EOL_SIZE * cbLines) Mod 3
      Case 1: '8 bit final
        Mid$(lpBuffer, cbSize + 1, 2) = Base64_EOF & Base64_EOF
        cbSize = cbSize + 2
      Case 2: '16 bit final
        Mid$(lpBuffer, cbSize + 1, 1) = Base64_EOF
        cbSize = cbSize + 1
    End Select
    
    ' Return the string and ignore the two first bytes
    Encode64 = Mid$(lpBuffer, 1 + EOL_SIZE, cbSize - EOL_SIZE)

End Function

' ---------------------------------------------------------------
' A simple hash function
' Return a chksum of 8 bytes long
' ymaingoy@free.fr
' ---------------------------------------------------------------
Public Function hash_string(ByRef s As String) As String
    
    Dim h As Long
    Dim i As Long
    
    h = 0
    For i = 1 To Len(s)
        h = ((h And &HFF000000) \ &H1000000) + _
            (((h And &HFFFFFF) * 8) + Asc(Mid$(s, i, 1)))
    Next
    
    hash_string = Right$("00000000" & Hex$(h), 8)

End Function





