home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic 4 Power Pack / Visual_Basic4_Power_Pack.bin / vb4files / passwd1 / passwrd.bas < prev    next >
Encoding:
BASIC Source File  |  1996-11-20  |  8.9 KB  |  276 lines
  1. Option Explicit
  2. 'This program is quite simple and well documented with comments.
  3. 'Written by Livio Bestulic, at Point Systems, Inc (which is also me)
  4. 'at CIS 102370,3655.  It was written because I couldn't find a simple
  5. 'set of Password modules/forms to insert into my programs.  Its free to
  6. 'use this code to develop and learn from.  However, I would like you to
  7. 'contribute $10.00 US dollars to my self interest fund if you incorporate
  8. 'it into your commercial/released/sold software.  You can register it on
  9. 'CIS GO SWREG or send a check/money order to:
  10. 'Point Systems, Inc.
  11. 'PO Box 76255
  12. 'St Petersburg' FL 33734
  13. '
  14. 'Registered users get to ask support questions via Email and I will Email
  15. 'them any major updates I perform to the this base program.  What do you
  16. 'expect for $10.  See the Readme.txt for additional details etc.
  17. '
  18. 'database file stuff (is an MS Access 2.5 DB, nothing special happens
  19. ' in the DB, its just for storage, so you can change it to anything
  20. ' as long as you change the db find, read & writes to any new field names.
  21. Global db As database
  22. Global Pw As dynaset
  23. 'Warning, if your VB can't read the DB, you need to upgrade the included Access
  24. 'Jet engine supplied with old VB. Go Access on CIS and do a key word search for
  25. 'Compatibility Layer (from Jet 1.1 to 2.0) and Service Pack (from jet 2 to 2.5).
  26. 'VB 4.0 comes with Jet 2.5 for 16bit and 3.0 for 32bit.
  27.  
  28. Global nResponse As Integer  'for cancel response
  29.  
  30. 'variables - read and written in this order
  31. Global UserID As String
  32. Global Password As String
  33. Global UserName As String
  34. Global UserTaskLevel As String
  35. Global UserActivationDate As String
  36. Global UserExpireDate As String
  37.  
  38. ' password specific constants
  39. Global Const EXPIRE_TERM = 90  'password expiration interval
  40. Global Const MAX_NAME_LENGTH = 50   ' name maximum length
  41. Global Const MINIMUM_ID_LENGTH = 3   'ID minimum length
  42. Global Const MAX_ID_LENGTH = 25   'ID maximum length
  43. Global Const MINIMUM_PASSWORD_LENGTH = 6   'password minimum length
  44. Global Const MAX_PASSWORD_LENGTH = 15   'password maximum length
  45. Global Const PASSWORD_FILE = "password.mdb"   'password filename
  46. 'important, next constant is used as encrypion key
  47. Global Const APP_TITTLE = "Password Program" 'Application title & encryt key
  48. Global Const APP_PASSWORD_REQUIRED = True    'enable password protection
  49. Global Const NUM_TRIES = 3  'max number of password tries before the boot!
  50.  
  51. 'windows stuff
  52. Global Const MODAL = 1    'to show the password forms Modally  ie stay on top
  53. Global Const MODELESS = 0  'not modal
  54.  
  55. Function crypt (Action As String, Key As String, Src As String) As String
  56. 'E encrypts, D decrypts, Key is a unique string needed to en/decrypt (either hardcode or
  57. 'setup something for the user to enter. Src is the string to be en/decrypted.
  58.  
  59. 'I take no credit for this Function,  I picked
  60. 'it over a number of other methods/code available in VBPJ mag, articles etc. Its simple and I
  61. 'like it better than the ASCII shifting.  Hex just seems a little more subtle.  Replace this
  62. 'function with any number of similar ones out there or just write your own.
  63. 'from Crypt.Bas by ????.
  64.  
  65. Dim count As Integer, KeyPos As Integer, KeyLen As Integer, SrcAsc As Integer
  66. Dim Dest As String, Offset As Integer, TmpSrcAsc, SrcPos As Integer
  67.  
  68. KeyLen = Len(Key)
  69.  
  70. If Action = "E" Then
  71.     Randomize
  72.     Offset = (Rnd * 10000 Mod 255) + 1
  73.     Dest = Hex$(Offset)
  74.  
  75.     For SrcPos = 1 To Len(Src)
  76.         SrcAsc = (Asc(Mid$(Src, SrcPos, 1)) + Offset) Mod 255
  77.         If KeyPos < KeyLen Then KeyPos = KeyPos + 1 Else KeyPos = 1
  78.         'Fill Dest$ with HEX representation of Encrypted field
  79.         'Hex used to keep nasties such as eof or lf from mangling stream
  80.         'Use format$ to make Hex$ return " 0" instead of "0" when the same
  81.         'values are Xor'ed together (Null) - keeps placeholder for decrypt
  82.         SrcAsc = SrcAsc Xor Asc(Mid$(Key, KeyPos, 1))
  83.         Dest = Dest + Format$(Hex$(SrcAsc), "@@")
  84.         Offset = SrcAsc
  85.  
  86.     Next
  87.  
  88. ElseIf Action = "D" Then
  89.     Offset = Val("&H" + Left$(Src, 2))
  90.     For SrcPos = 3 To Len(Src) Step 2
  91.         SrcAsc = Val("&H" + Trim(Mid$(Src, SrcPos, 2)))
  92.         If KeyPos < KeyLen Then KeyPos = KeyPos + 1 Else KeyPos = 1
  93.         TmpSrcAsc = SrcAsc Xor Asc(Mid$(Key, KeyPos, 1))
  94.         If TmpSrcAsc <= Offset Then
  95.             TmpSrcAsc = 255 + TmpSrcAsc - Offset
  96.         Else
  97.             TmpSrcAsc = TmpSrcAsc - Offset
  98.         End If
  99.         Dest = Dest + Chr(TmpSrcAsc)
  100.         Offset = SrcAsc
  101.     Next
  102.  
  103. End If
  104. crypt = Dest
  105.  
  106. End Function
  107.  
  108. Sub DeletePassword (tempID As String)
  109.  
  110. On Local Error GoTo DeleteError
  111. Screen.MousePointer = 11
  112.  
  113.    'find the UserID
  114.    Pw.FindFirst "[UserID] = '" & tempID & "'"
  115.    If Pw.NoMatch Then  ' doesn't exists
  116.             Screen.MousePointer = 0
  117.             Exit Sub
  118.    End If
  119.    'found so delete it
  120.    Pw.Delete
  121.    
  122.  
  123. 'say all is ok
  124. MsgBox "Delete was successfull.", 64, "Delete OK"
  125. Screen.MousePointer = 0 ' Default
  126. Exit Sub
  127.  
  128. DeleteError:
  129.   Beep
  130.   MsgBox "Delete Error Occurred. " & Error, 16, " Error No. " & Err
  131.   Exit Sub
  132.  
  133.  
  134.  
  135.  
  136.  
  137.  
  138.  
  139. End Sub
  140.  
  141. Sub FormCenterModal (frmCurrent As Form)
  142.     frmCurrent.Left = (Screen.Width - frmCurrent.Width) / 2
  143.     frmCurrent.Top = (Screen.Height - frmCurrent.Height) / 2
  144. End Sub
  145.  
  146. Sub Main ()
  147. Dim F As String
  148.  
  149. F = Dir$(app.Path & "\" & PASSWORD_FILE) 'check for file exists
  150. If F = "" Then 'if password file doesn't exist
  151.     'Password = "COMPUTER"  'password file doesn't exist.
  152.     'UserID = "test"         'My development backdoor or default
  153.     'Screen.MousePointer = 0
  154.     'Exit Sub
  155.     'use the above in development and below in final code release
  156.     Beep 'to prevent user deleting pw file as entry point
  157.     MsgBox "Password file could not be found or is corrupt. Call Technical Support at 1800-555-1212.", 16, "Missing or Corrupt Password File"
  158.     End
  159. Else
  160.    'open the database (DB notes in Readme.txt)
  161.    Set db = OpenDatabase(app.Path & "\" & PASSWORD_FILE)
  162.    Set Pw = db.CreateDynaset("Passwords")    'table
  163. End If
  164.    
  165.    
  166.    MainForm.Show
  167.    
  168.    If APP_PASSWORD_REQUIRED Then 'to disable password checking in the app.
  169.       frmPassWord.Show MODAL
  170.    End If
  171.  
  172. End Sub
  173.  
  174. Sub ReadPasswd (RAction As Integer, Rtemp As String)
  175. Dim temp As String
  176. Dim Mark As Integer, z As Integer
  177.  
  178. On Local Error GoTo ReadError
  179.  
  180. Screen.MousePointer = 11
  181. 'my back door
  182. Pw.MoveLast
  183. If Pw.RecordCount = 0 Then        'if the db is empty then this will
  184.     UserID = "~"       'bypass the retrieval and set
  185.     Password = "~"      'id & password to secrete backdoor
  186.     Screen.MousePointer = 0   'enter ~ as the ID and the
  187.     Exit Sub                  ' password. You can remove this but
  188. End If                   'will need to limit deletes to prevent empting the db.
  189.    
  190.  If RAction = True Then
  191.     'find the UserID
  192.     Pw.FindFirst "[UserID] = '" & UserID & "'"
  193.     If Pw.NoMatch Then
  194.         'not found so get out of sub
  195.         Password = Chr$(177) 'my not found character (dont want it to be blank)
  196.         Screen.MousePointer = 0
  197.         Exit Sub
  198.     End If
  199.     UserName = Pw("UserName")
  200.     temp = Pw("Password")'the encrypted pw,level & dates
  201.     'was found so decrypt the string
  202.     temp = crypt("D", APP_TITTLE, temp)
  203.     'seperate the parts
  204.     'password
  205.     Mark = InStr(1, temp, "|")
  206.     Password = Left(temp, Mark - 1)
  207.     'tasklevel
  208.     z = InStr(Mark + 1, temp, "|")
  209.     UserTaskLevel = Mid(temp, Mark + 1, 1)
  210.     Mark = z
  211.     'activation date
  212.     z = InStr(Mark + 1, temp, "|")
  213.     UserActivationDate = Mid(temp, Mark + 1, z - Mark - 1)
  214.     'expire date
  215.     UserExpireDate = Right(temp, Len(temp) - z)
  216.  Else
  217.     Pw.FindFirst "[UserID] = '" & Rtemp & "'"
  218.     If Pw.NoMatch Then
  219.         'not found so get out of sub
  220.         Rtemp = "|||"'blank
  221.         Screen.MousePointer = 0
  222.         Exit Sub
  223.     End If
  224.     Rtemp = Pw("Password")'the encrypted pw,level & dates
  225.     Rtemp = crypt("D", APP_TITTLE, Rtemp)
  226.     'unparsed so it won't change your info, for display only
  227.  End If
  228. Screen.MousePointer = 0
  229.  
  230.  
  231. Exit Sub
  232. ReadError:
  233.   MsgBox "Read Error Occurred. " & Error, 16, " Error No. " & Err
  234.   Resume Next
  235.  
  236. End Sub
  237.  
  238. Sub WritePasswd (Action As Integer, tempID As String, tempName As String, temp As String)
  239.  
  240.  
  241. On Local Error GoTo WriteError
  242. Screen.MousePointer = 11
  243.  
  244. 'encrypt
  245. temp = crypt("E", APP_TITTLE, temp)
  246.  
  247.    If Action Then   'true is addnew
  248.         Pw.AddNew
  249.         Pw("UserID") = tempID
  250.         Pw("UserName") = tempName
  251.         Pw("Password") = temp
  252.         Pw.Update  'update saves
  253.    Else             'must be edit
  254.         Pw.FindFirst "[UserID] = '" & tempID & "'"
  255.         Pw.Edit
  256.         Pw("UserName") = tempName
  257.         Pw("Password") = temp
  258.         Pw.Update  'update saves
  259.    End If
  260.  
  261. 'say all is ok
  262. MsgBox "Updates were successfull.", 64, "Update OK"
  263. Screen.MousePointer = 0 ' Default
  264. Exit Sub
  265.  
  266. WriteError:
  267.   Beep
  268.   MsgBox "Write Error Occurred. " & Error, 16, " Error No. " & Err
  269.   Exit Sub
  270.  
  271.  
  272.  
  273.  
  274. End Sub
  275.  
  276.