Loupe, version api

Télécharger le projet
Commenter

Description

C'est en cherchant autour du source précédent que j'ai vu la fonction API StretchBlt. Je me suis dit qu'en une ligne on pouvait copier et agrandir une partie de l'écran : donc faire une loupe toute simple !

La loupe se place par défaut en haut à droite de l'écran. Pour la déplacer il suffit de cliquer dessus et de la faire glisser là ou vous voulez. Pour fermer la loupe il faut faire un clic droit dessus. La loupe reste active même quand vous travaillez sur une autre application.

Source / Exemple : 


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.

Conclusion :


Cette source et quelques autres sur : http://nono40.developpez.com
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

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.

Du même auteur (cs_Nono40)