home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / create2a / form1.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1999-09-28  |  12.0 KB  |  292 lines
  1. VERSION 5.00
  2. Begin VB.Form Form1 
  3.    Caption         =   "Form1"
  4.    ClientHeight    =   5175
  5.    ClientLeft      =   60
  6.    ClientTop       =   345
  7.    ClientWidth     =   5715
  8.    LinkTopic       =   "Form1"
  9.    ScaleHeight     =   5175
  10.    ScaleWidth      =   5715
  11.    StartUpPosition =   2  'CenterScreen
  12.    Begin VB.CommandButton Command3 
  13.       Cancel          =   -1  'True
  14.       Caption         =   "Quit (ESC)"
  15.       Height          =   495
  16.       Left            =   3840
  17.       TabIndex        =   3
  18.       Top             =   4440
  19.       Width           =   1575
  20.    End
  21.    Begin VB.CommandButton Command2 
  22.       Caption         =   "&Unregister"
  23.       Height          =   495
  24.       Left            =   2040
  25.       TabIndex        =   2
  26.       Top             =   4440
  27.       Width           =   1575
  28.    End
  29.    Begin VB.CommandButton Command1 
  30.       Caption         =   "&Register"
  31.       Height          =   495
  32.       Left            =   240
  33.       TabIndex        =   1
  34.       Top             =   4440
  35.       Width           =   1575
  36.    End
  37.    Begin VB.TextBox Text1 
  38.       Height          =   4095
  39.       Left            =   120
  40.       MultiLine       =   -1  'True
  41.       ScrollBars      =   2  'Vertical
  42.       TabIndex        =   0
  43.       Top             =   120
  44.       Width           =   5415
  45.    End
  46. Attribute VB_Name = "Form1"
  47. Attribute VB_GlobalNameSpace = False
  48. Attribute VB_Creatable = False
  49. Attribute VB_PredeclaredId = True
  50. Attribute VB_Exposed = False
  51. Option Explicit
  52. Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
  53. Dim FirstInstallation As String, TimesWorked As Long, LicencedUser As String
  54. Dim Licenc As Long, DemoVersion As Boolean, ReadSeries As String
  55. Private Sub AddText(a As String)
  56.     Text1.Text = Text1.Text & vbCrLf & a
  57. End Sub
  58. Private Sub InitializeSystem()
  59. On Error GoTo erro
  60.     AddText ("Initializing...")
  61.     Dim volbuf$, sysname$, serialnum&, sysflags&, componentlength&, res&
  62.     volbuf$ = String$(256, 0)
  63.     sysname$ = String$(256, 0)
  64.     res = GetVolumeInformation("C:\", volbuf$, 255, serialnum, _
  65.             componentlength, sysflags, sysname$, 255)
  66.                  
  67.     AddText ("HD's serial number got: " & serialnum)
  68.     'This is the math expression you can apply to get the registering code.
  69.     'Of course, you must build another app that gets the user code and returns the
  70.     'registration code, wich you pass to the user.
  71.     Licenc = Int(2802 * Sqr(serialnum))
  72.     AddText ("Licence code is " & Licenc & ", use it when registering the software.")
  73.     'L
  74.  data da 1
  75.  instala
  76.     Dim FirstInstallationSaved As String, ReadDate As String, DateOk As String, FirstTime As Boolean
  77.     ReadDate = GetSetting("DemoApp", "Install", "Installation", "xxx")
  78.     If Not ReadDate = "xxx" Then
  79.         DateOk = Decrypt(ReadDate, "alex")
  80.         FirstInstallation = DateOk
  81.         AddText ("FirstInstallation read: " & FirstInstallation)
  82.     Else        'Nothing saved, this is the first time...
  83.         'FirstInstallation = Left(Date, 2) & Mid(Date, 4, 2) & Right(Date, 2)
  84.         FirstInstallation = Date
  85.         FirstInstallationSaved = Encrypt(FirstInstallation, "alex")
  86.         SaveSetting "DemoApp", "Install", "Installation", FirstInstallationSaved
  87.         AddText ("No FirstInstallation saved, doing it now.")
  88.         FirstTime = True
  89.     End If
  90.         
  91.     'Reads encrypted serial number:
  92.     ReadSeries = GetSetting("DemoApp", "Install", "Series", "0")
  93.     If ReadSeries = "0" Then      'Doesn't exist, creating one
  94.         DemoVersion = True
  95.         Me.Caption = "Demo App - THIS IS A DEMO VERSION!"
  96.         Command2.Enabled = False
  97.         Dim LimitDate As Date, TimesWorked As Long, TimesWorkedRead As String, TimesWorkedSaved As String
  98.         TimesWorkedRead = GetSetting("DemoApp", "Install", "TimesWorked", "0")
  99.         If Not TimesWorkedRead = "0" Then
  100.             TimesWorked = Decrypt(TimesWorkedRead, "alex")
  101.         Else
  102.             TimesWorked = 0
  103.         End If
  104.         
  105.         'Giving the user 1 month to use the demo
  106.         LimitDate = DateAdd("m", 1, FirstInstallation)
  107.         
  108.         If (TimesWorked >= 100 Or LimitDate < Date) And Not FirstTime Then
  109.             Me.Caption = "Demo App - EXPIRED!!!"
  110.             AddText ("")
  111.             AddText ("This Demo version has EXPIRED!!!")
  112.             AddText ("")
  113.             AddText ("Open Registry Editor and delete the key")
  114.             AddText ("HKEY_CURRENT_USER\Software\VB and VBA Program Settings\DemoApp\Install")
  115.             Command1.Enabled = False
  116.             'End    'Disable further use of the app by the user
  117.         Else
  118.             TimesWorked = TimesWorked + 1
  119.             TimesWorkedSaved = Encrypt(CStr(TimesWorked), "alex")
  120.             SaveSetting "DemoApp", "Install", "TimesWorked", TimesWorkedSaved
  121.             AddText ("This is a DEMO version. You can use it for 1 month or 100 times!")
  122.             AddText ("Times worked: " & TimesWorked & "       First installation: " & FirstInstallation)
  123.             
  124.             'Verify the TimesWorked variable:
  125.             If DemoVersion And TimesWorked >= 95 Then
  126.                 If TimesWorked = 100 Then
  127.                     AddText ("")
  128.                     AddText ("WARNING!!   This is the LAST TIME you can run this DEMO version!!!")
  129.                 ElseIf TimesWorked = 99 Then
  130.                     AddText ("")
  131.                     AddText ("WARNING!!   You can run only ONE MORE TIME this app!!")
  132.                 Else
  133.                     AddText ("")
  134.                     AddText ("WARNING!!   You can run this app " & 100 - TimesWorked & " more times.")
  135.                 End If
  136.             End If
  137.             
  138.             'Verify the FirstInstallation variable:
  139.             If Not FirstTime And DemoVersion And DateDiff("d", LimitDate, Date) * (-1) <= 5 Then
  140.                 If DateDiff("d", LimitDate, Date) = 0 Then
  141.                     AddText ("")
  142.                     AddText ("WARNING!!   This is the LAST DAY you can run this demo version!")
  143.                 ElseIf DateDiff("d", LimitDate, Date) = -1 Then
  144.                     AddText ("")
  145.                     AddText ("WARNING!!   You have only ONE MORE DAY to run this demo version!")
  146.                 Else
  147.                     AddText ("")
  148.                     AddText ("WARNING!!   You have " & DateDiff("d", LimitDate, Date) * (-1) & " days to run this demo version!")
  149.                 End If
  150.             End If
  151.         End If
  152.     ElseIf Decrypt(ReadSeries, "alex") <> CStr(Licenc) Then
  153.         AddText ("The licence code for this app is wrong.   Please contact the support!")
  154.         'End       'Someone have tried to alter the licence, or copy the entire Windows registry
  155.                     'from a registered machine to another one...
  156.     End If
  157.     If DemoVersion = False Then
  158.         Dim e As String
  159.         e = GetSetting("DemoApp", "Install", "LicencedUser")
  160.         Command1.Enabled = False
  161.         LicencedUser = Decrypt(e, "alex")
  162.         Me.Caption = "Demo App - REGISTERED VERSION to " & LicencedUser
  163.         AddText ("Registered version to " & LicencedUser)
  164.         
  165.         'you can continue to count the times the app has worked:
  166.         TimesWorkedRead = GetSetting("DemoApp", "Install", "TimesWorked", "0")
  167.         TimesWorked = Decrypt(TimesWorkedRead, "alex")
  168.         TimesWorked = TimesWorked + 1
  169.         TimesWorkedSaved = Encrypt(CStr(TimesWorked), "alex")
  170.         SaveSetting "DemoApp", "Install", "TimesWorked", TimesWorkedSaved
  171.         AddText ("Worked " & TimesWorked & " times.")
  172.     End If
  173.         
  174.         
  175.         
  176.     Exit Sub
  177. erro:
  178.     MsgBox "There was an error:" & vbLf & vbLf & Err.Number & " - " & Err.Description, vbCritical
  179.     Resume sa
  180. End Sub
  181. Public Function Decrypt(texti, salasana)
  182. On Error Resume Next
  183.     Dim t As Byte, sana As String, x1 As Integer, g As Integer, tt As Byte, DeCrypted As String
  184.     For t = 1 To Len(salasana)
  185.         sana = Asc(Mid(salasana, t, 1))
  186.         x1 = x1 + sana
  187.     Next
  188.     x1 = Int((x1 * 0.1) / 6)
  189.     salasana = x1
  190.     g = 0
  191.     For tt = 1 To Len(texti)
  192.         sana = Asc(Mid(texti, tt, 1))
  193.         g = g + 1
  194.         If g = 6 Then g = 0
  195.         x1 = 0
  196.         If g = 0 Then x1 = sana + (salasana - 2)
  197.         If g = 1 Then x1 = sana - (salasana - 5)
  198.         If g = 2 Then x1 = sana + (salasana - 4)
  199.         If g = 3 Then x1 = sana - (salasana - 2)
  200.         If g = 4 Then x1 = sana + (salasana - 3)
  201.         If g = 5 Then x1 = sana - (salasana - 5)
  202.         x1 = x1 - g
  203.         DeCrypted = DeCrypted & Chr(x1)
  204.     Next
  205.     Decrypt = DeCrypted
  206. End Function
  207. Public Function Encrypt(texti, salasana)
  208. On Error Resume Next
  209.     Dim t As Byte, tt As Byte, sana As String, x1 As Integer, g As Integer, Crypted As String
  210.     For t = 1 To Len(salasana)
  211.         sana = Asc(Mid(salasana, t, 1))
  212.         x1 = x1 + sana
  213.     Next
  214.     x1 = Int((x1 * 0.1) / 6)
  215.     salasana = x1
  216.     g = 0
  217.     For tt = 1 To Len(texti)
  218.         sana = Asc(Mid(texti, tt, 1))
  219.         g = g + 1
  220.         If g = 6 Then g = 0
  221.         x1 = 0
  222.         If g = 0 Then x1 = sana - (salasana - 2)
  223.         If g = 1 Then x1 = sana + (salasana - 5)
  224.         If g = 2 Then x1 = sana - (salasana - 4)
  225.         If g = 3 Then x1 = sana + (salasana - 2)
  226.         If g = 4 Then x1 = sana - (salasana - 3)
  227.         If g = 5 Then x1 = sana + (salasana - 5)
  228.         x1 = x1 + g
  229.         Crypted = Crypted & Chr(x1)
  230.     Next
  231.     Encrypt = Crypted
  232. End Function
  233. Private Sub Command1_Click()
  234. On Error GoTo erro
  235.     Dim volbuf$, sysname$, serialnum&, sysflags&, componentlength&, res&
  236.     volbuf$ = String$(256, 0)
  237.     sysname$ = String$(256, 0)
  238.     res = GetVolumeInformation("C:\", volbuf$, 255, serialnum, _
  239.             componentlength, sysflags, sysname$, 255)
  240.                         
  241.     'The math expression:
  242.     Licenc = Int(2802 * Sqr(serialnum))
  243.     Dim k As String
  244.     k = InputBox("Please input the registration code to this machine:", "Registration")
  245.     If Len(k) = 0 Then Exit Sub
  246.     If k <> Licenc Then
  247. CodErro:
  248.             MsgBox "Nice try, but it's an invalid code.", vbCritical
  249.     Else
  250.         Dim a As String, b As String, c As String
  251.         c = InputBox("Registered user:", "Registration")
  252.             If Len(c) = 0 Then MsgBox "Registration canceled!", vbCritical: Exit Sub
  253.             If MsgBox("Registered user:" & vbLf & vbLf & "" & c & "" & _
  254.                 vbLf & vbLf & "Confirm?", vbYesNo + vbQuestion) = vbYes Then
  255.             a = Encrypt(CStr(Licenc), "alex")
  256.             b = Encrypt(c, "alex")
  257.             SaveSetting "DemoApp", "Install", "Series", a
  258.             SaveSetting "DemoApp", "Install", "LicencedUser", b
  259.             LicencedUser = c
  260.             Command1.Enabled = False
  261.             MsgBox "Thanks for registering this app, etc etc...", vbInformation
  262.             Me.Caption = "Demo App - REGISTERED VERSION to " & c
  263.             DemoVersion = False
  264.         End If
  265.     End If
  266.     Exit Sub
  267. erro:
  268.     If Err.Number = 13 Then
  269.         Resume CodErro
  270.     Else
  271.         MsgBox "There was an error:" & vbLf & vbLf & Err.Number & " - " & Err.Description, vbCritical
  272.     Resume sa
  273.     End If
  274. End Sub
  275. Private Sub Command2_Click()
  276. On Error Resume Next
  277.     If MsgBox("You will cancel the registration." & vbLf & vbLf & "Ok?", vbYesNo) = vbYes Then
  278.         DeleteSetting "DemoApp", "Install", "LicencedUser"
  279.         DeleteSetting "DemoApp", "Install", "Series"
  280.         Me.Caption = "Demo App - THIS IS A DEMO VERSION!"
  281.         Command1.Enabled = True
  282.         Command2.Enabled = False
  283.     End If
  284. End Sub
  285. Private Sub Command3_Click()
  286.     Unload Me
  287.     End
  288. End Sub
  289. Private Sub Form_Activate()
  290.     InitializeSystem
  291. End Sub
  292.