Public Class FormMain
Public WithEvents KeyboardFocus As New SystemEvent(SystemEvents.EVENT_OBJECT_FOCUS)
Public WithEvents xListener As New UdpKeyListener
Public WithEvents InputHook As New RawInputHook
Public LocalProcesses As Processes = Nothing
Private KeySetupEnabledAdd As Boolean = False
Private KeySetupEnabledRemove As Boolean = False
Private m_Enabled As Boolean = True
Private m_filo As New UdpKeyBufferFILO(6)
Private LocalManager As New UdpKeyPostManager
Public Sub OnKeyboardFocusChanged(ByVal hWinEventHook As IntPtr, ByVal eventType As UInteger, ByVal hwnd As IntPtr, ByVal idObject As Integer, ByVal idChild As Integer, ByVal dwEventThread As UInteger, ByVal dwmsEventTime As UInteger) Handles KeyboardFocus.SystemEvent
'blah blah blah
End Sub
Public Sub cmAppNamesUpdate(ByVal items As String())
cmAppNames.Items.Clear()
For Each item As String In items
cmAppNames.Items.Add(item)
Next
End Sub
Public Sub cmAppTitlesUpdate(ByVal items As String())
cmAppTitles.Items.Clear()
For Each item As String In items
cmAppTitles.Items.Add(item)
Next
End Sub
Public Sub UdpMessageReceived(ByVal Sender As Object, ByVal msgCount As Integer, ByVal iRet As Integer, ByVal msg As String) Handles xListener.OnMessageReceived
Dim thisKey As New UdpKeyInfo(msg)
If thisKey.Valid Then
If thisKey.Command() = &H2222 Then
If Not lbKeys.Items.Contains(InputHook.FriendlyKeyname(thisKey.VKey)) Then
lbKeys.Items.Add(InputHook.FriendlyKeyname(thisKey.VKey))
End If
ElseIf thisKey.Command() = &H3333 Then
If lbKeys.Items.Contains(InputHook.FriendlyKeyname(thisKey.VKey)) Then
lbKeys.Items.Remove(InputHook.FriendlyKeyname(thisKey.VKey))
End If
ElseIf thisKey.Command() = &H5555 Then
Dim key As String = MachineID.ID & CStr(thisKey.PID)
If lvPIDS.Items.ContainsKey(key) Then
lvPIDS.Items.RemoveByKey(key)
End If
ElseIf thisKey.Command() = &H4444 Then
Dim key As String = MachineID.ID & CStr(thisKey.PID)
Dim x As System.Windows.Forms.ListViewItem = lvPIDS.Items.Add(key, MachineID.ID, "")
x.SubItems.Add(CStr(thisKey.PID))
x.SubItems.Add(CStr(0))
x.SubItems.Add(CStr(0))
x.SubItems.Add(CStr(0))
lvPIDS.Items(key).Checked = True
ElseIf Not LocalProcesses Is Nothing AndAlso LocalProcesses.length > 0 AndAlso m_Enabled Then
For i As Integer = 0 To LocalProcesses.length - 1
If Not LocalProcesses.process(i) Is Nothing Then
If ((thisKey.MachineID = MachineID.ID) AndAlso (LocalProcesses.process(i).MainWindowHandle = thisKey.ForegroundWindow)) Then
'this is the app (PID) that received the original key; so skip sending the key to it
Else
'Manager.AddMessage(LocalProcesses.process(i).MainWindowHandle, thisKey.Message, New IntPtr(thisKey.VKey), New IntPtr(lParam))
LocalManager.AddPostMessage(LocalProcesses.process(i).MainWindowHandle, thisKey)
End If
End If
Next
End If
End If
End Sub
Public Sub InputFromKeyboard(ByVal riHeader As RAWINPUTHEADER, ByVal riKeyboard As RAWKEYBOARD) Handles InputHook.OnRawInputFromKeyboard
Dim s As String = "" 's = s & Chr(13) & Chr(10)
s = s & "MCode: 0x" & riKeyboard.MakeCode.ToString("X4")
s = s & " VKey: 0x" & riKeyboard.VKey.ToString("X4")
s = s & " Mssg: 0x" & riKeyboard.Message.ToString("X4")
s = s & " Flag: 0x" & riKeyboard.Flags.ToString("X4")
's = s & " Rsrvd: 0x" & riKeyboard.Reserved.ToString("X4")
's = s & " ExInf: 0x" & riKeyboard.ExtraInformation.ToString("X8")
s = s & " Devc: 0x" & riHeader.hDevice.ToString("X4")
's = s & " .Size: 0x" & riHeader.dwSize.ToString("X8")
's = s & " .Type: 0x" & riHeader.dwType.ToString("X8")
's = s & " wPara: 0x" & riHeader.wParam.ToString("X8")
'Debug.WriteLine(s)
s = s & Chr(13) & Chr(10)
tbLog.Text += s
Dim Command As Integer = 0
Dim PID As Integer = 0
If KeySetupEnabledAdd Then
Command = &H2222
ElseIf KeySetupEnabledRemove Then
Command = &H3333
End If
Dim doSendMessage As Boolean = False
Dim ForegroundWindow As IntPtr = KeyboardFocus.Hwnd 'InputHook.GetForegroundWindow()
If KeySetupEnabledAdd OrElse KeySetupEnabledRemove Then
doSendMessage = True
End If
Dim thisKey As New UdpKeyInfo(MachineID.ID, riHeader.hDevice, riKeyboard.MakeCode, riKeyboard.VKey, CInt(riKeyboard.Message), riKeyboard.Flags, Command, PID, ForegroundWindow)
If (LocalProcesses.length > 0) Then
For i As Integer = 0 To LocalProcesses.length - 1
If (riKeyboard.Message And CUInt(1)) = 0 Then 'keydown event
If ((LocalProcesses.process(i).MainWindowHandle = ForegroundWindow) AndAlso lbKeys.Items.Contains(InputHook.FriendlyKeyname(riKeyboard.VKey)) AndAlso m_Enabled) Then
doSendMessage = True
End If
Else 'keyup event (let all keyup events through to be tested against keydown events; prevent keys from being stuck if app with the keyboard/foreground focus get switched after keydown and before keyup)
doSendMessage = True
End If
Next
End If
If doSendMessage Then
If (riKeyboard.Message And CUInt(1)) = 0 Then 'key down event
m_filo.Push(thisKey)
Else 'key up event; make sure our keyup event has the same amnestyAppPID as the keydown event (prevent keys from being stuck if app with the keyboard/foreground focus get switched after keydown and before keyup)
Dim pushedKey As UdpKeyInfo = m_filo.Pop(thisKey)
If Not pushedKey Is Nothing Then
thisKey.ForegroundWindow = pushedKey.ForegroundWindow
Else
doSendMessage = False
End If
End If
If doSendMessage Then
UdpKeyListener.Send(thisKey.ToString)
End If
End If
End Sub
Private Sub lbApps_SelectedIndexChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles lbAppNames.SelectedIndexChanged, lbAppTitles.SelectedIndexChanged
If sender.GetType Is GetType(System.Windows.Forms.CheckedListBox) Then
Dim oName As Object = lbAppNames.SelectedItem
If ((Not oName Is Nothing) AndAlso (oName.GetType Is GetType(String))) AndAlso DirectCast(sender, System.Windows.Forms.CheckedListBox).Name.Equals("lbAppNames") Then
Dim sName As String = CStr(oName).Trim
tbAppName.Text = sName
tbAppTitle.Text = ""
End If
Dim oTitle As Object = lbAppTitles.SelectedItem
If ((Not oTitle Is Nothing) AndAlso (oTitle.GetType Is GetType(String))) AndAlso DirectCast(sender, System.Windows.Forms.CheckedListBox).Name.Equals("lbAppTitles") Then
Dim sTitle As String = CStr(oTitle).Trim
tbAppName.Text = ""
tbAppTitle.Text = sTitle
End If
End If
End Sub
Private Sub btnRemove_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnRemove.Click
'Dim s As String = tbAppName.Text & New String(" ", 31 - tbAppName.Text.Length) & tbAppTitle.Text
Dim sName As String = tbAppName.Text.Trim
Dim sTitle As String = tbAppTitle.Text.Trim
If lbAppNames.Items.Contains(sName) AndAlso sName.Length > 0 Then
lbAppNames.Items.Remove(sName)
LocalProcesses.RemoveProcessName(sName)
End If
If lbAppTitles.Items.Contains(sTitle) AndAlso sTitle.Length > 0 Then
lbAppTitles.Items.Remove(sTitle)
LocalProcesses.RemoveProcessTitle(sTitle)
End If
End Sub
Private Sub btnAdd_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnAdd.Click
'Dim s As String = tbAppName.Text & New String(" ", 31 - tbAppName.Text.Length) & tbAppTitle.Text
Dim sName As String = tbAppName.Text.Trim
Dim sTitle As String = tbAppTitle.Text.Trim
If Not lbAppNames.Items.Contains(sName) AndAlso sName.Length > 0 Then
lbAppNames.Items.Add(sName)
lbAppNames.SetItemChecked(lbAppNames.Items.IndexOf(sName), True)
LocalProcesses.AddProcessName(sName)
End If
If Not lbAppTitles.Items.Contains(sTitle) AndAlso sTitle.Length > 0 Then
lbAppTitles.Items.Add(sTitle)
lbAppTitles.SetItemChecked(lbAppTitles.Items.IndexOf(sTitle), True)
LocalProcesses.AddProcessTitle(sTitle)
End If
End Sub
Public Sub ProcessClosedEvent(ByVal processId As Integer)
Dim msg As String = MachineID.ID & ",&H0000,&H0000,&H0000,&H0000,&H0000,&H5555,&H" & processId.ToString("X4") & ",&H0000"
UdpKeyListener.Send(msg)
End Sub
Public Sub ProcessOpenedEvent(ByVal processId As Integer)
Dim msg As String = MachineID.ID & ",&H0000,&H0000,&H0000,&H0000,&H0000,&H4444,&H" & processId.ToString("X4") & ",&H0000"
UdpKeyListener.Send(msg)
End Sub
Private Sub FormMain_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Persist.Load("3cb83f25-8baa-4dc2-8976-a765baabcc2b", CType(lbAppNames, Object))
Persist.Load("d706522d-021d-44c5-bb34-0c46eac09d31", CType(lbAppTitles, Object))
Persist.Load("20357ea8-db8d-45a9-9905-af9e50638638", CType(lbKeys, Object))
LocalProcesses = New Processes(CheckedList(lbAppNames), CheckedList(lbAppTitles))
AddHandler LocalProcesses.ProcessOpenedEvent, AddressOf Me.ProcessOpenedEvent
AddHandler LocalProcesses.ProcessClosedEvent, AddressOf Me.ProcessClosedEvent
AddHandler LocalProcesses.ProcessListChangedNames, AddressOf Me.cmAppNamesUpdate
AddHandler LocalProcesses.ProcessListChangedTitles, AddressOf Me.cmAppTitlesUpdate
End Sub
Private Sub FormMain_FormClosing(ByVal sender As System.Object, ByVal e As System.Windows.Forms.FormClosingEventArgs) Handles MyBase.FormClosing
Persist.Save("3cb83f25-8baa-4dc2-8976-a765baabcc2b", CType(lbAppNames, Object))
Persist.Save("d706522d-021d-44c5-bb34-0c46eac09d31", CType(lbAppTitles, Object))
Persist.Save("20357ea8-db8d-45a9-9905-af9e50638638", CType(lbKeys, Object))
'786aff08-fdcb-48cd-a797-17236b25f473
'ba53bca7-d269-4f33-a794-8204be9dfed7
'5418c45f-eac0-4172-a5e0-6eee8cc302d6
'd667c8b0-5ef8-40b7-a84f-6335f2e88e8d
'b8163ecb-f429-439f-bd56-1e44198b56ce
'a55e6fae-d6f7-4436-820d-94f482f95d73
'45bba7ab-b443-4fb8-b78b-04f30b7adee4
'52f12d79-d8b2-412b-bda7-e53bd970d150
'237824e6-94fb-481a-b5c6-791d3631c1b6
'28ef19d8-ab5c-487b-83a6-ccaed409d59a
'052cb727-6a01-4377-bd6e-bb45fbb1a87c
'Debug.WriteLine(System.Guid.NewGuid.ToString())
End Sub
Private Function CheckedList(ByVal Sender As CheckedListBox) As System.Collections.ArrayList
Dim result As New System.Collections.ArrayList
For i As Integer = 0 To Sender.Items.Count - 1
If Sender.Items(i).GetType Is GetType(String) Then
If Sender.CheckedIndices.Contains(i) Then
result.Add(Sender.Items(i))
End If
End If
Next
Return result
End Function
Private Sub lbAppNames_ItemCheck(ByVal sender As System.Object, ByVal e As System.Windows.Forms.ItemCheckEventArgs) Handles lbAppNames.ItemCheck
Debug.WriteLine("")
End Sub
Private Sub Panel4_MouseHover(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Panel4.MouseHover
ToolStripStatusLabel3.Text = "PRESS A KEY TO ADD IT TO THE LIST"
KeySetupEnabledAdd = True
End Sub
Private Sub Panel4_MouseLeave(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Panel4.MouseLeave
ToolStripStatusLabel3.Text = ""
KeySetupEnabledAdd = False
End Sub
Private Sub Panel5_MouseHover(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Panel5.MouseHover
ToolStripStatusLabel3.Text = "PRESS A KEY TO REMOVE IT TO THE LIST"
KeySetupEnabledRemove = True
End Sub
Private Sub Panel5_MouseLeave(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Panel5.MouseLeave
ToolStripStatusLabel3.Text = ""
KeySetupEnabledRemove = False
End Sub
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnEnabled.Click
If m_Enabled Then
Me.Text = Me.Text.Replace(" - Enabled", " - Disabled")
StatusStrip1.BackColor = Color.DarkRed
btnEnabled.ImageIndex = 1
m_Enabled = False
Else
Me.Text = Me.Text.Replace(" - Disabled", " - Enabled")
StatusStrip1.BackColor = Color.DarkGreen
btnEnabled.ImageIndex = 0
m_Enabled = True
End If
End Sub
Private Sub AppTitle_MouseHover(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles tbAppTitle.MouseHover
ToolStripStatusLabel3.Text = ""
End Sub
Private Sub AppTitle_MouseLeave(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles tbAppTitle.MouseLeave
ToolStripStatusLabel3.Text = ""
End Sub
Private Sub AppName_MouseHover(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles tbAppName.MouseHover
ToolStripStatusLabel3.Text = ""
End Sub
Private Sub AppName_MouseLeave(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles tbAppName.MouseLeave
ToolStripStatusLabel3.Text = ""
End Sub
Private Sub cmAppTitles_ItemClicked(ByVal sender As System.Object, ByVal e As System.Windows.Forms.ToolStripItemClickedEventArgs) Handles cmAppTitles.ItemClicked
tbAppTitle.Text = e.ClickedItem.Text
tbAppName.Text = ""
End Sub
Private Sub cmAppNames_ItemClicked(ByVal sender As System.Object, ByVal e As System.Windows.Forms.ToolStripItemClickedEventArgs) Handles cmAppNames.ItemClicked
tbAppName.Text = e.ClickedItem.Text
tbAppTitle.Text = ""
End Sub
End Class
Submit an article or tip