development/compilers/freepascal/rtl/win32/winmouse.pp

   1 {
   2     $Id$
   3     This file is part of the Free Pascal run time library.
   4     Copyright (c) 1999-2000 by Florian Klaempfl
   5     member of the Free Pascal development team
   6
   7     This is unit implements a subset of the msmouse unit functionality
   8     for the gui win32 graph unit implementation
   9
  10     See the file COPYING.FPC, included in this distribution,
  11     for details about the copyright.
  12
  13     This program is distributed in the hope that it will be useful,
  14     but WITHOUT ANY WARRANTY; without even the implied warranty of
  15     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  16
  17  **********************************************************************}
  18 unit winmouse;
  19
  20   interface
  21     { initializes the mouse with the default values for the current screen mode }
  22     Function InitMouse:Boolean;
  23
  24     { shows mouse pointer,text+graphics screen support }
  25     Procedure ShowMouse;
  26
  27     { hides mouse pointer }
  28     Procedure HideMouse;
  29
  30     { reads mouse position in pixels (divide by 8 to get text position in standard
  31       text mode) and reads the buttons state:
  32          bit 1 set -> left button pressed
  33          bit 2 set -> right button pressed
  34          bit 3 set -> middle button pressed
  35       Have a look at the example program in the manual to see how you can use this }
  36     Procedure GetMouseState(var x,y, buttons :Longint);
  37
  38     { returns true if the left button is pressed }
  39     Function LPressed:Boolean;
  40
  41     { returns true if the right button is pressed }
  42     Function RPressed:Boolean;
  43
  44     { returns true if the middle button is pressed }
  45     Function MPressed:Boolean;
  46
  47 (*!!!!! the following functions aren't implemented yet:
  48     { positions the mouse pointer }
  49     Procedure SetMousePos(x,y:Longint);
  50
  51     { returns at which position "button" was last pressed in x,y and returns the
  52       number of times this button has been pressed since the last time this
  53       function was called with "button" as parameter. For button you can use the
  54       LButton, RButton and MButton constants for resp. the left, right and middle
  55       button }
  56     Function GetLastButtonPress(button:Longint;var x,y:Longint): Longint;
  57
  58     { returns at which position "button" was last released in x,y and returns the
  59       number of times this button has been re since the last time. For button
  60       you can use the LButton, RButton and MButton constants for resp. the left,
  61       right and middle button
  62     }
  63     Function GetLastButtonRelease (button : Longint; var x,y:Longint): Longint;
  64
  65     { sets mouse's x range, with Min and Max resp. the higest and the lowest
  66       column (in pixels) in between which the mouse cursor can move }
  67     Procedure SetMouseXRange (Min,Max:Longint);
  68
  69     { sets mouse's y range, with Min and Max resp. the higest and the lowest
  70       row (in pixels) in between which the mouse cursor can move}
  71     Procedure SetMouseYRange (Min,Max:Longint);
  72
  73     { set the window coordinates in which the mouse cursor can move }
  74     Procedure SetMouseWindow(x1,y1,x2,y2:Longint);
  75
  76     { sets the mouse shape in text mode: background and foreground color and the
  77       Ascii value with which the character on screen is XOR'ed when the cursor
  78       moves over it. Set to 0 for a "transparent" cursor}
  79     Procedure SetMouseShape(ForeColor,BackColor,Ascii:Byte);
  80
  81     { sets the mouse ascii in text mode. The difference between this one and
  82       SetMouseShape, is that the foreground and background colors stay the same
  83       and that the Ascii code you enter is the character that you will get on
  84       screen; there's no XOR'ing }
  85     Procedure SetMouseAscii(Ascii:Byte);
  86
  87     { set mouse speed in mickey's/pixel; default: horizontal: 8; vertical: 16 }
  88     Procedure SetMouseSpeed(Horizontal ,Vertical:Longint);
  89
  90     { set a rectangle on screen that mouse will disappear if it is moved into }
  91     Procedure SetMouseHideWindow(x1,y1,x2,y2:Longint);
  92 *)
  93
  94     Const
  95        LButton = 1; { left button   }
  96        RButton = 2; { right button  }
  97        MButton = 4; { middle button }
  98
  99     Var
 100        MouseFound: Boolean;
 101
 102   implementation
 103
 104     uses
 105        windows,graph;
 106
 107     var
 108        oldexitproc : pointer;
 109        mousebuttonstate : byte;
 110
 111     function InitMouse : boolean;
 112
 113       begin
 114          InitMouse:=MouseFound;
 115       end;
 116
 117     procedure ShowMouse;
 118
 119       begin
 120          Windows.ShowCursor(true);
 121       end;
 122
 123     procedure HideMouse;
 124
 125       begin
 126          Windows.ShowCursor(false);
 127       end;
 128
 129     function msghandler(Window: hwnd; AMessage, WParam,
 130       LParam: Longint): Longint;
 131
 132       begin
 133          { we catch the double click messages here too, }
 134          { even if they never appear because the graph  }
 135          { windows doesn't have the cs_dblclks flags    }
 136          case amessage of
 137             wm_lbuttondblclk,
 138             wm_lbuttondown:
 139               mousebuttonstate:=mousebuttonstate or LButton;
 140             wm_rbuttondblclk,
 141             wm_rbuttondown:
 142               mousebuttonstate:=mousebuttonstate or RButton;
 143             wm_mbuttondblclk,
 144             wm_mbuttondown:
 145               mousebuttonstate:=mousebuttonstate or MButton;
 146             wm_lbuttonup:
 147               mousebuttonstate:=mousebuttonstate and not(LButton);
 148             wm_rbuttonup:
 149               mousebuttonstate:=mousebuttonstate and not(RButton);
 150             wm_mbuttonup:
 151               mousebuttonstate:=mousebuttonstate and not(MButton);
 152          end;
 153          msghandler:=0;
 154       end;
 155
 156     Function LPressed : Boolean;
 157
 158       begin
 159          LPressed:=(mousebuttonstate and LButton)<>0;
 160       end;
 161
 162     Function RPressed : Boolean;
 163
 164       begin
 165          RPressed:=(mousebuttonstate and RButton)<>0;
 166       end;
 167
 168     Function MPressed : Boolean;
 169
 170       begin
 171          MPressed:=(mousebuttonstate and MButton)<>0;
 172       end;
 173
 174     Procedure GetMouseState(var x,y,buttons : Longint);
 175
 176       var
 177          pos : POINT;
 178
 179       begin
 180          buttons:=mousebuttonstate;
 181          GetCursorPos(@pos);
 182          ScreenToClient(mainwindow,@pos);
 183          x:=pos.x;
 184          y:=pos.y;
 185       end;
 186
 187     procedure myexitproc;
 188
 189       begin
 190          exitproc:=oldexitproc;
 191          mousemessagehandler:=nil;
 192       end;
 193
 194   begin
 195      mousemessagehandler:=@msghandler;
 196      oldexitproc:=exitproc;
 197      exitproc:=@myexitproc;
 198      mousebuttonstate:=0;
 199      MouseFound:=GetSystemMetrics(SM_MOUSEPRESENT)<>0;
 200   end.
 201 {
 202   $Log$
 203   Revision 1.1  2002/02/19 08:26:28  sasu
 204   Initial revision
 205
 206   Revision 1.1  2000/07/13 06:31:22  michael
 207   + Initial import
 208
 209   Revision 1.3  2000/03/05 13:08:52  florian
 210     + some new functions
 211     * double click messages are handled like single clicks because this
 212       is the behavior as old DOS applications expect
 213
 214   Revision 1.2  2000/01/07 16:41:53  daniel
 215     * copyright 2000
 216
 217   Revision 1.1  1999/11/29 22:03:39  florian
 218     * first implementation of winmouse unit
 219
 220 }