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.
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 :)
Monggo, thanks ya dah nulisin sumber
good programming.thx
thanks atas pujianny6a