Dan Appleman's Visual Bas…s Guide to the Win32 API/Dan.Applmans.Visual.Basic.5.0.Programmers.Guide.To.The.Win32.API.1997.Ziff-Davis.Press.CD/VB5PG32.mdf/vbpg32/samples4/ch06/ex6a.frm

Visual Basic Form | 1996-11-20 | 12.7 KB | 370 lines

VERSION 4.00
Begin VB.Form frmCh6
   Caption         =   "Ch.6 Extra Function Examples"
   ClientHeight    =   3420
   ClientLeft      =   2625
   ClientTop       =   1680
   ClientWidth     =   4575
   Height          =   3825
   Left            =   2565
   LinkTopic       =   "Form1"
   ScaleHeight     =   228
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   305
   Top             =   1335
   Width           =   4695
   Begin VB.PictureBox picHolder
      Height          =   315
      Index           =   2
      Left            =   3240
      Picture         =   "EX6A.frx":0000
      ScaleHeight     =   285
      ScaleWidth      =   405
      TabIndex        =   16
      Top             =   3060
      Visible         =   0   'False
      Width           =   435
   End
   Begin VB.PictureBox picHolder
      Height          =   315
      Index           =   1
      Left            =   2880
      Picture         =   "EX6A.frx":0442
      ScaleHeight     =   285
      ScaleWidth      =   405
      TabIndex        =   15
      Top             =   3060
      Visible         =   0   'False
      Width           =   435
   End
   Begin VB.PictureBox picHolder
      Height          =   315
      Index           =   0
      Left            =   2580
      Picture         =   "EX6A.frx":0884
      ScaleHeight     =   285
      ScaleWidth      =   405
      TabIndex        =   14
      Top             =   3060
      Visible         =   0   'False
      Width           =   435
   End
   Begin VB.Frame fraControlPanel
      Caption         =   "Control Panel:"
      Height          =   1095
      Left            =   60
      TabIndex        =   7
      Top             =   2100
      Width           =   4395
      Begin VB.HScrollBar scrDoubleClick
         Height          =   255
         LargeChange     =   15
         Left            =   840
         Max             =   0
         Min             =   -100
         TabIndex        =   11
         Top             =   480
         Width           =   2415
      End
      Begin VB.PictureBox pctDoubleClick
         AutoSize        =   -1  'True
         Height          =   510
         Left            =   3360
         Picture         =   "EX6A.frx":0CC6
         ScaleHeight     =   480
         ScaleWidth      =   480
         TabIndex        =   10
         Top             =   300
         Width           =   510
      End
      Begin VB.Label lblDC1
         Caption         =   "Slow"
         Height          =   195
         Index           =   1
         Left            =   840
         TabIndex        =   13
         Top             =   720
         Width           =   375
      End
      Begin VB.Label lblDC1
         Caption         =   "Fast"
         Height          =   195
         Index           =   0
         Left            =   2940
         TabIndex        =   12
         Top             =   720
         Width           =   375
      End
      Begin VB.Label lblDoubleClick
         Caption         =   "0.75 ms"
         Height          =   255
         Left            =   180
         TabIndex        =   9
         Top             =   480
         Width           =   615
      End
      Begin VB.Label Label1
         Caption         =   "Double Click Time:"
         Height          =   195
         Left            =   120
         TabIndex        =   8
         Top             =   240
         Width           =   1515
      End
   End
   Begin VB.Frame fraCursor
      Caption         =   "Cursor Options:"
      Height          =   1935
      Left            =   60
      TabIndex        =   0
      Top             =   60
      Width           =   4395
      Begin VB.PictureBox pctCursor
         ForeColor       =   &H000000FF&
         Height          =   1575
         Left            =   180
         ScaleHeight     =   103
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   155
         TabIndex        =   4
         Top             =   240
         Width           =   2355
         Begin VB.TextBox txtCaret
            Height          =   315
            Left            =   60
            TabIndex        =   5
            Text            =   "Type in this text box"
            Top             =   420
            Width           =   2115
         End
         Begin VB.Label lblClipInfo
            Caption         =   "Click the picturebox to stop  cursor clipping."
            Height          =   375
            Left            =   60
            TabIndex        =   6
            Top             =   1080
            Visible         =   0   'False
            Width           =   2175
         End
      End
      Begin VB.CommandButton cmdClip
         Caption         =   "&Clip Cursor"
         Height          =   495
         Left            =   2640
         TabIndex        =   3
         Top             =   1320
         Width           =   1575
      End
      Begin VB.CommandButton cmdSetPos
         Caption         =   "Set Cursor &Position"
         Height          =   495
         Left            =   2640
         TabIndex        =   2
         Top             =   780
         Width           =   1575
      End
      Begin VB.CommandButton cmdHide
         Caption         =   "&Hide Cursor"
         Height          =   495
         Left            =   2640
         TabIndex        =   1
         Top             =   240
         Width           =   1575
      End
   End
Attribute VB_Name = "frmCh6"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim dl&, fCHidden&, fCClipped&, fTxtHidIt&
'**********************************
'**  Constant Definitions:
#If Win32 Then
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Const EWX_POWEROFF = 8
Const VK_NUMLOCK = 90
Const VK_SCROLL = 91
Const VK_CAPITAL = 14
Private Const VER_PLATFORM_WIN32_NT& = 2
Private Const VER_PLATFORM_WIN32_WINDOWS& = 1
Private Const SPIF_UPDATEINIFILE& = &H1
Private Const SPIF_SENDWININICHANGE& = &H2
#End If 'WIN32
'**********************************
'**  Type Definitions:
#If Win32 Then
Private Type POINTAPI
    x As Long
    Y As Long
End Type
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
'Private Type SYSTEM_INFO
'        dwOemID As Long
'        dwPageSize As Long
'        lpMinimumApplicationAddress As Long
'        lpMaximumApplicationAddress As Long
'        dwActiveProcessorMask As Long
'        dwNumberOrfProcessors As Long
'        dwProcessorType As Long
'        dwAllocationGranularity As Long
'        dwReserved As Long
'End Type
Private Type SYSTEM_INFO
        dwOemID As Long
        dwPageSize As Long
        lpMinimumApplicationAddress As Long
        lpMaximumApplicationAddress As Long
        dwActiveProcessorMask As Long
        dwNumberOfProcessors As Long
        dwProcessorType As Long
        dwAllocationGranularity As Long
        wProcessorLevel As Integer
        wProcessorRevision As Integer
End Type
Private Type OSVERSIONINFO ' 148 bytes
        dwOSVersionInfoSize As Long
        dwMajorVersion As Long
        dwMinorVersion As Long
        dwBuildNumber As Long
        dwPlatformId As Long
        szCSDVersion As String * 128
End Type
#End If 'WIN32 Types
'**********************************
'**  Function Declarations:
#If Win32 Then
Private Declare Function ClientToScreen& Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI)
Private Declare Function ClipCursor& Lib "user32" (lpRect As RECT)
Private Declare Function ClipCursorBynum& Lib "user32" Alias "ClipCursor" (ByVal lpRect As Long)
Private Declare Function apiBeep& Lib "kernel32" Alias "Beep" (ByVal dwFreq As Long, ByVal dwDuration As Long)
Private Declare Function ExitWindowsEx& Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long)
Private Declare Function GetComputerName& Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long)
Private Declare Function GetDoubleClickTime& Lib "user32" ()
Private Declare Function GetKeyboardState& Lib "user32" (pbKeyState As Byte)
Private Declare Function GetKeyState% Lib "user32" (ByVal nVirtKey As Long)
Private Declare Function GetVersionEx& Lib "kernel32" Alias "GetVersionExA" _
                        (lpVersionInformation As OSVERSIONINFO)
Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
Private Declare Function SetCaretBlinkTime& Lib "user32" (ByVal wMSeconds As Long)
Private Declare Function SetKeyboardState& Lib "user32" (lppbKeyState As Byte)
Private Declare Function SetCursorPos& Lib "user32" (ByVal x As Long, ByVal Y As Long)
Private Declare Function SetDoubleClickTime& Lib "user32" (ByVal wCount As Long)
Private Declare Function ShowCursor& Lib "user32" (ByVal bShow As Long)
Private Declare Function ShowCaret& Lib "user32" (ByVal hwnd As Long)
Private Declare Function HideCaret& Lib "user32" (ByVal hwnd As Long)
Private Declare Function SystemParametersInfo& Lib "user32" Alias "SystemParametersInfoA" _
    (ByVal fAction As Long, ByVal uiParam As Long, ByVal pvParam As Long, ByVal fWinIni As Long)
#End If 'WIN32
Private Sub cmdClip_Click()
    Dim myRect As RECT, myPoint As POINTAPI
    Select Case fCClipped&
        Case True:
            dl& = ClipCursorBynum&(0)
            cmdClip.Caption = "&Clip Cursor"
            lblClipInfo.Visible = False
            fCClipped& = False
            pctCursor.Refresh
        Case False:
            cmdSetPos_Click
            myPoint.x = 0
            myPoint.Y = 0
            dl& = ClientToScreen&(pctCursor.hwnd, myPoint)
            myRect.Top = myPoint.Y
            myRect.Left = myPoint.x
            myRect.Right = myRect.Left + pctCursor.ScaleWidth
            myRect.Bottom = myRect.Top + pctCursor.ScaleHeight
            dl& = ClipCursor&(myRect)
            cmdClip.Caption = "Un-&Clip Cursor"
            lblClipInfo.Visible = True
            fCClipped& = True
            pctCursor.DrawWidth = 2
            pctCursor.Line (1, 1)-(pctCursor.ScaleWidth - 1, pctCursor.ScaleHeight - 1), , B
            pctCursor.DrawWidth = 1
    End Select
End Sub
Private Sub cmdHide_Click()
    If cmdHide.Caption = "&Hide Cursor" Then
        cmdHide.Caption = "&Show Cursor"
        fCHidden& = ShowCursor&(0)
    Else
        cmdHide.Caption = "&Hide Cursor"
        fCHidden& = ShowCursor&(1)
    End If
End Sub
Public Sub cmdSetPos_Click()
    Dim myPoint As POINTAPI
    myPoint.x = 12
    myPoint.Y = 12
    dl& = ClientToScreen&(pctCursor.hwnd, myPoint)
    dl& = SetCursorPos&(myPoint.x, myPoint.Y)
End Sub
Private Sub Form_Load()
    Dim x&
    x& = GetDoubleClickTime&()
    lblDoubleClick = x& & " ms"
    scrDoubleClick.Value = x& / -10
End Sub
Private Sub lblClipInfo_Click()
    pctCursor_Click
End Sub
Private Sub pctCursor_Click()
    If fCClipped& = True Then
        dl& = ClipCursorBynum&(0)
        cmdClip.Caption = "&Clip Cursor"
        fCClipped& = False
        pctCursor.Refresh
        lblClipInfo.Visible = False
    End If
End Sub
Private Sub pctCursor_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
    If fCHidden& = -1 And fTxtHidIt& Then 'Cursor is now hidden
        fCHidden& = ShowCursor&(1)
        fTxtHidIt& = False
    End If
End Sub
Private Sub pctCursor_Paint()
    pctCursor.Line (5, 5)-(20, 20)
    pctCursor.Line (5, 20)-(20, 5)
    If fCClipped& = True Then
        With pctCursor
            .DrawWidth = 2
            pctCursor.Line (1, 1)-(.ScaleWidth - 1, .ScaleHeight - 1), , B
            .DrawWidth = 1
        End With
    End If
End Sub
Private Sub pctDoubleClick_DblClick()
    Static whichLight%
    whichLight = whichLight + 1
    If whichLight = 3 Then whichLight = 0
    pctDoubleClick = picHolder(whichLight).Picture
End Sub
Private Sub scrDoubleClick_Change()
    dl& = SetDoubleClickTime&(-1 * scrDoubleClick * 10)
    lblDoubleClick = (-1 * scrDoubleClick * 10) & " ms"
End Sub
Private Sub scrDoubleClick_Scroll()
    dl& = SetDoubleClickTime&(-1 * scrDoubleClick * 10)
    lblDoubleClick = (-1 * scrDoubleClick * 10) & " ms"
End Sub
Private Sub txtCaret_KeyDown(KeyCode As Integer, Shift As Integer)
    If fCHidden& = 0 Then 'Cursor is now shown
        fTxtHidIt& = True
        fCHidden& = ShowCursor&(0)
    End If
End Sub
Private Sub txtCaret_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
    If fCHidden& = -1 And fTxtHidIt& Then 'Cursor is now hidden
        fCHidden& = ShowCursor&(1)
        fTxtHidIt& = False
    End If
End Sub