Karena ada permintaan maka kami posting tutorial part 2 Membuat generator key dengan Macro VBA Excel langsung saja
Pertama buka workbook baru beri nama file GENERATOR KEY.xls lalu masuk pada vba macro
buat 1 userfrom seperti gambar berikut
- Masukkan/Inser Label1, Label2, Label3, Label4, Label5 , Textbox1, Textbox2, Textbox3, Button1, Button2, Button3,Scrollbar
- Kemudian ganti Caption dan Name:
Caption Label1 : SN Computer Drives
Caption Label2 : The Validity
Caption Label3 : Aktivation Code
Name.Label4 : txtvalid
Caption Label5 : <-play div="">
Name.Textbox1 : txtSN
Name.Textbox2 : txttgl
Name.Textbox3 : txtcode
Name.Button1 : cmdPutar
Name.Button2 : cmdAbout
Name.Button3 : cmdExit
Name.Scrollbar : DATAS
3. Kemudian klik Scrool Bar masukkan string
Private Sub DATAS_Change()
If DATAS.Value Then Call ApdetKontrol
End Sub
4. Klik REGISTRASI masukkan string
Private Sub cmdPutar_Click()Dim BarisAktip As Integer
BarisAktip = DATAS.Value
With ThisWorkbook.Sheets("Serial")
.Cells(BarisAktip, 6).Value = txtcode.Value
End With
txtSN.Value = ThisWorkbook.Sheets("Serial").Cells(DATAS.Value, 7)
txttgl.Value = ThisWorkbook.Sheets("Serial").Cells(DATAS.Value, 8)
txtvalid.Value = ThisWorkbook.Sheets("Serial").Cells(DATAS.Value, 9)
End Sub
5. Klik About masukkan string
Private Sub cmdAbout_Click()
MsgBox " REGISTRATION KEY " & vbCrLf _
& " Versi. 0.1" & vbCrLf & vbCrLf _
& " ===============================" & vbCrLf _
& " Application registration program " & vbCrLf _
& " By optimizing VBA Macro Project " & vbCrLf _
& " Applications are still below perfection" & vbCrLf _
& " ===============================" & vbCrLf & vbCrLf _
& " By. wahyuareta" & vbCrLf _
& " http://packfile.webs.com" & vbCrLf & vbCrLf _
& " Support Mas Syukron. Thank ", vbOKOnly, "ABOUT"
End Sub
6. Klik Exit masukkan string
Private Sub cmdExit_Click()
'Application.Quit
Unload Me
End Sub
7. Masukkan string klik userform berikut
Option Explicit
Private Sub ApdetKontrol()
txtcode.Value = ThisWorkbook.Sheets("Serial").Cells(DATAS.Value, 6)
txtSN.Value = ThisWorkbook.Sheets("Serial").Cells(DATAS.Value, 7)
txttgl.Value = ThisWorkbook.Sheets("Serial").Cells(DATAS.Value, 8)
txtvalid.Value = ThisWorkbook.Sheets("Serial").Cells(DATAS.Value, 9)
End Sub
Private Sub UserForm_Activate()
Me.Caption = "Registration Key"
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, _
CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
MsgBox "Sorry please select the exit button to close it!", vbOKOnly, "Closed"
End If
End Sub
8. Tambahkan "Module masukkan string
Const pengguna = "Serial!B2"
Sub Auto_Close()
On Error Resume Next
ThisWorkbook.Sheets("Serial").Visible = xlSheetVeryHidden
End Sub
Sub Auto_Open()
Dim filesistem As Object, draive As Object, nyuitem As Object
Dim yuser As String, suorce As String
Dim Registrasi As Object, SubMenu As Object
Dim FSys As Object, Drv As Object
Dim Sn1 As Variant, Sn2 As Variant
Dim serial1 As String, serial2 As String
Dim Respon1 As VbMsgBoxResult, Respon2 As VbMsgBoxResult
Call Auto_Close
Set FSys = CreateObject("Scripting.FileSystemObject")
Set Drv = FSys.GetDrive(FSys.GetDriveName _
(FSys.GetAbsolutePathName(ThisWorkbook.FullName)))
Sn2 = Abs(Drv.SerialNumber)
Sn1 = ThisWorkbook.Sheets("Serial").Range("A1").Value
On Error GoTo 0
yuser = Application.UserName
Set filesistem = CreateObject("Scripting.FileSystemObject")
Set draive = filesistem.GetDrive(filesistem.GetDriveName _
(filesistem.GetAbsolutePathName(ThisWorkbook.FullName)))
If Sn1 = Sn2 Then
If ThisWorkbook.Sheets("Serial").Range("C13").Value < Date Then GoTo TutupWorkbook
Exit Sub
Else
serial1 = ThisWorkbook.Sheets("Serial").Range("F1").Value
serial2 = Generator(Right(Sn1, 4))
If serial1 = serial2 Then
Respon1 = MsgBox("Wait... " & (Right(Sn1, 4)) & vbCrLf _
& "Are you sure you want to move the application?", vbQuestion + vbYesNo, "Reset")
If Respon1 = vbYes Then
Respon2 = MsgBox("Succes... " & (Right(Sn2, 4)) & vbCrLf, vbQuestion + vbYesNo, "Reset")
If Respon2 = vbYes Then
GoTo ResetSN
Else
GoTo TutupWorkbook
End If
Else
TutupWorkbook:
Call Auto_Close
ThisWorkbook.Close SaveChanges:=False
End If
Else
MsgBox "Name number old pc : " & ThisWorkbook.Sheets("Serial").Range("B3") & (Right(Sn1, 4)) & vbCrLf _
& "Activation code : " & serial1 & vbCrLf _
& "---------------------------" & vbCrLf _
& "Name number new pc : " & ThisWorkbook.Sheets("Serial").Range("B3") & (Right(Sn2, 4)) & vbCrLf & vbCrLf _
& "Serial number will be reset!!!" _
, vbInformation + vbOKOnly, "DRIVE SN CHANGED"
ResetSN:
ThisWorkbook.Sheets("Serial").Range("A1").Value = Sn2
ThisWorkbook.Sheets("Serial").Range("A1").Font.ColorIndex = 2
ThisWorkbook.Sheets("Serial").Range("F1").Value = Empty
ThisWorkbook.Sheets("Serial").Range("F1").Font.ColorIndex = 2
ThisWorkbook.Sheets("Serial").Range("B2").Value = Empty
ThisWorkbook.Sheets("Serial").Range("B2").Font.ColorIndex = 2
ThisWorkbook.Sheets("Serial").Range("C13").Value = Date + 30
ThisWorkbook.Sheets("Serial").Range("C13").Font.ColorIndex = 2
ThisWorkbook.Sheets("Serial").Range(pengguna).Value = Empty
ThisWorkbook.Sheets("Serial").Range(pengguna).Value = yuser
ThisWorkbook.Sheets("Serial").Range(pengguna).Font.ColorIndex = 2
ThisWorkbook.Save
End If
End If
UserForm1.Show
End Sub
Private Function Generator(KodeNumber As Long) As String
Dim Digit10 As Variant
Dim i As Integer
Dim karakter(35) As Variant
karakter(0) = "0"
karakter(1) = "5"
karakter(2) = "P"
karakter(3) = "X"
karakter(4) = "V"
karakter(5) = "A"
karakter(6) = "E"
karakter(7) = "Y"
karakter(8) = "4"
karakter(9) = "W"
karakter(10) = "Q"
karakter(11) = "G"
karakter(12) = "K"
karakter(13) = "Z"
karakter(14) = "R"
karakter(15) = "9"
karakter(16) = "L"
karakter(17) = "C"
karakter(18) = "I"
karakter(19) = "O"
karakter(20) = "8"
karakter(21) = "D"
karakter(22) = "S"
karakter(23) = "B"
karakter(24) = "M"
karakter(25) = "F"
karakter(26) = "U"
karakter(27) = "6"
karakter(28) = "J"
karakter(29) = "7"
karakter(30) = "H"
karakter(31) = "N"
karakter(32) = "1"
karakter(33) = "2"
karakter(34) = "3"
karakter(35) = "T"
Digit10 = Right("1234" & KodeNumber, 4)
Do
If Len(Digit10) >= 10 Then Exit Do
Digit10 = Digit10 * KodeNumber
Loop
For i = 1 To 10
Generator = Generator & karakter(Mid(Digit10, i, 1))
Next i
End Function
Selamat mencoba ......
dari pada ribet kami sertakan file contohnya: GENERATOR KEY jangan lupa like
Password VBA : kontakpm4x
Silahkan dimodifikasi bebas tetap sertakan sumber aslinya.
Semoga membantu...
0 komentar
Posting Komentar