ACCESS FEED: [belajar-access] Membuat Key Genertor dengan ID HDD [1 Attachment]

[Attachment(s) from hari yanto included below]

Untuk membuat aplikasi Key Generator, langkah paling awal bisa dimulai dengan membuat 2 modul:

Modul Pertama (berfungsi untuk memanggil Serial Number Hard Disk, dan membuat encrypsi-decrypsi -- memakai fungsi CryptRC4):

Function ShowDriveInfo(drvpath)
    Dim fs, d, t, s
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set d = fs.GetDrive(fs.GetDriveName(fs.GetAbsolutePathName(drvpath)))
    s = Abs(d.SerialNumber)
    ShowDriveInfo = s
End Function
Public Function CryptRC4(sText As String, sKey As String) As String
    Dim baS(0 To 255) As Byte
    Dim baK(0 To 255) As Byte
    Dim bytSwap     As Byte
    Dim lI          As Long
    Dim lJ          As Long
    Dim lIdx        As Long

    For lIdx = 0 To 255
        baS(lIdx) = lIdx
        baK(lIdx) = Asc(Mid$(sKey, 1 + (lIdx Mod Len(sKey)), 1))
    Next
    For lI = 0 To 255
        lJ = (lJ + baS(lI) + baK(lI)) Mod 256
        bytSwap = baS(lI)
        baS(lI) = baS(lJ)
        baS(lJ) = bytSwap
    Next
    lI = 0
    lJ = 0
    For lIdx = 1 To Len(sText)
        lI = (lI + 1) Mod 256
        lJ = (lJ + baS(lI)) Mod 256
        bytSwap = baS(lI)
        baS(lI) = baS(lJ)
        baS(lJ) = bytSwap
        CryptRC4 = CryptRC4 & Chr$((pvCryptXor(baS((CLng(baS(lI)) + baS(lJ)) Mod 256), Asc(Mid$(sText, lIdx, 1)))))
    Next
End Function

Private Function pvCryptXor(ByVal lI As Long, ByVal lJ As Long) As Long
    If lI = lJ Then
        pvCryptXor = lJ
    Else
        pvCryptXor = lI Xor lJ
    End If
End Function

Public Function ToHexDump(sText As String) As String
    Dim lIdx            As Long

    For lIdx = 1 To Len(sText)
        ToHexDump = ToHexDump & Right$("0" & Hex(Asc(Mid(sText, lIdx, 1))), 2)
    Next
End Function

Public Function FromHexDump(sText As String) As String
    Dim lIdx            As Long

    For lIdx = 1 To Len(sText) Step 2
        FromHexDump = FromHexDump & Chr$(CLng("&H" & Mid(sText, lIdx, 2)))
    Next
End Function

Modul kedua (berfungsi untuk mengeksekusi copy clipboard):

'********* Code Start ************
' This code was originally written by Terry Kreft.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of
' Terry Kreft
'
Public Const GHND = &H42
Public Const CF_TEXT = 1
Private Const CF_ANSIONLY = &H400&
Private Const CF_APPLY = &H200&
Private Const CF_BITMAP = 2
Private Const CF_DIB = 8
Private Const CF_DIF = 5
Private Const CF_DSPBITMAP = &H82
Private Const CF_DSPENHMETAFILE = &H8E
Private Const CF_DSPMETAFILEPICT = &H83
Private Const CF_DSPTEXT = &H81
Private Const CF_EFFECTS = &H100&
Private Const CF_ENABLEHOOK = &H8&
Private Const CF_ENABLETEMPLATE = &H10&
Private Const CF_ENABLETEMPLATEHANDLE = &H20&
Private Const CF_ENHMETAFILE = 14
Private Const CF_FIXEDPITCHONLY = &H4000&
Private Const CF_FORCEFONTEXIST = &H10000
Private Const CF_GDIOBJFIRST = &H300
Private Const CF_GDIOBJLAST = &H3FF
Private Const CF_HDROP = 15
Private Const CF_INITTOLOGFONTSTRUCT = &H40&
Private Const CF_LIMITSIZE = &H2000&
Private Const CF_LOCALE = 16
Private Const CF_MAX = 17
Private Const CF_METAFILEPICT = 3
Private Const CF_NOFACESEL = &H80000
Private Const CF_NOSCRIPTSEL = &H800000
Private Const CF_NOSIMULATIONS = &H1000&
Private Const CF_NOSIZESEL = &H200000
Private Const CF_NOSTYLESEL = &H100000
Private Const CF_NOVECTORFONTS = &H800&
Private Const CF_NOOEMFONTS = CF_NOVECTORFONTS
Private Const CF_NOVERTFONTS = &H1000000
Private Const CF_OEMTEXT = 7
Private Const CF_OWNERDISPLAY = &H80
Private Const CF_PALETTE = 9
Private Const CF_PENDATA = 10
Private Const CF_PRINTERFONTS = &H2
Private Const CF_PRIVATEFIRST = &H200
Private Const CF_PRIVATELAST = &H2FF
Private Const CF_RIFF = 11
Private Const CF_SCALABLEONLY = &H20000
Private Const CF_SCREENFONTS = &H1
Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Private Const CF_SCRIPTSONLY = CF_ANSIONLY
Private Const CF_SELECTSCRIPT = &H400000
Private Const CF_SHOWHELP = &H4&
Private Const CF_SYLK = 4
Private Const CF_TIFF = 6
Private Const CF_TTONLY = &H40000
Private Const CF_UNICODETEXT = 13
Private Const CF_USESTYLE = &H80&
Private Const CF_WAVE = 12
Private Const CF_WYSIWYG = &H8000

Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal _
dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _
As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) _
As Long
Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
ByVal lpString2 As Any) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" _
(ByVal lpString As String) As Long

Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _
As Long

Private Declare Function OpenClipboard Lib "user32" (ByVal Hwnd As Long) _
As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As _
Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat _
As Long, ByVal hMem As Long) As Long

Function ClipBoard_SetText(strCopyString As String) As Boolean
Dim hGlobalMemory As Long
Dim lpGlobalMemory As Long
Dim hClipMemory As Long

' Allocate moveable global memory.
'-------------------------------------------
hGlobalMemory = GlobalAlloc(GHND, Len(strCopyString) + 1)

' Lock the block to get a far pointer
' to this memory.
lpGlobalMemory = GlobalLock(hGlobalMemory)

' Copy the string to this global memory.
lpGlobalMemory = lstrcpy(lpGlobalMemory, strCopyString)

' Unlock the memory and then copy to the clipboard
If GlobalUnlock(hGlobalMemory) = 0 Then
    If OpenClipboard(0&) <> 0 Then
      Call EmptyClipboard
      hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
      ClipBoard_SetText = CBool(CloseClipboard)
    End If
End If
End Function

Function ClipBoard_GetText() As String
Dim hClipMemory As Long
Dim lpClipMemory As Long
Dim strCBText As String
Dim RetVal As Long
Dim lngSize As Long
If OpenClipboard(0&) <> 0 Then
    ' Obtain the handle to the global memory
    ' block that is referencing the text.
    hClipMemory = GetClipboardData(CF_TEXT)
    If hClipMemory <> 0 Then
      ' Lock Clipboard memory so we can reference
      ' the actual data string.
      lpClipMemory = GlobalLock(hClipMemory)
      If lpClipMemory <> 0 Then
        lngSize = GlobalSize(lpClipMemory)
        strCBText = Space$(lngSize)
        RetVal = lstrcpy(strCBText, lpClipMemory)
        RetVal = GlobalUnlock(hClipMemory)
        ' Peel off the null terminating character.
        strCBText = Left(strCBText, InStr(1, strCBText, Chr$(0), 0) - 1)
      Else
        MsgBox "Could not lock memory to copy string from."
      End If
    End If
    Call CloseClipboard
End If
ClipBoard_GetText = strCBText
End Function

Function CopyOlePiccy(Piccy As Object)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long

' Allocate moveable global memory.
'-------------------------------------------
hGlobalMemory = GlobalAlloc(GHND, Len(Piccy) + 1)

' Lock the block to get a far pointer
' to this memory.
lpGlobalMemory = GlobalLock(hGlobalMemory)

'Need to copy the object to the memory here

lpGlobalMemory = lstrcpy(lpGlobalMemory, Piccy)

' Unlock the memory.
If GlobalUnlock(hGlobalMemory) <> 0 Then
    MsgBox "Could not unlock memory location. Copy aborted."
    GoTo OutOfHere2
End If

' Open the Clipboard to copy data to.
If OpenClipboard(0&) = 0 Then
    MsgBox "Could not open the Clipboard. Copy aborted."
    Exit Function
End If

' Clear the Clipboard.
X = EmptyClipboard()

' Copy the data to the Clipboard.
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)

OutOfHere2:
If CloseClipboard() = 0 Then
    MsgBox "Could not close Clipboard."
End If
End Function
'********* Code End   ************

Selanjutnya kita buat 2 form untuk User dan Admin.

Untuk user:

      Isi script VBAnya:

Option Explicit

Private Sub Command21_Click()
Dim sSecret     As String
Dim aa          As Variant
Dim i           As Integer

'cek apakah lisence key dan key code sudah diisi
    If L_key <> "" And c_code <> "" Then
        'bila berisi, hilangkan tanda -, karena kofirmasi ke sistem tanpa tanda -
        sSecret = Replace(L_key, "-", "")
        'hilangkan space kosong kanan dan kiri
        id_dd = Trim(id_dd)
        sSecret = Trim(sSecret)
        'jika jumlah digit Lisence key lebih dari 10 digit
        If Len(sSecret) > 10 Then
             'melihat hasil kombinasi Lisence key dan Code Key
            aa = CryptRC4(FromHexDump(sSecret), c_code)
            'apabila sama dengan id_dd
            If aa = id_dd Then
                'Sukses
                status.Caption = "Sukses Registered!!"
                status.ForeColor = 16711680
            Else
               'Gagal
                status.Caption = "Not Registered, hubungi Admin untuk mendapatkan" _
                & " Key Code dan Lisence Key"
                status.ForeColor = 255
            End If
        Else
            status.Caption = "Not Registered, hubungi Admin untuk mendapatkan" _
            & " Key Code dan Lisence Key"
            status.ForeColor = 255
        End If
    Else
        MsgBox "Isi Lisence Key dan Key Code dulu", , "Harus isi"
        If id_dd <> "" Then
            c_code.SetFocus
        ElseIf c_code <> "" Then
            id_dd.SetFocus
        Else
            id_dd.SetFocus
        End If
    End If
End Sub

Private Sub Command22_Click()
    If id_dd <> "" Then
         'memblock textbox id_dd dan mengcopy (ctrl+c)
        ClipBoard_SetText (id_dd)
    Else
        MsgBox "Tidak ada Lisence Key yang akan di copy", , "Gak Ono Lisence Key"
    End If
End Sub

Private Sub Form_Load()
   'membaca nomor seri hard disk, ditaruh di texbox id_dd
    id_dd = ShowDriveInfo("C:")
End Sub

Untuk Admin:

Script untuk form admin:

Option Explicit

Private Sub Command21_Click()
'deklarasi variabel
Dim sSecret, aa    As String
Dim i           As Integer

    If id_dd <> "" And c_code <> "" Then
        'mengubah kombinasi id_dd dan c_code menjadi Lisence Key
        sSecret = ToHexDump(CryptRC4(id_dd, c_code))
        For i = 1 To Len(sSecret) Step 4
            'agar tampak menarik beri tanda - tiap 4 digit
            aa = aa & Mid(sSecret, i, 4) & "-"
        Next i
        'hilangkangkan tanda - yang terletak di akhir
        'semula aamma-amma-amama-mama-, menjadi aamma-amma-amama-mama
        aa = Trim(aa)
        aa = Mid(aa, 1, (Len(aa) - 1))
        L_key = aa 'taruh hasilnya ke textbox L_key
    Else
        MsgBox "Isi Lisence ID dan Key Code dulu", , "Harus isi"
        If id_dd <> "" Then
            c_code.SetFocus
        ElseIf c_code <> "" Then
            id_dd.SetFocus
        Else
            id_dd.SetFocus
        End If
    End If
End Sub

Private Sub Command22_Click()
Dim aa As Variant

    If L_key <> "" Then
        'membuat text yang akan di copy clipboard
        'kode vbTab ==> tekan tab
        'kode vbCrLf ==> ganti baris
        aa = "Lisence ID" & vbTab & ": " & id_dd & vbCrLf _
        & "Key Code" & vbTab & ": " & c_code & vbCrLf _
        & "Lisence Key" & vbTab & ": " & L_key & vbCrLf

        ClipBoard_SetText (aa)
    Else
        MsgBox "Tidak ada Lisence Key yang akan di copy", , "Gak Ono Lisence Key"
    End If
End Sub

Private Sub Command37_Click()
    'copy L_key
    ClipBoard_SetText (L_key)
End Sub

Private Sub Form_Load()
    this_id = ShowDriveInfo("C:")
End Sub

Bila form untuk user kita beri nama lisensi_user, sedangkan untuk admin lisensi_admin, maka tampilan di Ms Access akan nampak seperti ini: