Magnifier Image

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 <>

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;

Canvas.Draw(xActual - AreaRadius * Magnification - HalfExtraSpace,

yActual - AreaRadius * Magnification - HalfExtraSpace,

CircularMask);

IF CheckBoxMagnifierBorder.Checked

THEN BEGIN

// 2-pixel annulus around magnifier, when requested

WITH CircularMask.Canvas DO

BEGIN

Brush.Color := clBlack;

Brush.Style := bsSolid;

FillRect(ClipRect); // solid black square

Brush.Color := ColorDialog.Color;

Ellipse(QuarterExtraSpace,

QuarterExtraSpace,

CircularMask.Width - QuarterExtraSpace,

CircularMask.Height - QuarterExtraSpace);

Brush.Color := clBlack;

Ellipse(HalfExtraSpace,

HalfExtraSpace,

CircularMask.Width - HalfExtraSpace,

CircularMask.Height - HalfExtraSpace)

END;

CircularMask.Transparent := TRUE;

Canvas.Draw(xActual - AreaRadius * Magnification - HalfExtraSpace,

yActual - AreaRadius * Magnification - HalfExtraSpace,

CircularMask);

END

FINALLY

CircularMask.Free

END

END;

ELSE

// Ignore -- should never happen

END;

END;

// Display newly modified image

ImageOnForm.Picture.Graphic := ModifiedBitmap

FINALLY

ModifiedBitmap.Free

END

END {ShowMagnifier};

procedure TFormMagnifier.ImageOnFormMouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

VAR

TargetColor: TColor;

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;

TargetColor := Bitmap.Canvas.Pixels[xActual, YActual];

LabelLocation.Caption :=

'(X,Y) = (' + IntToStr(xActual) + ', ' +

IntToStr(yActual) + ') ' +

'(R,G,B) = (' + IntToStr(GetRValue(TargetColor)) + ', ' +

IntToStr(GetGValue(TargetColor)) + ', ' +

IntToStr(GetBValue(TargetColor)) + ') = ' +

ColorToString(TargetColor);

IF MagnifierShowing

THEN ShowMagnifier(X, Y)

end;

procedure TFormMagnifier.FormCreate(Sender: TObject);

VAR

IniFile : TIniFile;

{$IFDEF GIF}

s : STRING;

{$ENDIF}

begin

LabelNoPalettes.Visible := IsPaletteDevice;

// Add "GIF" to OpenPictureDialog selections

{$IFDEF GIF}

s := OpenPictureDialog.Filter + '|GIFs (*.gif)|*.gif';

Insert('*.gif;',s, POS('(',s)+1); // Put GIF in "All" selection

Insert('*.gif;',s, POS('|',s)+1);

OpenPictureDialog.Filter := s;

{$ENDIF}

// Create "Empty" Bitmap so OnMouse Events Work

ImageDesignWidth := ImageOnForm.Width;

ImageDesignHeight := ImageOnForm.Height;

Bitmap := TBitmap.Create;

// Start with directory last used

IniFile := TIniFile.Create(ChangeFileExt(ParamStr(0), '.INI'));

TRY

OpenPictureDialog.InitialDir := Inifile.ReadString(KeywordSetup,

KeywordDirectory,

ExtractFilePath(ParamStr(0)))

FINALLY

IniFile.Free

END

end;

procedure TFormMagnifier.FormDestroy(Sender: TObject);

begin

Bitmap.Free

end;

PROCEDURE TFormMagnifier.WmEraseBkgnd(VAR Msg: TWmEraseBkgnd);

BEGIN

Msg.Result := 1;

END {WmEraseBkgnd};

procedure TFormMagnifier.FormPaint(Sender: TObject);

begin

// Clear background of Form

Canvas.Brush.Color := clBtnFace;

Canvas.FillRect(Canvas.ClipRect)

end;

procedure TFormMagnifier.ButtonLoadImageClick(Sender: TObject);

VAR

Filename: STRING;

IniFile : TIniFile;

NewPath : STRING;

begin

IF OpenPictureDialog.Execute

THEN BEGIN

Bitmap.Free;

Bitmap := TBitmap.Create;

Bitmap := LoadGraphicsFile(OpenPictureDialog.FileName);

LabelFilename.Caption := OpenPictureDialog.FileName;

// Update INI file for next time

Filename := ChangeFileExt(ParamStr(0), '.INI');

NewPath := ExtractFilePath(OpenPictureDialog.Filename);

OpenPictureDialog.InitialDir := NewPath;

IniFile := TIniFile.Create(Filename);

TRY

Inifile.WriteString(KeywordSetup, KeywordDirectory, NewPath)

FINALLY

IniFile.Free

END;

LabelBitmapAttributes.Caption :=

GetBitmapDimensionsString(Bitmap);

IF CheckBoxStretch.Checked

THEN BEGIN

ImageOnForm.Width := ImageDesignWidth;

ImageOnForm.Height := ImageDesignHeight

END

ELSE AdjustImageSize;

IF (Bitmap.Width > ImageOnForm.Width) OR

(Bitmap.Height > ImageOnForm.Height)

THEN CheckBoxStretch.Checked := TRUE;

ImageOnForm.Picture.Graphic := Bitmap

END

end;

PROCEDURE TFormMagnifier.AdjustImageSize;

BEGIN

// Eliminate one souce of flicker

IF Bitmap.Width <>

THEN ImageOnForm.Width := Bitmap.Width

ELSE ImageOnForm.Width := ImageDesignWidth;

IF Bitmap.Height <>

THEN ImageOnForm.Height := Bitmap.Height

ELSE ImageOnForm.Height := ImageDesignHeight

END {AdjustImageSize};

procedure TFormMagnifier.CheckBoxStretchClick(Sender: TObject);

begin

ImageOnForm.Stretch := CheckBoxStretch.Checked;

IF CheckBoxStretch.Checked

THEN BEGIN

ImageOnForm.Width := ImageDesignWidth;

ImageOnForm.Height := ImageDesignHeight

END

ELSE AdjustImageSize;

ImageOnForm.Invalidate

end;

procedure TFormMagnifier.ImageOnFormMouseDown(Sender: TObject;

Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

MagnifierShowing := TRUE;

IF CheckBoxMagnifierCursor.Checked

THEN Screen.Cursor := crCross

ELSE Screen.Cursor := crNone;

ShowMagnifier (X,Y);

end;

procedure TFormMagnifier.ImageOnFormMouseUp(Sender: TObject;

Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

MagnifierShowing := FALSE;

Screen.Cursor := crDefault;

ImageOnForm.Picture.Graphic := Bitmap; // Restore base image

end;

procedure TFormMagnifier.ShapeBorderColorMouseDown(Sender: TObject;

Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

IF ColorDialog.Execute

THEN ShapeBorderColor.Brush.Color := ColorDialog.Color

end;

end.