DESKTOP PROTEKTOR

Contoh source code dibawah ini berfungsi untuk
mengamankan komputer anda dari user** yang tidak anda
inginkan untuk menggunakan komputer anda.
1. Siapkan 1 Project simpan dengan nama ExLock.vbp
2. Buat 1 Form dengan properties Name:FrmPassLock,
BackColor:&H00C00000&, Borderstyle:0-None
3. Buat 1 Frame dengan properties Backcolor:&H00FF0000&
4. Buat 1 Label dengan properties Name:lblStatus,
BackStyle:0-Transparent, Borderstyle:0-None
5. Buat 2 TextBox, yaitu
TextBox1 dengan properties Name:txtUser,
BackColor:&H00FF8080&, Text:UserName.
TextBox2 dengan properties Name:txtPassword,
BackColor:&H00FF8080&, PasswordChar:*
6. Tambah 1 Timer dengan properties Name:timPause,
Enable:False, Interval:2000
7. Tambahkan Module simpan dengan nama deskt.bas

Copy coding dibawah ini dan paste di Editor Form:

'coding Editor Form:
'catatan Untuk menspesifikasikan password yang baru,
'Hapus terlebih dahulu file profil_user.z33 selanjutnya jalankan ExLock.vbp
'Diadaptasi dari http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=48339&lngWId=1

Private Sub TampilkanPesan(ByVal Msg As String)
    lblStatus.Caption = Msg
    lblStatus.Left = Frame1.Width / 2 - lblStatus.Width / 20
    timPause.Enabled = True
End Sub

Private Sub Redraw_Form()
    Me.Height = Screen.Height
    Me.Width = Screen.Width
    Me.Top = 0
    Me.Left = 0
    Frame1.Caption = App.Title
    Frame1.Top = Me.ScaleHeight / 2 - Frame1.Height / 2
    Frame1.Left = Me.ScaleWidth / 2 - Frame1.Width / 2
    AktifkanForm
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 95 Then KeyCode = 0
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    txtPassword.SetFocus
End Sub

Private Sub Form_Load()
    App.TaskVisible = False
    If txtUser.Text = "" Then txtUser.Locked = False
    lngI = SetFocuses(Me.hWnd)
End Sub

Private Sub Form_Resize()
    Redraw_Form
End Sub

Private Function Petunjuk()
    Dim HurufPertamaPass
    HurufPertamaPass = Left$(PassPadaMemory.strPassword, 1)
    For i = 2 To Len(PassPadaMemory.strPassword)
        HurufPertamaPass = HurufPertamaPass & "*"
    Next i
    Petunjuk = HurufPertamaPass
End Function

Private Sub txtPassword_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn Then
        If ApaPassDahBener(txtPassword.Text, txtUser.Text) <> Yap Then
            TampilkanPesan "Password gak bener : (" & Petunjuk() & ")"
        Else
            End
        End If
    End If
End Sub

Private Sub txtUser_GotFocus()
    If txtUser.Locked = True Then txtPassword.SetFocus
End Sub

Copy coding dibawah ini dan paste di Editor Module:

'Copy coding dibawah ini dan paste di Editor Module:


Public Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Declare Function SetFocuses Lib "user32" Alias "SetFocus" (ByVal hWnd As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Public Type InfoYgDidapat
    LenUserName As Long
    LenPassword As Long
    strUserName As String
    strPassword As String
End Type

Public Enum ApaButuhProfilBaru
    Yap = -1
    Kagak = 0
End Enum

Public UserName(100) As Long
Public Password(100) As Long
Public LenUser As Long
Public LenPass As Long
Public PassPadaMemory As InfoYgDidapat
Public Const UserProfile = "profil_user.z33"
Public BuatProfil As Boolean

Public Function ApaPassDahBener(ByVal lpPassword As String, lpUserName) As ApaButuhProfilBaru
    Dim NullReturn As Variant
    If BuatProfil = True Then
        NullReturn = TulisUserN_keFile(lpUserName, lpPassword)
        ApaPassDahBener = Yap
        Exit Function
    End If
   
    If lpPassword <> PassPadaMemory.strPassword Then
        ApaPassDahBener = Kagak
    Else
        ApaPassDahBener = Yap
    End If
End Function

Public Function ApaAda(ByVal lstrQuery As String) As Boolean
    ApaAda = (Dir(lstrQuery) <> "")
End Function

Public Function AmbilUsrN_DariFile() As InfoYgDidapat
    On Error GoTo ErrorHandler
    Dim LenUserName As Long
    Dim LenPassword As Long
    Dim lngUserN(100) As Long
    Dim lngPassN(100) As Long
    Dim lpStrUser, lpStrPassword, Letter As String
    Dim lngShuffle As Long
    
    Open UserProfile For Binary As #1
        Get #1, , LenUserName
        Get #1, , LenPassword
        Get #1, , lngUserN
        Get #1, , lngPassN
    Close #1
    
    For i = 1 To LenUserName
       lpStrUser = lpStrUser & Chr$((lngUserN(i) / 2))
    Next i
    
    For i = 1 To LenPassword
       lpStrPassword = lpStrPassword & Chr$(lngPassN(i) / 2)
    Next i
      
    With AmbilUsrN_DariFile
        .LenPassword = LenPassword
        .LenUserName = LenUserName
        .strPassword = lpStrPassword
        .strUserName = lpstrusername
    End With
    Exit Function
    
ErrorHandler:
   frmPassLock.Visible = False
    MsgBox "Error:" & Err.Description
   End
End Function

'Enkripsi password pada file profil_user.z33
Public Function TulisUserN_keFile(ByVal lstrUser As String, lstrPass As String)
    On Error GoTo ErrorHandler
    Dim lngShuffle As Long
    Dim Letter As String

    LenUser = Len(lstrUser)
    LenPass = Len(lstrPass)

    For i = 1 To LenUser
        Letter = Mid$(lstrUser, i, i + 1)
        lngShuffle = Asc(Letter)
        UserName(i) = lngShuffle * 2
    Next i

    For i = 1 To LenPass
        Letter = Mid$(lstrPass, i, i + 1)
        lngShuffle = Asc(Letter)
        Password(i) = lngShuffle * 2
    Next i

    Open UserProfile For Binary As #1
        Put #1, , LenUser
        Put #1, , LenPass
        Put #1, , UserName
        Put #1, , Password
    Close #1

    Exit Function
   
ErrorHandler:
    frmPassLock.Visible = False
    MsgBox "Error:" & Error
    End
End Function

Public Sub AktifkanForm()
    Const SWP_NOSIZE = &H1
    Const SWP_NOMOVE = &H2
    Const SWP_NOACTIVATE = &H10
    Const SWP_SHOWWINDOW = &H40
    Const HWND_TOPMOST = -1
    Const HWND_NOTOPMOST = -2
    lngFlags = SWP_NOMOVE Or SWP_NOSIZE Or SWP_SHOWWINDOW Or SWP_NOACTIVATE
    SetWindowPos frmPassLock.hWnd, HWND_TOPMOST, 0, 0, 0, 0, lngFlags
End Sub

Public Sub InfFile()
      Dim UserFile As String
End Sub

Public Function CekApaButuhProfBaru() As ApaButuhProfilBaru
    If Not ApaAda(UserProfile) Then
        MsgBox "Nggak ada profil_user.z33...Tulis Password yang baru", vbApplicationModal
        CekApaButuhProfBaru = Yap
    Else
        CekApaButuhProfBaru = Kagak
    End If
End Function

Public Sub Main()
    Dim DesktopdC As Long
    Dim strName As String
    Dim lngBuffer As Long
    Dim HasilTanya As ApaButuhProfilBaru
    App.Title = "Desktop Locker : v1n0z33"
    HasilTanya = CekApaButuhProfBaru()
    BuatProfil = (HasilTanya = Yap)
  
    If HasilTanya <> Yap Then
        PassPadaMemory = AmbilUsrN_DariFile()
    End If
    
    strName = String$(255, 0)
    lngBuffer = GetUserName(strName, Len(strName))
    Load frmPassLock
    frmPassLock.txtUser.Text = strName
    frmPassLock.Show
End Sub