Security Algorithim

[HorseGoose]

Below are two procedures which work together to create a security key which locks a VBA Office based program to a users PC once it is run.

If you want to ensure that VBA Office based software once installed on one PC cannot work on another PC then this will help.

I just posted it as a thank you for getting help on the previous post.

Sub securityalgoritim()
Dim varuser As String, varcomp As String, varchar As Integer, varpos As Integer, factor As Single, checkval As String
varuser = Environ("UserName")
varcomp = Environ("ComputerName")
varchar = 15 ' helps move through the username one character at a time
varpos = 1 ' position in array
secure(0) = CSng(Now()) / (22 / 7)
Do While varchar <> 0
checkval = Right(varcomp, varchar)
checkval = Left(checkval, 1)
Select Case IsNumeric(checkval)
Case True
secure(varpos) = checkval
secure(varpos) = secure(varpos) ^ Sqr(secure(0))
Case False
secure(varpos) = Asc(checkval)
secure(varpos) = secure(0) ^ Sqr(secure(varpos))
End Select
varpos = varpos + 1
varchar = varchar - 1
Range("$A$16") = secure(0)
Loop
varchar = 15
Do While varchar <> 0
checkval = Right(varuser, varchar)
checkval = Left(checkval, 1)
Select Case IsNumeric(checkval)
Case True
secure(varpos) = checkval
secure(varpos) = secure(varpos) ^ Sqr(secure(0))
Case False
secure(varpos) = Asc(checkval)
secure(varpos) = secure(0) ^ Sqr(secure(varpos))
End Select
varpos = varpos + 1
varchar = varchar - 1
Range("$B$16") = secure(0)
Loop
Call savesecurekey
End Sub

Sub savesecurekey()
Dim fs, f, ts, s, varpos As Integer
Do
filesavename = Application.GetSaveAsFilename(FileFilter:="SLDS User Key (*.SLD), *.SLD")
If filesavename = 0 Then Exit Sub
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FileExists(filesavename) = True Then x = MsgBox("FILE " & filesavename & Chr(10) & Chr(10) & "ALREADY EXISTS, SAVE OVER IT ?", vbYesNo + vbExclamation, "SLDS Question")
If x = vbYes Then Kill filesavename
If x = vbYes Then Exit Do
If fs.FileExists(filesavename) = False Then Exit Do
Loop
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CreateTextFile filesavename 'Create a file
Set f = fs.GetFile(filesavename)
Set ts = f.OpenAsTextStream(2, 0)
ts.write "********************************************************************"
ts.writeblanklines (1)
ts.write "* *"
ts.writeblanklines (1)
ts.write "* THIS FILE IS THE PROPERTY OF THE COMPANY NAME *"
ts.writeblanklines (1)
ts.write "* This file is classified HIGHLY CONFIDENTIAL *"
ts.writeblanklines (1)
ts.write "* Any attempt to interfer with this file is a criminal offence *"
ts.writeblanklines (1)
ts.write "* *"
ts.writeblanklines (1)
ts.write "*******************************************************************"
ts.writeblanklines (1)
ts.write "Copyright The Company Name - 2006"
ts.writeblanklines (1)
ts.writeblanklines (1)
ts.writeblanklines (1)
Do While varpos < 26
ts.write secure(varpos)
ts.writeblanklines (1)
varpos = varpos + 1
Loop
ts.Close
End Sub