Code for Basic Encryption part 1/2 1

[HorseGoose]

I have been making a basic encryption module for some software I have been writing. Nothing too complicated. It comes in two parts. Part one below you place in a nex excel workbook with a uerform which allows the security/IT manager to create a key for each user of the software. The second part of of the code which I will post seperately checks the file and the logged on user then reencrypts against the individual pc. this makes it user and pc specific.

You need to make a form as the GUI for the guy to input the username but that should be a piece of cake. I have included some notes. It may not be perfect code but it works.

If anyone wants more request my e-mail address and we can get in touch. I will then mail you the files with the company specific stuff deleted. It does work well though.

'variables in the general decs in your module
Public secure(2) As Double, varuser As String

Sub auto_open()
Call initilise
frmsecurity.Show ' call it what you will
Call resetallbars
Select Case Workbooks.Count
Case 1
ActiveWorkbook.Saved = True
Application.Quit
Case Is > 1
ActiveWorkbook.Close savechanges:=False
End Select
End Sub

Sub securityalgoritim()
Dim varchar As Integer, varpos As Integer, factor As Single, checkval As String
varchar = Len(varuser) ' helps move through the username one character at a time
secure(0) = CSng(Now())
Do While varchar <> 0
checkval = Right(varuser, varchar)
checkval = Left(checkval, 1)
Select Case IsNumeric(checkval)
Case True
secure(1) = secure(1) + checkval
Case False
secure(1) = secure(1) + Asc(UCase(checkval))
End Select
varchar = varchar - 1
Loop
secure(1) = secure(1) * secure(0) ' this is simple as it multiples by the date, you can put whatever formula you want in here as long as the decrypt mirrors it duh!
Call savesecurekey
End Sub

Sub savesecurekey()
Dim fs, f, ts, s, varpos As Integer ' ,ostly straight out of help file
Do
filesavename = Application.GetSaveAsFilename(FileFilter:=&quot;SLDS User Key (*.SLD), *.SLD&quot
If filesavename = 0 Then Exit Sub
Set fs = CreateObject(&quot;Scripting.FileSystemObject&quot
If fs.FileExists(filesavename) = True Then x = MsgBox(&quot;FILE &quot; & filesavename & Chr(10) & Chr(10) & &quot;ALREADY EXISTS, SAVE OVER IT ?&quot;, vbYesNo + vbExclamation, &quot;SLDS Question&quot
If x = vbYes Then Kill filesavename
If x = vbYes Then Exit Do
If fs.FileExists(filesavename) = False Then Exit Do
Loop
Set fs = CreateObject(&quot;Scripting.FileSystemObject&quot
fs.CreateTextFile filesavename 'Create a file
Set f = fs.GetFile(filesavename)
Set ts = f.OpenAsTextStream(2, 0)
ts.write secure(0)
ts.writeblanklines (1)
ts.write secure(1)
ts.writeblanklines (5)
ts.write &quot;********************************************************************&quot;
ts.writeblanklines (1)
ts.write &quot;* *&quot;
ts.writeblanklines (1)
ts.write &quot;* THIS FILE IS THE PROPERTY OF ******** ************ *&quot;
ts.writeblanklines (1)
ts.write &quot;* This file is classified HIGHLY CONFIDENTIAL *&quot;
ts.writeblanklines (1)
ts.write &quot;* Any attempt to interfer with this file is a criminal offence *&quot; ' blah blah
ts.writeblanklines (1)
ts.write &quot;* *&quot;
ts.writeblanklines (1)
ts.write &quot;*******************************************************************&quot;
ts.writeblanklines (1)
ts.write &quot;Copyright **********************&quot; ' you get the idea
ts.Close
End Sub

Sub initilise()
On Error Resume Next
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
.DisplayWorkbookTabs = False
End With
With Application
.DisplayFormulaBar = False
.DisplayFullScreen = True
.DisplayScrollBars = False
End With
CommandBars(&quot;Standard&quot.Visible = False
CommandBars(&quot;Formatting&quot.Visible = False
Dim bar As Object
For Each bar In CommandBars
bar.Visible = False
Next bar
CommandBars(&quot;worksheet menu bar&quot.Enabled = False
End Sub

Sub resetallbars()
Application.CommandBars.DisableCustomize = True
With ActiveWindow
.DisplayGridlines = True
.DisplayHeadings = True
.DisplayWorkbookTabs = True
End With
With Application
.DisplayFormulaBar = True
.DisplayFullScreen = False
.DisplayScrollBars = True
End With
CommandBars(&quot;worksheet menu bar&quot.Reset
CommandBars(&quot;worksheet menu bar&quot.Enabled = True
CommandBars(&quot;Standard&quot.Enabled = True
CommandBars(&quot;Formatting&quot.Enabled = True
CommandBars(&quot;Drawing&quot.Enabled = True
CommandBars(&quot;Standard&quot.Visible = True
CommandBars(&quot;Formatting&quot.Visible = True
CommandBars(&quot;Drawing&quot.Visible = True
CommandBars(&quot;cell&quot.Reset
CommandBars(&quot;cell&quot.Enabled = True
End Sub

 

[cuok]

hI HorseGoose !

aMAZING !!

PLEASE do send me the files to:

cuok@bezeqint.net

Thanks a lot
CUOK

 

[DaleWatson123321]

Hi HorseGoose,

Thanks VERY much for your encryption code example/model.

You certainly deserve a STAR for sharing your work, so I'm pleased to award you one.

I'll be very grateful if you can email me your encryption files to the address below.

Regards, ...Dale Watson dwatson@bsi.gov.mb.ca