RE: [Programmer-VB] deteksi aktif/non aktif form

Fri, 13 Jan 2006 02:57:23 -0800

Saya ada contoh program SystemHook, written by Arkadiy Olovyannikov. mgkn bisa membantu.
contoh coding ini terdiri dari coding untuk class module (cSystemHook) dan MDIForm
Silahkan modifikasi pada module Timer1_Timer() sesuai dengan keperluan.
 
Coding pada cSystemHook:
 
Option Explicit
' System wide keyboard and mouse hook
'
' Written by Arkadiy Olovyannikov ([EMAIL PROTECTED]
' Copyright 2001 by Arkadiy Olovyannikov
'
' This software is FREEWARE. You may use it as you see fit for
' your own projects but you may not re-sell the original or the
' source code.
'
' No warranty express or implied, is given as to the use of this
' program. Use at your own risk.
' Thanks to Johnny Jorgensen ([EMAIL PROTECTED]) for
' fixing some bugs.
Public Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event SystemKeyDown(KeyCode As Integer)
Public Event SystemKeyUp(KeyCode As Integer)
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function GetAsyncKeyState% Lib "user32" (ByVal vKey As Long)
Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Const WM_RBUTTONDBLCLK = &H206
Private Const WM_MBUTTONDOWN = &H207
Private Const WM_MBUTTONUP = &H208
Private Const WM_MBUTTONDBLCLK = &H209
Private Const WM_MOUSEWHEEL = &H20A
Private Const WM_SYSTEMKEYDOWN = &H104
Private Const WM_SYSTEMKEYUP = &H105
Private Const WH_JOURNALRECORD = 0
Private Const WH_GETMESSAGE = 3
Private Type EVENTMSG
     wMsg As Long
     lParamLow As Long
     lParamHigh As Long
     msgTime As Long
     hWndMsg As Long
End Type
Dim EMSG As EVENTMSG
Public Function SetHook() As Boolean
   If hJournalHook = 0 Then hJournalHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf JournalRecordProc, App.hInstance, 0)
   If hAppHook = 0 Then hAppHook = SetWindowsHookEx(WH_GETMESSAGE, AddressOf AppHookProc, App.hInstance, App.ThreadID)
   SetHook = True
End Function
Public Sub RemoveHook()
   UnhookWindowsHookEx hAppHook
   UnhookWindowsHookEx hJournalHook
    hJournalHook = 0
    hAppHook = 0
End Sub
Private Sub Class_Initialize()
  SHptr = ObjPtr(Me)
End Sub
Private Sub Class_Terminate()
  If hJournalHook Or hAppHook Then RemoveHook
End Sub
Friend Function FireEvent(ByVal lParam As Long)
  Dim i%, j%, k%
  Dim s As String
  If lParam = WM_CANCELJOURNAL Then
     hJournalHook = 0
     SetHook
     Exit Function
  End If
 
  CopyMemory EMSG, ByVal lParam, Len(EMSG)
  Select Case EMSG.wMsg
    Case WM_KEYDOWN
         j = 0
         If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1)        'fixed by JJ
         If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2)      'fixed by JJ
         If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4)         'fixed by JJ
         s = Hex(EMSG.lParamLow)
         k = (EMSG.lParamLow And &HFF)
         RaiseEvent KeyDown(k, j)
         s = Left$(s, 2) & Right$("00" & Hex(k), 2)               'fixed by JJ
         EMSG.lParamLow = CLng("&h" & s)
         CopyMemory ByVal lParam, EMSG, Len(EMSG)
    Case WM_KEYUP
         j = 0                                                    'fixed by JJ
         If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1)        'fixed by JJ
         If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2)      'fixed by JJ
         If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4)         'fixed by JJ
         s = Hex(EMSG.lParamLow)
         k = (EMSG.lParamLow And &HFF)
         RaiseEvent KeyUp(k, j)
         s = Left$(s, 2) & Right$("00" & Hex(k), 2)               'fixed by JJ
         EMSG.lParamLow = CLng("&h" & s)
         CopyMemory ByVal lParam, EMSG, Len(EMSG)
    Case WM_MOUSEMOVE
         i = 0                                                    'fixed by JJ
         If GetAsyncKeyState(vbKeyLButton) Then i = (i Or 1)      'fixed by JJ
         If GetAsyncKeyState(vbKeyRButton) Then i = (i Or 2)      'fixed by JJ
         If GetAsyncKeyState(vbKeyMButton) Then i = (i Or 4)      'fixed by JJ
         j = 0                                                    'fixed by JJ
         If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1)        'fixed by JJ
         If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2)      'fixed by JJ
         If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4)         'fixed by JJ
         RaiseEvent MouseMove(i, j, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh))
    Case WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN
         i = 0                                                    'fixed by JJ
         If GetAsyncKeyState(vbKeyShift) Then i = (i Or 1)        'fixed by JJ
         If GetAsyncKeyState(vbKeyControl) Then i = (i Or 2)      'fixed by JJ
         If GetAsyncKeyState(vbKeyMenu) Then i = (i Or 4)         'fixed by JJ
         RaiseEvent MouseDown(2 ^ ((EMSG.wMsg - 513) / 3), i, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh))
    Case WM_LBUTTONUP, WM_RBUTTONUP, WM_MBUTTONUP
         i = 0                                                    'fixed by JJ
         If GetAsyncKeyState(vbKeyShift) Then i = (i Or 1)        'fixed by JJ
         If GetAsyncKeyState(vbKeyControl) Then i = (i Or 2)      'fixed by JJ
         If GetAsyncKeyState(vbKeyMenu) Then i = (i Or 4)         'fixed by JJ
         RaiseEvent MouseUp(2 ^ ((EMSG.wMsg - 514) / 3), i, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh))
    Case WM_SYSTEMKEYDOWN
         s = Hex(EMSG.lParamLow)
         k = (EMSG.lParamLow And &HFF)
         If k <> vbKeyMenu Then RaiseEvent SystemKeyDown(k)
         s = Left$(s, 2) & Right$("00" & Hex(k), 2)               'fixed by JJ
         EMSG.lParamLow = CLng("&h" & s)
         CopyMemory ByVal lParam, EMSG, Len(EMSG)
    Case WM_SYSTEMKEYUP
         s = Hex(EMSG.lParamLow)
         k = (EMSG.lParamLow And &HFF)
         If k <> vbKeyMenu Then RaiseEvent SystemKeyUp(k)
         s = Left$(s, 2) & Right$("00" & Hex(k), 2)               'fixed by JJ
         EMSG.lParamLow = CLng("&h" & s)
         CopyMemory ByVal lParam, EMSG, Len(EMSG)
    Case Else
  End Select
End Function
 
---------=================================------------
Coding di Form MDIForm:
 
Option Explicit
Dim WithEvents sh As cSystemHook
Private Sub MDIForm_Load()
   'Ingat Ingat
   'Untuk Sementara jgn dijalanin dulu, karena akan menganggu proses coding
   '=================================================
  
   Set sh = New cSystemHook
   sh.SetHook
End Sub
Private Sub MDIForm_Unload(Cancel As Integer)
    sh.RemoveHook
    Set sh = Nothing
End Sub

Private Sub sh_KeyDown(KeyCode As Integer, Shift As Integer)
   SetTtlTimer
End Sub
Private Sub sh_KeyUp(KeyCode As Integer, Shift As Integer)
   SetTtlTimer
End Sub
Private Sub sh_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  SetTtlTimer
End Sub
Private Sub sh_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  SetTtlTimer
End Sub
Private Sub sh_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  SetTtlTimer
End Sub
Private Sub sh_SystemKeyDown(KeyCode As Integer)
   If KeyCode = vbKeyF4 Then KeyCode = 0
   SetTtlTimer
End Sub
Private Function CharFromKeyCode(k As Integer) As String
   Dim s As String
   Select Case k
          Case vbKeyBack:     s = "BackSpace"
          Case vbKeyTab:      s = "Tab"
          Case vbKeyClear:    s = "Clear"
          Case vbKeyReturn:   s = "Enter"
          Case vbKeyShift:    s = "Shift"
          Case vbKeyControl:  s = "Ctrl"
          Case vbKeyMenu:     s = "Alt"
          Case vbKeyPause:    s = "Pause"
          Case vbKeyCapital:  s = "CapsLock"
          Case vbKeyEscape:   s = "ESC"
          Case vbKeySpace:    s = "SPACEBAR"
          Case vbKeyPageUp:   s = "PAGE UP"
          Case vbKeyPageDown: s = "PAGE DOWN"
          Case vbKeyEnd:      s = "END"
          Case vbKeyHome:     s = "HOME"
          Case vbKeyLeft:     s = "LEFT ARROW"
          Case vbKeyUp:       s = "UP ARROW"
          Case vbKeyRight:    s = "RIGHT ARROW"
          Case vbKeyDown:     s = "DOWN ARROW"
          Case vbKeySelect:   s = "SELECT"
          Case vbKeyPrint:    s = "PRINT SCREEN"
          Case vbKeyExecute:  s = "EXECUTE"
          Case vbKeySnapshot: s = "SNAPSHOT"
          Case vbKeyInsert:   s = "INS"
          Case vbKeyDelete:   s = "DEL"
          Case vbKeyHelp:     s = "HELP"
          Case vbKeyNumlock:  s = "NUM LOCK"
          Case vbKey0 To vbKey9: s = Chr$(k)
          Case vbKeyA To vbKeyZ: s = Chr$(MapVirtualKeyEx(k, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0))))
          Case vbKeyF1 To vbKeyF16: s = "F" & CStr(k - 111)
          Case vbKeyNumpad0 To vbKeyNumpad9: s = "Numpad " & CStr(k - 95)
          Case vbKeyMultiply: s = "Numpad {*}"
          Case vbKeyAdd: s = "Numpad {+}"
          Case vbKeySeparator: s = "Numpad {ENTER}"
          Case vbKeySubtract: s = "Numpad {-}"
          Case vbKeyDecimal: s = "Numpad {.}"
          Case vbKeyDivide: s = "Numpad {/}"
          Case Else
               s = Chr$(MapVirtualKeyEx(k, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0))))
   End Select
   CharFromKeyCode = "[" & s & " key]"
End Function
Sub SetTtlTimer()
    TtlTimer = 0
End Sub
Private Sub Timer1_Timer()
    TtlTimer = TtlTimer + 1
    If TtlTimer = (1 * 60) Then WaktuHabis
    If TtlTimer = 15 Then WaktuHabis
End Sub
Sub WaktuHabis()
    TtlTimer = 0
On Error Resume Next
    End
End Sub
 
 
 
Regards,
Yulianto
KwetChiro
 


Heru Rahadyan <[EMAIL PROTECTED]> wrote:
alo, coba bantu ya .. tp dgn cara yg kuno hehehe
 
1. mungkin bisa pake timer di tiap2 form,
a. buat variable Aktif as date di bagian generalnya
b. aktifkan property keypreview di form tsb
c. buat timer dgn durasi tertentu
d. setiap kali ada aktifitas yg tertangkap di form buat prosedur Aktif = now
e. di timer buat prosedur jika now - aktif > 5 menit then form1.windowstate=1 (minimize)
f. prosedur aktif = now bisa jg dilakukan saat form got focus, deactivate dll dst sesuai kebutuhan
 
2. klo pake MDI child, timer bisa ditaruh di MDI Parent-nya saja
a. buat public variable di modul dgn nama dForm1 as date, dForm2 as date dst
b. setiap kali ada aktivitas di form maka buat prosedur -misal- dForm2 = now (lihat poin 1)
c. di timer buat prosedur utk mengecek variabel dForm satu2, misal, jika now - dForm1 > 5 menit maka ... dst dll
 
3. cara canggih, nah ini yg gwe blm tau hehehe

4. cuman yg perlu ditentukan adalah definisi dr tdk ada proses atau tdk aktif itu sendiri

-----Original Message-----
From: [email protected] [mailto:[email protected]] On Behalf Of iyan_graduated
Sent: Thursday, January 12, 2006 7:26 PM
To: [email protected]
Subject: [Programmer-VB] deteksi aktif/non aktif form


Buat Vb'ers, Saya mau tanya bagaimana coding yang baik untuk
mendeteksi bila dalam interval tertentu (misal. 5 menit) form tidak
ada proses atau tidak aktif, maka form automatis akan minimized dengan
sendirinya..
mirip2 expired time gitu....


Yahoo! Photos
Ring in the New Year with Photo Calendars. Add photos, events, holidays, whatever.

Wahana Programmer Groups Links

<*> Untuk mengunjungi sponsor milis ini, klik link berikut:
    http://wahanaprogrammer.net

<*> Untuk menghubungi owner milis ini, kirim email ke:
    [EMAIL PROTECTED]

<*> Konsultasi pemrogramman bisa chat disini:
    Yahoo! Messenger: wahanaprogrammer



SPONSORED LINKS
Programmer Indonesia Basic programming language
Computer programming languages Programming languages Java programming language

YAHOO! GROUPS LINKS



Kirim email ke