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
