Bir soru münasebeti ile geçmiş yıllarda Visual Basic 6 ile yaptığım projelerde kullandığım program koruması aklıma geldi. Sizlerle de paylaşayım direkt Visual Basic 6 projelerinizde kullanabilir ya da Visual Basic.NET'e dönüştürerek VB.NET projelerinizde kullanabilirsiniz. Zaman olur da ben dönüştürürsem buradan yayınlarım.
Program ilk çalıştığında yükleneceği bilgisayarın hdd seri numarasını okuyup, bunu bir şifreleme algoritması ile şifrelemeye tabi tutup ilk çalışmada kaydediyor. Daha sonra çalışmalarda ise bunu sormuyor bir daha.
Eğer yeniden yükleme yapılırsa bu şifrelenmiş dosyayı okuyup doğru değerler var ise kurulum yapıyordu.
Elden geldiği kadar ilgili kodları derleyip yazmaya çalıştım. Kendinize göre düzenlersiniz.
’ İlk defa çalışılıp çalışılmadığını anlamak için registry tanımlaması
Dim d, x, Y, ts
Dim password As String ’sifre cozme
’Hdd seri numarası okumak için tanımlama
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
’Program ilk çalışmasında registera değer yazar ve her çalışmasında registerdan değer okur. Ben bir kreş için yaptığım için registry de Kres anahtarını ekledim.
d = GetSetting("Kres", "Ayarlar", "İlk Giriş", "")
x = GetSetting("Kres", "Ayarlar", "tekrar", "")
Y = GetSetting("Kres", "Ayarlar", "Son Giriş", "")
If d = "" Then
’Bu bilgisayarda ilk defa çalışıyor
SaveSetting "Kres", "Ayarlar", "İlk Giriş", Date
MsgBox "Program bu bilgisayarda ilk defa çalışıyor" & vbCrLf & "Geçici Kullanıcı adı v, şifre ise v dir." & vbCrLf & "Özel işlemler menüsünden değiştirebilirsiniz"
Open "a:\\sifre1.dat" For Input As #1
’Şifre dosyasından okuma yapılır.
Input #1, password
Close #1
password = Decrypt(password)
If password = "33rammerkez1" Then
Dim lpVolumeNameBuffer As String
Dim nVolumeNameSize As String
Dim lpVolumeSerialNumber As Long
Dim lpMaximumComponentLength As Long
Dim lpfileSystemFlags As Long
Dim lpFileSystemNameBuffer As String
Dim nFileSystemNameSize As Long
Dim lpSectorsPerCluster As Long
Dim lpBytesPerSector As Long
Dim lpNumberOfFreeClusters As Long
Dim lpTotalNumberOfClusters As Long
Dim rtval As Long
lpVolumeNameBuffer = Space(255)
nVolumeNameSize = 256
lpFileSystemNameBuffer = Space(255)
nFileSystemNameSize = 256
f% = (Dir$("a:\\sifre2.dat") <> "")
rtval = GetVolumeInformation("c:\\", _
lpVolumeNameBuffer, _
nVolumeNameSize, _
lpVolumeSerialNumber, _
lpMaximumComponentLength, _
lpfileSystemFlags, _
lpFileSystemNameBuffer, _
nFileSystemNameSize)
If f% = 0 Then
’Hdd seri no şifrelenir.
password = Encrypt(lpVolumeSerialNumber)
’Şifre kaydedilir
Open "a:\\sifre2.dat" For Output As #1
Print #1, password
Close #1
Exit Sub
Else
Open "a:\\sifre2.dat" For Input As #1
’Şifre dosyasında okuma yapılır
Input #1, password
Close #1
’password değişkeninin içeriği şifrelenmiş olan Hdd seri no ile karşılaştırılır
password = Decrypt(password)
If password <> lpVolumeSerialNumber Then
MsgBox "Sabit disk değiştirilmiş. Lütfen firmayla irtibat kurun"
If vbOK Then
Unload Me
End
End If
End If
End If
Else
MsgBox "Şifrenin bulunduğu diskete erişilemiyor ya da yanlış şifre" & vbCrLf & "Lütfen firma ile bağlantı kurun"
If vbOK Then
Unload Me
End
End If
End If
Else
’Buradan itibaren şifre doğru olduğunda çalışması gereken normal program satırları
........
End if
hata:
Select Case Err
Case 53: MsgBox "Şifrenin bulunduğu diskete erişilemiyor ya da yanlış şifre" & vbCrLf & "Lütfen firma ile bağlantı kurun"
Case 75: MsgBox "Şifrenin bulunduğu diskete erişilemiyor ya da yanlış şifre" & vbCrLf & "Lütfen firma ile bağlantı kurun"
Case 76: MsgBox "Şifrenin bulunduğu diskete erişilemiyor ya da yanlış şifre" & vbCrLf & "Lütfen firma ile bağlantı kurun"
Unload Me
End
End Select
Private Sub Form_Unload(Cancel As Integer)
SaveSetting "Kres", "Ayarlar", "Son Giriş", Date
SaveSetting "Kres", "Ayarlar", "tekrar", ts + 1
End Sub
’şifreleme ve şifre çözme alt programları
Public Function Encrypt(ByVal Plain As String)
Dim i
Dim Letter As String
For i = 1 To Len(Plain)
Letter = Mid$(Plain, i, 1)
Mid$(Plain, i, 1) = Chr(Asc(Letter) + 99)
Next i
Encrypt = Plain
End Function
Public Function Decrypt(ByVal Encrypted As String)
Dim i
Dim Letter As String
For i = 1 To Len(Encrypted)
Letter = Mid$(Encrypted, i, 1)
Mid$(Encrypted, i, 1) = Chr(Asc(Letter) - 99)
Next i
Decrypt = Encrypted
End Function