screenmagnifier.pas

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

                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;


// Eliminate erasing whole form during a screen update.  Interestingly,
// if only the TImage is present, WmEraseBkgnd is not necessary, but a
// combination of updating a TLabel and the TImage during a MouseMove causes
// a great deal of flicker without this trick.  For some reason, this trick
// is NOT needed if the TImage is place on a TPanel or TTabSheet instead of
// directly on the TForm as it is in this example.
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  < ImageDesignWidth
  THEN ImageOnForm.Width := Bitmap.Width
  ELSE ImageOnForm.Width := ImageDesignWidth;

  IF   Bitmap.Height < ImageDesignHeight
  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.