Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/sendke1a/simkeys.frm

Visual Basic Form | 1999-03-10 | 8.7 KB | 281 lines

VERSION 5.00
Begin VB.Form frmSimKeys
   Caption         =   "Send Keys and Mouse Events"
   ClientHeight    =   4725
   ClientLeft      =   3390
   ClientTop       =   2400
   ClientWidth     =   6870
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   4725
   ScaleWidth      =   6870
   Begin VB.CommandButton cmdClickMe
      Caption         =   "Click Me"
      Height          =   435
      Left            =   5520
      TabIndex        =   9
      Top             =   4140
      Width           =   1275
   End
   Begin VB.Timer Timer1
      Left            =   5880
      Top             =   3480
   End
   Begin VB.TextBox txtDelay
      Height          =   315
      Left            =   5520
      TabIndex        =   7
      Text            =   "1"
      Top             =   2880
      Width           =   1215
   End
   Begin VB.TextBox txtTarget
      Height          =   315
      Left            =   120
      TabIndex        =   6
      Top             =   420
      Width           =   5235
   End
   Begin VB.CommandButton cmdCaptureActive
      Caption         =   "Capture Active"
      Height          =   435
      Left            =   5460
      TabIndex        =   5
      Top             =   1860
      Width           =   1335
   End
   Begin VB.CommandButton cmdCaptureAll
      Caption         =   "Capture Screen"
      Height          =   435
      Left            =   5460
      TabIndex        =   4
      Top             =   1380
      Width           =   1335
   End
   Begin VB.CommandButton cmdMouseMove
      Caption         =   "MyMouseMove"
      Height          =   435
      Left            =   5460
      TabIndex        =   3
      Top             =   900
      Width           =   1335
   End
   Begin VB.CommandButton cmdSendKeys
      Caption         =   "MySendKeys"
      Height          =   435
      Left            =   5460
      TabIndex        =   2
      Top             =   420
      Width           =   1335
   End
   Begin VB.TextBox txtSource
      Height          =   315
      Left            =   120
      TabIndex        =   1
      Text            =   "Text to be entered by sendkeys"
      Top             =   60
      Width           =   6675
   End
   Begin VB.PictureBox picTest
      Height          =   3735
      Left            =   120
      ScaleHeight     =   3675
      ScaleWidth      =   5175
      TabIndex        =   0
      Top             =   840
      Width           =   5235
   End
   Begin VB.Label lblDelay
      Caption         =   "Delay (seconds)"
      Height          =   255
      Left            =   5520
      TabIndex        =   8
      Top             =   2580
      Width           =   1155
   End
Attribute VB_Name = "frmSimKeys"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Enum enOP
    enOP_NO = 0
    enOP_SendKeys = 1
    enOP_SendMouse = 2
    enOP_CaptScreen = 3
    enOP_CaptWindow = 4
End Enum
Private menOperation As enOP
Private mbIsWin9x As Boolean
Private Sub Form_Load()
    Dim lRet As Long
    Dim tOSI As OSVERSIONINFO
    tOSI.dwOSVersionInfoSize = Len(tOSI)
    lRet = GetVersionEx(tOSI)
    mbIsWin9x = CBool(tOSI.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS)
End Sub
Private Sub cmdSendKeys_Click()
    Dim lDelay As Long
    If menOperation <> enOP_NO Then
        MsgBox "Wait for prior operation to finish"
        Exit Sub
    End If
    lDelay = Val(txtDelay)
    If lDelay = 0 Then
        txtTarget.SetFocus
        MySendKeys txtSource.Text
    Else
        menOperation = enOP_SendKeys
        Timer1.Interval = lDelay * 1000
        Timer1.Enabled = True
    End If
End Sub
Private Sub cmdMouseMove_Click()
    Dim lDelay As Long
    If menOperation <> enOP_NO Then
        MsgBox "Wait for prior operation to finish"
        Exit Sub
    End If
    lDelay = Val(txtDelay)
    If lDelay = 0 Then
        MyMouseMove
    Else
        menOperation = enOP_SendMouse
        Timer1.Interval = lDelay * 1000
        Timer1.Enabled = True
    End If
End Sub
Private Sub cmdCaptureAll_Click()
    Dim lDelay As Long
    If menOperation <> enOP_NO Then
        MsgBox "Wait for prior operation to finish"
        Exit Sub
    End If
    lDelay = Val(txtDelay)
    If lDelay = 0 Then
        MyCapture
    Else
        menOperation = enOP_CaptScreen
        Timer1.Interval = lDelay * 1000
        Timer1.Enabled = True
    End If
End Sub
Private Sub cmdCaptureActive_Click()
    Dim lDelay As Long
    If menOperation <> enOP_NO Then
        MsgBox "Wait for prior operation to finish"
        Exit Sub
    End If
    lDelay = Val(txtDelay)
    If lDelay = 0 Then
        MyCapture True
    Else
        menOperation = enOP_CaptWindow
        Timer1.Interval = lDelay * 1000
        Timer1.Enabled = True
    End If
End Sub
Private Sub cmdClickMe_Click()
    MsgBox "Button has been clicked"
End Sub
Private Sub timer1_Timer()
    Timer1.Enabled = False
    Select Case menOperation
        Case enOP_SendKeys:
            txtTarget.SetFocus
            MySendKeys txtSource.Text

        Case enOP_SendMouse:    MyMouseMove
        Case enOP_CaptScreen:   MyCapture
        Case enOP_CaptWindow:   MyCapture True
    End Select
    menOperation = enOP_NO
End Sub
' Setting ovbActiveWnd to 1 causes capture of the active window only
Public Sub MyCapture(Optional ByVal ovbActiveWnd As Boolean = False)
    Dim lScanCodeALT As Long
    Dim lSnapParam As Long
    ' translate the virtual-key code into a scan code.
    lScanCodeALT = MapVirtualKey(vbKeyMenu, 0)
    cmdCaptureAll.Enabled = False
    cmdCaptureActive.Enabled = False
    Screen.MousePointer = vbHourglass
    If ovbActiveWnd Then
        keybd_event CByte(vbKeyMenu), CByte(lScanCodeALT), 0, 0
        ' It seems necessary to let this key get processed before
        ' taking the snapshot.
    End If
    ' Why does this work?  Who knows!
    If (Not ovbActiveWnd) And mbIsWin9x Then lSnapParam = 1
    DoEvents    ' These seem necessary to make it reliable
    ' Take the snapshot
    keybd_event CByte(vbKeySnapshot), CByte(lSnapParam), 0, 0
    DoEvents
    picTest.Picture = Clipboard.GetData(vbCFBitmap)
    If ovbActiveWnd Then keybd_event CByte(vbKeyMenu), CByte(lScanCodeALT), KEYEVENTF_KEYUP, 0
    cmdCaptureAll.Enabled = True
    cmdCaptureActive.Enabled = True
    Screen.MousePointer = vbDefault
End Sub
' Try to move the mouse to click the "click me" button
Public Sub MyMouseMove()
    Dim tPOINT As POINTAPI
    Dim lRet As Long
    Dim lScreenX As Long
    Dim lScreenY As Long
    Dim lDestX As Long
    Dim lDestY As Long
    Dim lDistX As Long
    Dim lDistY As Long
    Dim lCurX As Long
    Dim lCurY As Long
    Dim bDone As Boolean
    Dim lPtsPerX As Long
    Dim lPtsPerY As Long
    lScreenX = GetSystemMetrics(SM_CXSCREEN)
    lScreenY = GetSystemMetrics(SM_CYSCREEN)
    ' Get screen coordinates first
    ' 10 by 10 pixels into the button
    tPOINT.x = 10
    tPOINT.y = 10
    lRet = ClientToScreen(cmdClickMe.hwnd, tPOINT)
    If lRet = 0 Then Exit Sub
    ' transform to mousepoints
    lDestX = (tPOINT.x * &HFFFF&) / lScreenX
    lDestY = (tPOINT.y * &HFFFF&) / lScreenY
    ' About how many mouse points per pixel
    lPtsPerX = &HFFFF& / lScreenX
    lPtsPerY = &HFFFF& / lScreenY
    ' Now move it
    Do
        lRet = GetCursorPos(tPOINT)

        ' transform to mpousepoints
        lCurX = (tPOINT.x * &HFFFF&) / lScreenX
        lCurY = (tPOINT.y * &HFFFF&) / lScreenY

        ' calculate distance
        lDistX = lDestX - lCurX
        lDistY = lDestY - lCurY

        If (Abs(lDistX) < 2 * lPtsPerX) And _
                (Abs(lDistY) < 2 * lPtsPerY) Then
            ' Close enough, go the rest of the way
            lCurX = lDestX
            lCurY = lDestY
            bDone = True
        Else
            ' Move closer
            lCurX = lCurX + Sgn(lDistX) * lPtsPerX * 2
            lCurY = lCurY + Sgn(lDistY) * lPtsPerY * 2
        End If
        mouse_event MOUSEEVENTF_ABSOLUTE Or MOUSEEVENTF_MOVE, lCurX, lCurY, 0, 0
        Sleep 5
    Loop While Not bDone
    ' We got there, click the button
    mouse_event MOUSEEVENTF_ABSOLUTE Or MOUSEEVENTF_LEFTDOWN, lCurX, lCurY, 0, 0
    mouse_event MOUSEEVENTF_ABSOLUTE Or MOUSEEVENTF_LEFTUP, lCurX, lCurY, 0, 0
End Sub