unit woScreenZoom;
{
        Webocton - ImageListView

        Komponente um einen Bildschirm-Ausschnitt in
        verschiedenen Größen heranzuzoomen und in einer
        abgeleiteten Paintbox auszugeben.
        Die Lupe lässt sich über verschiedene Eigenschaften
        steuern.
        Die Option AutoLoad gibt an, ob automatisch die Lupe aktiviert
        werden soll, die Farben für Rahmen und Fadenkreuz sind einstellbar
        (BorderColor, CrosshairColor) und können an-/abgeschaltet werden
        (Border, ShowCrosshair).
        Wie stark gezoomt werden soll, kann über die Eigenschaft Zoom
        angegeben werden.

        Version vom: 20.04.2004

        Copyright 2004-2008 by Benedikt Loepp
        Webocton

        benedikt@webocton.de
        www.webocton.de

        ---

        Benötigt wird Borland Delphi+Visual Component Library
}

interface

uses
    SysUtils,
    Classes,
    Controls,
    Math,
    ExtCtrls,
    Windows,
    Graphics,
    Forms;

type
    TRefreshEvent = procedure(X, Y: Integer; CompletePicture, ZoomedPicture: TBitmap) of object;

    TwoScreenZoom = class(TPaintBox)
    private
        fTimer: TTimer;
        fZoom: Integer;
        fCrosshair: Boolean;
        fCrosshairColor: TColor;
        fBorder: Boolean;
        fBorderColor: TColor;
        fOnRefresh: TRefreshEvent;
        fAutoLoad: Boolean;
        procedure OnTimer(Sender: TObject);
        procedure SetZoom(Value: Integer);
        procedure SetCrosshair(Value: Boolean);
        procedure SetCrosshairColor(Value: TColor);
        procedure SetBorder(Value: Boolean);
        procedure SetBorderColor(Value: TColor);
    protected
        procedure Loaded; override;
    public
        constructor Create(AOwner: TComponent); override;
        procedure BeginShowing;
        procedure EndShowing;
    published
        property AutoLoad: Boolean read FAutoLoad write FAutoLoad default False;
        property Zoom: Integer read fZoom write SetZoom default 2;
        property ShowCrosshair: Boolean read fCrosshair write SetCrosshair default TRUE;
        property CrosshairColor: TColor read fCrosshairColor write SetCrosshairColor default clBlack;
        property Border: Boolean read fBorder write SetBorder default TRUE;
        property BorderColor: TColor read fBorderColor write SetBorderColor default clBlack;
        property OnRefresh: TRefreshEvent read fOnRefresh write fOnRefresh;
    end;

procedure Register;

implementation

procedure Register;
begin
    RegisterComponents('Webocton - Components', [TwoScreenZoom]);
end;

procedure TwoScreenZoom.Loaded;
begin
    if (fAutoLoad = TRUE) then
        BeginShowing;
end;

constructor TwoScreenZoom.Create(AOwner: TComponent);
begin
    inherited Create(AOwner);

    fTimer := TTimer.Create(Self);
    fTimer.Interval := 100;
    fTimer.OnTimer := OnTimer;
    fTimer.Enabled := FALSE;

    Zoom := 2;
    ShowCrosshair := TRUE;
    Border := TRUE;
end;

procedure TwoScreenZoom.BeginShowing;
begin
    fTimer.Enabled := TRUE;
end;

procedure TwoScreenZoom.EndShowing;
begin
    fTimer.Enabled := FALSE;
end;

procedure TwoScreenZoom.SetZoom(Value: Integer);
begin
    if (Value >= 2) then
        fZoom := Value
    else
        fZoom := 2;
end;

procedure TwoScreenZoom.SetCrosshair(Value: Boolean);
begin
    fCrosshair := Value;
end;

procedure TwoScreenZoom.SetCrosshairColor(Value: TColor);
begin
    fCrosshairColor := Value;
end;

procedure TwoScreenZoom.SetBorder(Value: Boolean);
begin
    fBorder := Value;
end;

procedure TwoScreenZoom.SetBorderColor(Value: TColor);
begin
    fBorderColor := Value;
end;

procedure TwoScreenZoom.OnTimer(Sender: TObject);
var
    P: TPoint;
    DC: HDC;
    Width: Integer;
    Height: Integer;
    BitmapA: TBitmap;
    BitmapB: TBitmap;
begin
    GetCursorPos(P);

    DC := CreateDC('DISPLAY', nil, nil, nil);

    try
        BitmapA := TBitmap.Create;

        BitmapA.Height := Self.Height;
        BitmapA.Width := Self.Width;

        BitBlt(BitmapA.Canvas.Handle, 0, 0, Screen.Width, Screen.Height, DC, P.X - (Self.Width div fZoom), P.Y - (Self.Height div fZoom), srcCopy);

        Width := (BitmapA.Width - 1) div 2;
        Height := (BitmapA.Height - 1) div 2;
        Self.Canvas.CopyRect(Rect(0, 0, Self.Width - 1, Self.Height - 1), BitmapA.Canvas, Rect(Width div fZoom, Height div fZoom, (Width div fZoom * 3), (Height div fZoom * 3)));

        if (fCrosshair = TRUE) then
        begin
            Self.Canvas.Pen.Color := fCrosshairColor;
                        //Line horicontal
            Self.Canvas.MoveTo((Self.Width div 2) div 2, (Self.Height div 2));
            Self.Canvas.LineTo(((Self.Width div 2) div 2) * 3, (Self.Height div 2));

                        //Line vertical
            Self.Canvas.MoveTo((Self.Width div 2), (Self.Height div 2) div 2);
            Self.Canvas.LineTo((Self.Width div 2), ((Self.Height div 2) div 2) * 3);
        end;
        if (fBorder = TRUE) then
        begin
            Self.Canvas.Brush.Color := fBorderColor;
            Self.Canvas.FrameRect(Rect(0, 0, Self.Width, Self.Height));

        end;
        if (Assigned(fOnRefresh)) then
        begin
            BitmapB := TBitmap.Create;

            BitmapB.Height := Self.Height;
            BitmapB.Width := Self.Width;

            BitmapB.Canvas.CopyRect(Rect(0, 0, Self.Width - 1, Self.Height - 1), Self.Canvas, Rect(0, 0, Self.Width - 1, Self.Height - 1));

            fOnRefresh(P.X, P.Y, BitmapA, BitmapB);

            BitmapB.Free;
            BitmapB := nil;
        end;
    finally
        DeleteDC(DC);
        BitmapA.Free;
        BitmapA := nil;
    end;
end;

end.