0/5 (1 avis)
Vue 5 023 fois - Téléchargée 486 fois
unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, Menus; type TForm1 = class(TForm) Timer1: TTimer; Panel1: TPanel; PaintBox1: TPaintBox; procedure Timer1Timer(Sender: TObject); procedure FormCreate(Sender: TObject); procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure PaintBox1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); private { Déclarations privées } public { Déclarations publiques } end; var Form1: TForm1; implementation {$R *.dfm} // Valeur de zoom de la loupe Const Zoom=3; procedure TForm1.Timer1Timer(Sender: TObject); var Dc : HDC; x,y: Integer; Begin // Création d'un contexte d'affichage non lié à une fenêtre // donc permet d'accéder à l'écran entier DC := CreateDC('DISPLAY',Nil,Nil,Nil); With PaintBox1 Do Try // prise du point de référence de la souris x:=Mouse.CursorPos.X; y:=Mouse.CursorPos.Y; // limitations de la zone pour ne pas sortir de l'écran If x>=(Screen.Width -ClientWidth Div Zoom) Then x:=(Screen.Width -ClientWidth Div Zoom)-1; If y>=(Screen.Height-ClientHeight Div Zoom) Then y:=(Screen.Height-ClientHeight Div Zoom)-1; // Copie d'une partie de l'écran dans la boite à peindre StretchBlt(paintbox1.canvas.Handle // Copie vers le canevas de la boite ,0 // vers X=0 ,0 // et Y=0 ,(ClientWidth *zoom)-1 // en multipliant par Zoom la largeur ,(ClientHeight*zoom)-1 // en multipliant par Zoom la hauteur ,DC // Copie à partir du canevas global ,x // de la position de la souris ,y // ... ,ClientWidth // sur la taille de la boite ,ClientHeight // ,SRCCOPY); // Simple copie sans autre effet. Finally // ne pas ouvbier de libérer le contexte, c'est une ressource rare. DeleteDc(DC); End; // Mettre la fenêtre au premier plan Show; End; procedure TForm1.FormCreate(Sender: TObject); begin // Par défaut la loupe est en haut à droite Top :=20; Left :=Screen.Width-Width-20; Application.Title:='Loupe'; end; procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin // Astuce pour déplacer facilement un WinControl ou descendant // ( Merci à DelphiProg qui l'a donnée dans le forum il y a un bout de temps...) If Button=mbLeft Then Begin ReleaseCapture; perform(WM_SYSCOMMAND, $F012, 0); End; end; procedure TForm1.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin // Femeture de la fenêtre sur un click droit. If Button=mbRight Then Close; end; end.
25 déc. 2002 à 16:37
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.