screenmagnifier.pas

介绍了如何用delphi来制作一个图像放大镜

unit ScreenMagnifier;

interface

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

type
   TMagnifierForm = class(TForm)
      BigImage: TImage;
      OpenPictureDialog: TOpenPictureDialog;
      GroupBoxMagnifier: TGroupBox;
      LabelMagnifiation: TLabel;
      SpinEditMagnification: TSpinEdit;
      LabelX: TLabel;
      LabelRadius: TLabel;
      SpinEditMagnifierRadius: TSpinEdit;
      RadioGroupMagnifierShape: TRadioGroup;
      CheckBoxMagnifierCursor: TCheckBox;
      GroupBoxImage: TGroupBox;
    LoadButton: TButton;
      CheckBoxStretch: TCheckBox;
      LabelFilename: TLabel;
      LabelBitmapAttributes: TLabel;
      LabelLocation: TLabel;
      CheckBoxMagnifierBorder: TCheckBox;
      ColorDialog: TColorDialog;
      ShapeBorderColor: TShape;
      procedure BigImageMouseMove(Sender: TObject; Shift: TShiftState; X,
         Y: Integer);
      procedure FormCreate(Sender: TObject);
      procedure FormDestroy(Sender: TObject);
      procedure FormPaint(Sender: TObject);
      procedure LoadButtonClick(Sender: TObject);
      procedure CheckBoxStretchClick(Sender: TObject);
      procedure BigImageMouseDown(Sender: TObject; Button: TMouseButton;
         Shift: TShiftState; X, Y: Integer);
      procedure BigImageMouseUp(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 AdjustIma geSize;
      procedure ShowMagnifier(const X, Y: INTEGER);
   public
      { Public declarations }
   end;

var
   MagnifierForm: TMagnifierForm;

implementation
{$R *.DFM}

uses
   IniFiles;
const
   KeywordSetup = '信息文件当前路径';
   KeywordDirectory = '目录';

function IsPaletteDevice: BOOLEAN;
var
   DeviceContext: hDC;
begin
   //获取屏幕DC
   DeviceContext := GetDC(0);

   try
      RESULT := GetDeviceCaps(DeviceContext, RASTERCAPS) and RC_PALETTE = RC_PALETTE
   finally
      // Give back the screen DC
      ReleaseDC(0, DeviceContext)
   end
end {是否设备调色板};


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 {获得象素格式字符串};


function GetBitmapDimensionsString(const Bitmap: TBitmap): string;
begin
   RESULT := IntToStr(Bitmap.Width) + ' by ' +
      IntToStr(Bitmap.Height) + ' pixels by ' +
      GetPixelFormatString(Bitmap.PixelFormat) + ' color';
end {获取位图的尺寸};


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

procedure TMagnifierForm.ShowMagnifier(const X, Y: INTEGER);
const
   // 用额外的空间绘制环面
   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, BigImage.Width);
         yActual := MulDiv(Y, Bitmap.Height, BigImage.Height)
      end

   else begin
         xActual := X;
         yActual := Y
      end;

   Magnification := SpinEditMagnification.Value;
   //放大率
   AreaRadius := ROUND(SpinEditMagnifierRadius.Value / Magnification);
   //放大半径
   if AreaRadius < 2
      then begin
         // 防止小位图出现问题
         AreaRadius := 2;
         SpinEditMagnifierRadius.Value := AreaRadius * Magnification
      end;

   // 创建原始位图
   ModifiedBitmap := TBitmap.Create;
   try
      with ModifiedBitmap do
         begin
            Assign(Bitmap); // 由基本图加载

            case RadioGroupMagnifierShape.ItemIndex of
               // 方形放大：
               0: begin

                     if CheckBoxMagnifierBorder.Checked
                        then begin
                           // 单象素边界
                           Canvas.Brush.Color := clBlack;
                           Canvas.Pen.Color := ColorDialog.Color;
                           //边框颜色
                           Canvas.Pen.Style := psSolid;
                           // 绘制边框
                           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));
                     //从基本位图拷贝到ModifiedBitmap
                  end;

               // 如果是圆形
               1: begin
                     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);
                              //正方形用黑色填充
                              Brush.Color := clWhite;
                              Ellipse(HalfExtraSpace,HalfExtraSpace,
                                 CircularMask.Width - HalfExtraSpace,
                                 CircularMask.Height - HalfExtraSpace);
                              //绘制圆形，并且是白色区域
                              // 使用掩模方式.即源位图与目标画布进行与操作
                              CopyMode := cmSrcAnd;
                              CopyRect(Rect(0, 0,
                                 CircularMask.Width,
                                 CircularMask.Height),
                                 Bitmap.Canvas,
                                 Rect(xActual - AreaRadius,
                                 yActual - AreaRadius,
                                 xActual + AreaRadius,
                                 yActual + AreaRadius))
                           end;
                        //将Bitmap的相应位置拷贝到CircularMask位图上
                        CircularMask.Transparent := TRUE;
                        Canvas.Draw(xActual - AreaRadius * Magnification - HalfExtraSpace,
                           yActual - AreaRadius * Magnification - HalfExtraSpace,
                           CircularMask);

                       if CheckBoxMagnifierBorder.Checked
                        //如果需要边界显示
                           then begin
                               with CircularMask.Canvas do
                                 begin
                                    Brush.Color := clBlack;
                                    Brush.Style := bsSolid;
                                    FillRect(ClipRect);
                                    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
            end;
         end;

      // 显示修改过的位图
      BigImage.Picture.Graphic := ModifiedBitmap
   finally
      ModifiedBitmap.Free
   end
end;


procedure TMagnifierForm.BigImageMouseMove(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, BigImage.Width);
         yActual := MulDiv(Y, Bitmap.Height, BigImage.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 TMagnifierForm.FormCreate(Sender: TObject);
var
   IniFile: TIniFile;

begin
   self.DoubleBuffered := true;
   ImageDesignWidth := BigImage.Width;
   ImageDesignHeight := BigImage.Height;
   Bitmap := TBitmap.Create;
   //创建一个空的位图
   IniFile := TIniFile.Create(ChangeFileExt(ParamStr(0), '.INI'));
   // 创建INI文件
   try
      OpenPictureDialog.InitialDir := Inifile.ReadString(KeywordSetup,
         KeywordDirectory,
         ExtractFilePath(ParamStr(0))) //初始路径
   finally
      IniFile.Free
   end
end;

procedure TMagnifierForm.FormDestroy(Sender: TObject);
begin
   Bitmap.Free;
   //释放备份的位图
end;

procedure TMagnifierForm.FormPaint(Sender: TObject);
begin
   //清楚窗体背景
   Canvas.Brush.Color := clBtnFace;
   Canvas.FillRect(Canvas.ClipRect)
end;


procedure TMagnifierForm.LoadButtonClick(Sender: TObject);
var
   Filename: string;
   IniFile: TIniFile;
   NewPath: string;
begin
   if OpenPictureDialog.Execute
      then begin
         Bitmap.Free;
         //释放上次使用位图
         Bitmap := TBitmap.Create;
         //重新创建位图
         Bitmap.LoadFromFile(OpenPictureDialog.FileName);
         //加载位图
         LabelFilename.Caption := OpenPictureDialog.FileName;
         //位图名字
         // 更新INI文件
         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
               BigImage.Width := ImageDesignWidth;
               BigImage.Height := ImageDesignHeight
            end
         else AdjustImageSize; //调整BigImage大小

         if (Bitmap.Width > BigImage.Width) or
            (Bitmap.Height > BigImage.Height)
            then CheckBoxStretch.Checked := TRUE;
         BigImage.Picture.Graphic := Bitmap; //显示位图
      end;
end;


procedure TMagnifierForm.AdjustImageSize;
begin
   if Bitmap.Width < ImageDesignWidth
      then BigImage.Width := Bitmap.Width
   else BigImage.Width := ImageDesignWidth;

   if Bitmap.Height < ImageDesignHeight
      then BigImage.Height := Bitmap.Height
   else BigImage.Height := ImageDesignHeight
end {调整BigImage大小};


procedure TMagnifierForm.CheckBoxStretchClick(Sender: TObject);
begin
   BigImage.Stretch := CheckBoxStretch.Checked;
   if CheckBoxStretch.Checked
      then begin
         BigImage.Width := ImageDesignWidth;
         BigImage.Height := ImageDesignHeight
      end
   else AdjustImageSize;
   BigImage.Invalidate
end;


procedure TMagnifierForm.BigImageMouseDown(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 TMagnifierForm.BigImageMouseUp(Sender: TObject;
   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   MagnifierShowing := FALSE; //停止放大
   Screen.Cursor := crDefault;
   BigImage.Picture.Graphic := Bitmap; // 恢复源图
end;


procedure TMagnifierForm.ShapeBorderColorMouseDown(Sender: TObject;
   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   if ColorDialog.Execute
      then ShapeBorderColor.Brush.Color := ColorDialog.Color
end;


end.