Private Declare Function GetVolumeSerialNumber 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
Dim iInUse As Integer
Dim s(0 To 255) As Integer 'S-Box
Dim kep(0 To 255) As Integer
'For the file actions
Dim path As String
Public Sub RC4ini(Pwd As String)
Dim temp As Integer, a As Integer, b As Integer
'Save Password in Byte-Array
b = 0
For a = 0 To 255
b = b + 1
If b > Len(Pwd) Then
b = 1
End If
kep(a) = Asc(Mid$(Pwd, b, 1))
Next a
'INI S-Box
For a = 0 To 255
s(a) = a
Next a
b = 0
For a = 0 To 255
b = (b + s(a) + kep(a)) Mod 256
' Swap( S(i),S(j) )
temp = s(a)
s(a) = s(b)
s(b) = temp
Next a
End Sub
Public Function EnDeCrypt(plaintxt As Variant) As Variant
Dim temp As Integer, a As Long, i As Integer, j As Integer, k As Integer
Dim cipherby As Byte, cipher As Variant
For a = 1 To Len(plaintxt)
i = (i + 1) Mod 256
j = (j + s(i)) Mod 256
' Swap( S(i),S(j) )
temp = s(i)
s(i) = s(j)
s(j) = temp
'Generate Keybyte k
k = s((s(i) + s(j)) Mod 256)
'Plaintextbyte xor Keybyte
cipherby = Asc(Mid$(plaintxt, a, 1)) Xor k
cipher = cipher & Chr(cipherby)
Next a
EnDeCrypt = cipher
End Function
Private Sub cmdClose_Click()
Server.StopServer
Unload Me
End Sub
Private Sub Form_Load()
Dim Hostname As String, IPAdd As String
'get Server IP and save it to local file
Hostname = GetIPHostName()
IPAdd = GetIPAddress()
rtbOpen.Text = ""
rtbOpen.Text = IPAdd
rtbOpen.SaveFile App.path & "\SVRIP.DAT", rtfText
rtbOpen.Text = ""
txtUID = Trim(VolumeSerialNumber("C:\"))
Call Server.StartServer(123, IPAdd)
iInUse = 0
OpenLocalKeys
End Sub
Private Sub Form_Terminate()
On Error Resume Next
Kill App.path & "\SVRIP.DAT"
Call Server.StopServer
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
Kill App.path & "\SVRIP.DAT"
Call Server.StopServer
End Sub
Private Sub mnuOpenLK_Click()
'I chose .dlk as my licence key extension
On Error GoTo InvalidKey
cdMain.Filter = "*.dlk|*.dlk"
cdMain.FileName = ""
cdMain.ShowOpen
'check if a file was selected
If cdMain.FileName <> "" Then
'open key
Dim MyStr As String
Dim MyCipher As String
Dim mlen As Integer
rtbOpen.LoadFile cdMain.FileName, rtfText
mlen = Left(rtbOpen.Text, 2)
MyCipher = Mid(rtbOpen.Text, 38, mlen)
RC4ini (txtUID.Text)
MyStr = EnDeCrypt(MyCipher)
Dim mynum As Double
Dim myhex As Long
Dim myhex2 As String
mynum = Split(MyStr, " ")(0)
myhex = Split(MyStr, " ")(1)
myhex2 = Hex(myhex)
a = mynum - Asc(Mid(myhex2, 2, 1))
b = Asc(Right(myhex2, 1))
d = Asc(Left(myhex2, 1))
c = a / d
f = Int(c / b)
'first check that this is not just a renamed file
'use the unique hex code for this
For i = 1 To lvKeys.ListItems.Count
If myhex2 = lvKeys.ListItems(i).SubItems(3) Then
MsgBox "This key is already registered!", vbExclamation + vbOKOnly, "Error"
Exit Sub
End If
Next i
'f is the number of licences
Dim LI As ListItem
Set LI = lvKeys.ListItems.Add(, , cdMain.FileName)
LI.SubItems(1) = Str(f)
LI.SubItems(2) = Str(f)
LI.SubItems(3) = myhex2
End If
Exit Sub
InvalidKey:
MsgBox "Key is invalid!", vbExclamation + vbOKOnly, "Error"
End Sub
Private Function VolumeSerialNumber(ByVal RootPath As String) As String
Dim VolLabel As String
Dim VolSize As Long
Dim Serial As Long
Dim MaxLen As Long
Dim Flags As Long
Dim Name As String
Dim NameSize As Long
Dim s As String
Dim ret As Boolean
ret = GetVolumeSerialNumber(RootPath, VolLabel, VolSize, Serial, MaxLen, Flags, Name, NameSize)
If ret Then
VolumeSerialNumber = Str(Serial)
VolumeSerialNumber = "00000000"
End If
End Function
Private Sub Server_DataArrival(ByVal SckIndex As Integer, ByVal Data As String, ByVal bytesTotal As Long, ByVal RemoteIP As String, ByVal RemoteHost As String)
(.txt)