VB 6 : Otomatis Mengunci Layar Saat user meninggalkan komputer

Beberapa hari yang lalu ada yang bertanya kepada saya di blog tepanya di VISUAL BASIC 6.0 : Pengenalan Form dengan pertanyaan seperti ini ( Edited sehingga lebih mudah di baca ) :

Kakak saya mau bertanya, bagaimana sih cara membuat program yang bisa melakukan Auto Locking ( Penguncian Otomatis ) dengan Visual Basic 6.0 ( VB 6.0 ) ?

Maksud Auto Locking (Penguncian Otomatis ) di sini adalah saat Mouse tidak melakukan aktivitas dan keyboard juga tidak ada aktifitas dalam batas waktu tertentu, maka form login akan muncul dan layar akan terkunci. User tidak akan bisa melakukan aktifitas apapun karena layar sudah terkunci dan sang user harus memasukan id dan password kembali agar dapat melanjutkan aktifitasnya.

Konsep Auto Locking ini sebenarnya prinsipnya adalah seperti Screen Saver, tetapi bedanya di sini yang muncul adalah form login dan kita membutuhkan username dan password untuk kembali. Mohon bantuannya kakak karena saya sudah mencari di google tetapi tidak ketemu. Mohon bantuannya karena untuk bantuan sidang?

Lalu saya menjawab secara algoritma saja

Butlah satu buah timer, dan isi dengan variabel hitung yang nilainya dinaikan terus, terus dicek jika hitung sudah 5 menit, muncul login form

di event keyboard key press buat perintah hitungan = 0

di event mousemove buat perintah hitungan = 0

Nah tampaknya si penanya belum puas dan bertanya lagi,

Saya sudah buat seperti yang kaka bilang. Tetapi hal ini hanya bisa diimplementasikan jika dan hanya jika focus berada di aplikasi yang kita buat saja, lalu bagaimana jika fokusnya berada di luar aplikasi tersebut. Bagaimana caranya agar Visual Basic 6.0 ( VB 6.0 ) menangkap keadaan tersebut, terutama untuk mengetahui bahwa keyboard sedang ditekan ataupun mouse sedang di gerakan, karena posisi mouse dan keyboard tidak berada di aplikasi VB tersebut.

Sata dengar-dengar harus pake fungsi API getcurpos, agar aplikasi auto Locking ini bisa jalan, mohon bantuannya donk kakak.

Terimakasih

Karena saya lumayan sibuk akhir-akhir ini maka saya belum sempat mengerjakan program ini, nah karena sekarang saya waktu jadi saya kerjakan. Saya tidak akan buat layar login karena sebenarnya yang menjadi permasalahan di sini adalah bagaiamana Visual Basic 6.0 bisa mengetahui gerakan Mouse dan Keyboard yang terjadi diluar aplikasi VB, dan bagaimana caranya agar saat Visual Basic 6.0 ( VB 6.0 ) mengetahui hal tersebut terjadi, dia langsung melock layar komputer.

Nah, beginilah caranya.

Langkah 1 :

Buatlah Modul alwaysOnTop ( Modul ini bukan saya buat, tetapi saya dapat dari internet, karena sudah lama saya tidak tau asal linknya ) :

Attribute VB_Name = "alwaysOnTop"
Public Declare Function GetInputState Lib "user32" () As Long
Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Public Declare Function GetKeyboardType Lib "user32" (ByVal nTypeFlag As Long) As Long
Public Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
Public Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function SetActiveWindow Lib "user32" (ByVal hwnd As Long) As Long

Option Explicit
Public 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 Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const HWND_TOP = 0
Public Const HWND_DESKTOP = 0
Public Const HWND_BROADCAST = &HFFFF&
Public Const HWND_BOTTOM = 1
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2

Public Function SetWinPos(iPos As Integer, lHWnd As Long) As Boolean
Dim lWinPos As Long  'A variable to hold the value of
3  'the API window position constant
4  Dim l As Long
5
6 'Use a SELECT CASE to set the value of the
7  'API Window constant
8
9  Select Case iPos
'The window is set to its regular position
Case 0
12 lWinPos = HWND_NOTOPMOST
13 'Set the window always on top
14 Case 1
15 lWinPos = HWND_TOPMOST
16 'You have a bad value; leave the function
17 Case Else
18 Exit Function
19 End Select
20
21 'Run the API SetWindowPos function
22 If SetWindowPos(lHWnd, lWinPos, 0, 0, 0, 0, SWP_NOMOVE _
+ SWP_NOSIZE) Then
23 'If the function is greater than 0 (FALSE), the operation
24 'was successful. Return a True to indicate such.
25 SetWinPos = True
26 End If
27 End Function

Berikutnya adalah Modul Untuk menangkap gerakan mouse dan gerakan key board :

Attribute VB_Name = "tangkapKeyDanMouse"
Public Type POINTAPI
   X As Long
   Y As Long
End Type
Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Setelah itu adalah saatnya Anda Membuat formnya dengan settingan di bawah ini:

VERSION 5.00
Begin VB.Form Form1
  AutoRedraw      =   -1  'True
  BorderStyle     =   0  'None
  Caption         =   "Form1"
  ClientHeight    =   3195
  ClientLeft      =   0
  ClientTop       =   0
  ClientWidth     =   4680
  LinkTopic       =   "Form1"
  MaxButton       =   0   'False
  MinButton       =   0   'False
  ScaleHeight     =   3195
  ScaleWidth      =   4680
  ShowInTaskbar   =   0   'False
  StartUpPosition =   2  'CenterScreen
  WindowState     =   2  'Maximized
  Begin VB.CommandButton Command2
     Caption         =   "Close"
     Height          =   255
     Left            =   2520
     TabIndex        =   1
     Top             =   2400
     Width           =   1935
  End
  Begin VB.CommandButton Command1
     Caption         =   "Matikan Always On Top"
     Height          =   375
     Left            =   2520
     TabIndex        =   0
     Top             =   360
     Width           =   1935
  End
  Begin VB.Timer Timer1
     Interval        =   100
     Left            =   1800
     Top             =   1320
  End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Setelah itu tambahkan script di bawah ini:

'Program ini di buat oleh johan firdaus
'Khusus untuk modul alwaysOnTop saya dapat dari net
'Karena sudah lama sekali lupa siapa yang buat
'Author  : Johan Firdaus
'Blog    : http://johanfirdaus.zo-ka01.com/
'Program : Program yang akan berada dalam keadaan always on top
'          dalam waktu tertentu, cocok di gunakan untuk program login
Dim aktif As Boolean
Dim hitung As Integer
Dim posisiMouse As POINTAPI
Dim keylist

Private Sub Command1_Click()
   aktif = Not aktif
   SetWinPos 0, Me.hwnd
   setCommandCaption
   'Kalo ingin form gak keliatan pas gak
   'Me.Visible = False

End Sub

Private Sub Command2_Click()
   End
End Sub

Private Sub Form_Load()
   aktif = True
   hitung = 0
   posisiMouse.X = 0
   posisiMouse.Y = 0
   setCommandCaption

   keylist = Array(vbKeyLButton, vbKeyRButton, vbKeyCancel, vbKeyMButton, vbKeyBack, _
                 vbKeyTab, vbKeyClear, vbKeyReturn, vbKeyShift, vbKeyControl, _
                 vbKeyMenu, vbKeyPause, vbKeyCapital, vbKeyEscape, _
                 vbKeyPageUp, vbKeyPageDown, vbKeyEnd, vbKeyHome, vbKeyLeft, _
                 vbKeyUp, vbKeyRight, vbKeyDown, vbKeySelect, vbKeyPrint, _
                 vbKeyExecute, vbKeySnapshot, vbKeyInsert, vbKeyDelete, _
                 vbKeyHelp, vbKeyNumlock, vbKeyF1, vbKeyF2, vbKeyF3, vbKeyF4, _
                 vbKeyF5, vbKeyF6, vbKeyF7, vbKeyF8, vbKeyF9, vbKeyF10, vbKeyF11, _
                 vbKeyF12, vbKeyF13, vbKeyF14, vbKeyF15, vbKeyF16, vbKeyNumpad0, _
                 vbKeyNumpad1, vbKeyNumpad2, vbKeyNumpad3, vbKeyNumpad4, vbKeyNumpad5, _
                 vbKeyNumpad6, vbKeyNumpad7, vbKeyNumpad8, vbKeyNumpad9, vbKeyMultiply, _
                 vbKeyAdd, vbKeySeparator, vbKeySubtract, vbKeyDecimal, vbKeyDivide)

End Sub

Private Sub Timer1_Timer()
   On Error Resume Next

   If aktif Then
       SetActiveWindow Me.hwnd
       SetWinPos 1, Me.hwnd
       Me.Visible = True

   Else

       Dim userAktif As Boolean
       Dim tPA As POINTAPI

       userAktif = False

       'Mendapatkan posisi cursor
       GetCursorPos tPA

       'Cek posisi kursor
       If (posisiMouse.X <> tPA.X) Or (posisiMouse.Y <> tPA.Y) Then
           userAktif = True
           posisiMouse.X = tPA.X
           posisiMouse.Y = tPA.Y
       End If

       For i = 0 To 61

           'Cek keyboard
           Key = GetAsyncKeyState(keylist(i))

           'Jika Key board di tekan
           If Key = -32767 Then

               userAktif = True
           End If
       Next i

       For i = 0 To 127

           'Cek keyboard
           Key = GetAsyncKeyState(i)

           'Jika Key board di tekan
           If Key = -32767 Then

               userAktif = True
           End If
       Next i

       If userAktif Then
           hitung = 0
       End If
       hitung = hitung + 1

       'MAXIMAL ADA 5 DETIK IDLE
       If hitung > 50 Then
           hitung = 0
           aktif = True
           setCommandCaption
       End If
   End If

End Sub

Sub setCommandCaption()
   If Not aktif Then
       Command1.Caption = "Aktifkan Always On Top"
       Me.BackColor = vbBlue

   Else
       Command1.Caption = "Matikan Always On Top"
       Me.BackColor = vbRed
   End If
End Sub

Bagi yang mau praktis donlod aja langsung scriptnya di sini.

Untuk yang sudah di perbaiki file nya silakan download di sini, yang di atas masih versi pertama yang ada errornya.

Ok itu saja semoga bermanfaat.

1. Nawazaki says:

   March 9, 2010 at 3:25 pm (Edit)

   waw bagus! boleh minta ya? saya ada rencana mau bikin proyek pemilihan ketua osis pake vb nih. pas butuh code ini .boleh ya:) sumber ditulis ko :)
2. Johan Firdaus says:

   March 9, 2010 at 7:18 pm (Edit)

   Monggo, thanks ya dah nulisin sumber
3. hadisworodejavu says:

   July 25, 2010 at 4:14 am (Edit)

   good programming.thx
4. Johan Firdaus says:

   July 25, 2010 at 12:52 pm (Edit)

   thanks atas pujianny6a