screenmagnifier.~pas

一个Delphi写的图片放大镜（很不错的源代码）

// Digital Magnifying Glass
// efg, 8/30/1998

// Good performance on 166 MHz Pentium -- magnification area around
// cursor stays updated during "Mouse Move" events.  On a 120 MHz Pentium
// the update is not fast enough even during slow movement of the mouse.

// Bitmap and ImageOnForm must have the same dimensions (width and height), or
// flicker will be rather serious during MouseMove events.

unit ScreenMagnifier;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, Spin, ComCtrls, ExtDlgs;

type
  TFormMagnifier = class(TForm)
    ImageOnForm: TImage;
    OpenPictureDialog: TOpenPictureDialog;
    GroupBoxMagnifier: TGroupBox;
    LabelMagnifiation: TLabel;
    SpinEditMagnification: TSpinEdit;
    LabelX: TLabel;
    LabelRadius: TLabel;
    SpinEditMagnifierRadius: TSpinEdit;
    RadioGroupMagnifierShape: TRadioGroup;
    CheckBoxMagnifierCursor: TCheckBox;
    GroupBoxImage: TGroupBox;
    ButtonLoadImage: TButton;
    CheckBoxStretch: TCheckBox;
    LabelFilename: TLabel;
    LabelBitmapAttributes: TLabel;
    LabelLocation: TLabel;
    CheckBoxMagnifierBorder: TCheckBox;
    ColorDialog: TColorDialog;
    ShapeBorderColor: TShape;
    LabelNoPalettes: TLabel;
    procedure ImageOnFormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure ButtonLoadImageClick(Sender: TObject);
    procedure CheckBoxStretchClick(Sender: TObject);
    procedure ImageOnFormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure ImageOnFormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure ShapeBorderColorMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);

  private
    Bitmap:  TBitmap;
    ImageDesignHeight:  INTEGER;
    ImageDesignWidth :  INTEGER;
    MagnifierShowing :  BOOLEAN;

    PROCEDURE AdjustImageSize;
    PROCEDURE ShowMagnifier (CONST X,Y:  INTEGER);
    PROCEDURE WmEraseBkgnd(VAR Msg:  TWmEraseBkgnd); MESSAGE Wm_EraseBkgnd;
  public
    { Public declarations }
  end;

var
  FormMagnifier: TFormMagnifier;

implementation
{$R *.DFM}

  USES
{$IFDEF GIF}
    GIFImage,                    // TGIFImage (by Anders Melander)
{$ENDIF}
    IniFiles,                    // TIniFile
    GraphicsConversionsLibrary,  // LoadGraphicsFile
    JPEG;                        // TJPEGImage

  CONST
    KeywordSetup     = 'Setup';
    KeywordDirectory = 'Directory';


  //  Adapted from Joe C. Hecht's BitTBitmapAsDIB post to
  //  borland.public.delphi.winapi, 12 Oct 1997.
  FUNCTION IsPaletteDevice:  BOOLEAN;
    VAR
      DeviceContext:  hDC;
  BEGIN
    // Get the screen's DC since memory DCs are not reliable
    DeviceContext := GetDC(0);

    TRY
      RESULT := GetDeviceCaps(DeviceContext, RASTERCAPS) AND RC_PALETTE = RC_PALETTE
    FINALLY
      // Give back the screen DC
      ReleaseDC(0, DeviceContext)
    END
  END {IsPaletteDevice};


  FUNCTION GetPixelFormatString(CONST PixelFormat:  TPixelFormat):  STRING;
    VAR
      Format:  STRING;
  BEGIN
    CASE PixelFormat OF
      pfDevice:  Format := 'Device';
      pf1bit:    Format := '1 bit';
      pf4bit:    Format := '4 bit';
      pf8bit:    Format := '8 bit';
      pf15bit:   Format := '15 bit';
      pf16bit:   Format := '16 bit';
      pf24bit:   Format := '24 bit';
      pf32bit:   Format := '32 bit'
      ELSE
        Format := 'Unknown';
    END;
    RESULT := Format;
  END {GetPixelFormatString};


  FUNCTION GetBitmapDimensionsString(CONST Bitmap:  TBitmap):  STRING;
  BEGIN
    RESULT := IntToStr(Bitmap.Width)  + ' by ' +
              IntToStr(Bitmap.Height) + ' pixels by ' +
              GetPixelFormatString(Bitmap.PixelFormat) + ' color';
  END {GetBitmapDimensionsString};


//===========================================================================

PROCEDURE TFormMagnifier.ShowMagnifier (CONST X,Y:  INTEGER);
  CONST
    // Use extra space to draw annulus around circular magnifier
    ExtraSpace        = 8;  // pixels
    HalfExtraSpace    = ExtraSpace DIV 2;
    QuarterExtraSpace = ExtraSpace DIV 4;

  VAR
    AreaRadius    :  INTEGER;
    CircularMask  :  TBitmap;
    Magnification :  INTEGER;
    ModifiedBitmap:  TBitmap;
    xActual       :  INTEGER;
    yActual       :  INTEGER;
BEGIN
  IF   CheckboxStretch.Checked
  THEN BEGIN
    xActual := MulDiv(X, Bitmap.Width,  ImageOnForm.Width);
    yActual := MulDiv(Y, Bitmap.Height, ImageOnForm.Height)
  END
  ELSE BEGIN
    xActual := X;
    yActual := Y
  END;

  Magnification := SpinEditMagnification.Value;

  // Keep area of interest about the same size with changing magnification
  AreaRadius := ROUND(SpinEditMagnifierRadius.Value / Magnification);
  IF   AreaRadius < 2
  THEN BEGIN
    // Avoid problem with very small bitmaps
    AreaRadius := 2;
    SpinEditMagnifierRadius.Value := AreaRadius * Magnification
  END;

  // Copy original bitmap
  ModifiedBitmap := TBitmap.Create;
  TRY
    WITH ModifiedBitmap DO
    BEGIN
      Assign(Bitmap);   // Make a copy of the "base" image

      CASE RadioGroupMagnifierShape.ItemIndex OF
        // Square Magnifier
        0:  BEGIN

              IF   CheckBoxMagnifierBorder.Checked
              THEN BEGIN
                // Single-pixel border when requested
                Canvas.Brush.Color := clBlack;
                Canvas.Pen.Color   := ColorDialog.Color;
                Canvas.Pen.Style   := psSolid;
                // Outline for magnifier to help contrast between magnifier
                // and any image.
                Canvas.Rectangle (xActual - AreaRadius * Magnification-1,
                                  yActual - AreaRadius * Magnification-1,
                                  xActual + AreaRadius * Magnification+1,
                                  yActual + AreaRadius * Magnification+1);
              END;

              Canvas.CopyMode := cmSrcCopy;
              Canvas.CopyRect(Rect(xActual - AreaRadius * Magnification,
                                   yActual - AreaRadius * Magnification,
                                   xActual + AreaRadius * Magnification,
                                   yActual + AreaRadius * Magnification),
                              Bitmap.Canvas,
                              Rect(xActual - AreaRadius,
                                   yActual - AreaRadius,
                                   xActual + AreaRadius,
                                   yActual + AreaRadius) );
            END;

        // Circular Magnifier
        1:  BEGIN
              // Circular mask:  white circle with black border
              CircularMask := TBitmap.Create;
              TRY
                CircularMask.Width  := 2 * AreaRadius * Magnification + ExtraSpace;
                CircularMask.Height := 2 * AreaRadius * Magnification + ExtraSpace;

                WITH CircularMask.Canvas DO
                BEGIN
                  Brush.Color := clBlack;
                  Brush.Style := bsSolid;
                  FillRect(ClipRect);      // solid black square

                  Brush.Color := clWhite;
                  Ellipse(HalfExtraSpace, HalfExtraSpace,
                          CircularMask.Width -HalfExtraSpace,
                          CircularMask.Height-HalfExtraSpace);

                  // Use Mask to select portion of source image.
                  CopyMode := cmSrcAnd;  // AND Images
                  CopyRect(Rect(0,0,
                                CircularMask.Width,
                                CircularMask.Height),
                           Bitmap.Canvas,
                           Rect(xActual - AreaRadius,
                                yActual - AreaRadius,
                                xActual + AreaRadius,
                                yActual + AreaRadius) )
                END;

                // Draw over copy of base image
                CircularMask.Transparent := TRUE;