VB6 - Save settings into a file compressed and encrypted

[CVMichael]

If you want to save the application settings (or any other data) encrypted and/or compressed, this is how you do it:

Option Explicit
 
Private Declare Function Compress Lib "zlib.dll" Alias "compress" (dest As Any, destLen As Any, src As Any, ByVal srcLen As Long) As Long
Private Declare Function Uncompress Lib "zlib.dll" Alias "uncompress" (dest As Any, destLen As Any, src As Any, ByVal srcLen As Long) As Long
 
Private Function LoadSettings(Optional EncPassword As String = "") As PropertyBag
    '
    '  Made by Michael Ciurescu (CVMichael from vbforums.com)
    '  Original thread: [url]http://www.vbforums.com/showthread.php?t=434490[/url]
    '
 
    Dim PB As PropertyBag, FLNum As Integer
    Dim Data() As Byte, DataLength As Long
    Dim EncCompSettings As Byte, OriginalSize As Long
    Dim RndNum As Double
    
    Const Encrypted As Byte = 1
    Const Compressed As Byte = 2
    
    ' On error just return an empty property bag
    On Error GoTo ReturnEmpty
    
    Set PB = New PropertyBag
    
    FLNum = FreeFile
    Open App.Path & "\Settings.dat" For Binary Access Read As FLNum
        Get FLNum, , DataLength ' Get data length (size of buffer)
        
        If DataLength > 0 Then
            ' Get whether it was compressed and/or encrypted
            Get FLNum, , EncCompSettings
            
            ' if encrypted, read the random number
            If (EncCompSettings And Encrypted) = Encrypted Then Get FLNum, , RndNum
            
            ReDim Data(DataLength)
            Get FLNum, , Data ' read the data with the settings
            
            ' If data was encrypted, then decrypt it
            If (EncCompSettings And Encrypted) = Encrypted Then
                Data = StrConv(RndCrypt(StrConv(Data, vbUnicode), EncPassword & RndNum), vbFromUnicode)
            End If
            
            ' If data was compressed, then decompress it
            If (EncCompSettings And Compressed) = Compressed Then
                Get FLNum, , OriginalSize
                
                Dim OData() As Byte ' temporary buffer for decompression
                ReDim OData(OriginalSize)
                Uncompress OData(0), OriginalSize, Data(0), UBound(Data) + 1 ' decompress data
                
                Data = OData
                Erase OData
            End If
            
            ' Put the data in the property bag
            PB.Contents = Data
        End If
    Close FLNum
    
ReturnEmpty:
    Set LoadSettings = PB ' return the property bag
End Function
 
Private Function SaveSettings(SavePB As PropertyBag, Optional CompressData As Boolean = False, Optional EncPassword As String) As Boolean
    '
    '  Made by Michael Ciurescu (CVMichael from vbforums.com)
    '  Original thread: [url]http://www.vbforums.com/showthread.php?t=434490[/url]
    '
 
    Dim Data() As Byte, DataLength As Long
    Dim FLNum As Integer, RndNum As Double
    Dim EncCompSettings As Byte, OriginalSize As Long
    
    Const Encrypted As Byte = 1
    Const Compressed As Byte = 2
    
    ' On error exit and return False
    On Error GoTo Err_Exit
    
    Data = SavePB.Contents ' get the contents of the property bag
    
    OriginalSize = UBound(Data) + 1 ' get size of buffer (un-altered/original)
    
    If CompressData Then
        EncCompSettings = Compressed ' save the setting that we compressed the data
        
        Dim CData() As Byte ' temporary buffer to compress data
        DataLength = (UBound(Data) + 1) * 1.01 + 12
        ReDim CData(DataLength - 1)
        
        Compress CData(0), DataLength, Data(0), UBound(Data) + 1 ' compress the data
        
        ReDim Preserve CData(DataLength - 1) ' resize buffer to the compressed length
        Erase Data
        Data = CData ' assign compressed data to main buffer
    End If
    
    If Len(EncPassword) > 0 Then
        EncCompSettings = EncCompSettings Or Encrypted ' save the setting that we encrypted the data
        
        Randomize
        ' get a random number
        RndNum = 2 ^ 15 * Rnd + 2 ^ 20 * Rnd + 2 ^ 25 * Rnd + 2 ^ 30 * Rnd
        
        ' encrypt the data using our password and the random number
        Data = StrConv(RndCrypt(StrConv(Data, vbUnicode), EncPassword & RndNum), vbFromUnicode)
    End If
    
    ' delete the file if it already exists
    ' (in case the size of the current file is less than before)
    If Len(Dir(App.Path & "\Settings.dat")) > 0 Then
        On Error Resume Next
        SetAttr App.Path & "\Settings.dat", vbNormal
        Kill App.Path & "\Settings.dat"
        On Error GoTo 0
    End If
    
    ' Create file, and save all the settings
    FLNum = FreeFile
    Open App.Path & "\Settings.dat" For Binary Access Write As FLNum
        DataLength = UBound(Data)
        
        Put FLNum, , DataLength
        Put FLNum, , EncCompSettings
        
        If (EncCompSettings And Encrypted) = Encrypted Then Put FLNum, , RndNum
        
        Put FLNum, , Data
        
        If (EncCompSettings And Compressed) = Compressed Then Put FLNum, , OriginalSize
    Close FLNum
    
    SaveSettings = True
    Exit Sub
    
Err_Exit:
    SaveSettings = False
End Function
 
Public Function RndCrypt(ByVal Str As String, ByVal Password As String) As String
    '
    '  Made by Michael Ciurescu (CVMichael from vbforums.com)
    '  Original thread: [url]http://www.vbforums.com/showthread.php?t=231798[/url]
    '
    Dim SK As Long, K As Long
    
    ' init randomizer for password
    Rnd -1
    Randomize Len(Password)
    ' (((K Mod 256) Xor Asc(Mid$(Password, K, 1))) Xor Fix(256 * Rnd)) -> makes sure that a
    ' password like "pass12" does NOT give the same result as the password "sspa12" or "12pass"
    ' or "1pass2" etc. (or any combination of the same letters)
    
    For K = 1 To Len(Password)
        SK = SK + (((K Mod 256) Xor Asc(Mid$(Password, K, 1))) Xor Fix(256 * Rnd))
    Next K
    
    ' init randomizer for encryption/decryption
    Rnd -1
    Randomize SK
    
    ' encrypt/decrypt every character using the randomizer
    For K = 1 To Len(Str)
        Mid$(Str, K, 1) = Chr(Fix(256 * Rnd) Xor Asc(Mid$(Str, K, 1)))
    Next K
    
    RndCrypt = Str
End Function

How to use the functions (save and load settings/data):

Private Sub Form_Load()
    Dim LoadPB As PropertyBag
    
    ' load the settings
    ' Use any password you want, as long as it's the same when you save data
    Set LoadPB = LoadSettings("password=-0987654321") 
    
    ' read the values from the property bag
    Me.Top = LoadPB.ReadProperty("Top", Me.Top)
    Me.Left = LoadPB.ReadProperty("Left", Me.Left)
    Me.Width = LoadPB.ReadProperty("Width", Me.Width)
    Me.Height = LoadPB.ReadProperty("Height", Me.Height)
End Sub
 
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Dim SavePB As New PropertyBag
    
    ' assign the values you need to save in the property bag
    SavePB.WriteProperty "Top", Me.Top
    SavePB.WriteProperty "Left", Me.Left
    SavePB.WriteProperty "Width", Me.Width
    SavePB.WriteProperty "Height", Me.Height
    
    ' save the settings
    ' Password must be the same as when you load the data
    SaveSettings SavePB, True, "password=-0987654321"
End Sub

As you may already noticed, this code uses ZLib.DLL to compress data, this is the website for ZLIB:
http://www.zlib.net/
And to get the actual DLL, this is the direct link to the ZIP where the DLL is: ZLib.dll
Upzip the file, and copy and paste the DLL to your windows/system32 directory.