cmpbitmapeditor.pas

學習資料網上下載

  p.y := y;
  ScreenToClient (p);
  if Parent is TScrollingWinControl then
  begin
    r := Parent.ClientRect;
    MapWindowPoints (Parent.Handle, handle, r, 2);
    IntersectRect (r, r, ClientRect)
  end
  else
    r := ClientRect;

  inRect := PtInRect (r, p);
  if inRect  or (ssLeft in Shift) then
  begin
    p.x := p.x div magnification;
    p.y := p.y div magnification;
    if inRect and not fMouseCaptured then
    begin
      SetCapture (handle);
      fMouseCaptured := True
    end;

    if not InRect and (DrawingTool in [dtSelectRect, dtSelectArea]) then
    begin
      if p.x >= drawBmp.Width then p.x := drawBmp.Width - 1;
      if p.y >= drawBmp.Height then p.y := drawBmp.Height - 1;
      ChangeSelectionRect (rect (-2, -2, p.x, p.y));
    end
    else
    begin
      if (p.x <> fPos.x) or (p.y <> fPos.y) then
        if FLButtonIsDown then
        begin
          case DrawingTool of
            dtPencil :
              with fDrawBmp.Canvas do
                begin
                  Pen := fDrawPen;
                  MoveTo (fPos.x, fPos.y);
                  LineTo (p.x, p.y);
                  Pixels [p.x, p.y] := fDrawPen.Color;
                  fPos := p;
                end;

            dtLine :
              begin
                fDrawBmp.Assign (fScratchBmp);
                with fDrawBmp.Canvas do
                begin
                  Pen := fDrawPen;
                  MoveTo (fPos.x, fPos.y);
                  LineTo (p.x, p.y);
                  Pixels [p.x, p.y] := fDrawPen.Color;
                end
              end;
            dtFrameRect, dtFillRect, dtRect,
            dtFrameEllipse, dtFillEllipse, dtEllipse,
            dtFrameRoundRect, dtFillRoundRect, dtRoundRect :
              begin
                fDrawBmp.Assign (fScratchBmp);
                case DrawingTool of
                  dtFrameRect, dtFillRect, dtRect                : hrgn := CreateRectRgn (fPos.x, fPos.y, p.x + 1, p.y + 1);
                  dtFrameEllipse, dtFillEllipse, dtEllipse       : hrgn := CreateEllipticRgn (fPos.x, fPos.y, p.x + 1, p.y + 1);
                  dtFrameRoundRect, dtFillRoundRect, dtRoundRect : hrgn := CreateRoundRectRgn (fPos.x, fPos.y, p.x + 1, p.y + 1, 5, 5);
                  else
                    hrgn := 0;
                end;
                if hrgn <> 0 then
                  with fDrawBmp.Canvas do
                  try
                    case DrawingTool of
                      dtRect,
                      dtEllipse,
                      dtRoundRect  :
                        FillRgn (handle, hrgn, DrawBrush.Handle);

                      dtFillRect,
                      dtFillEllipse,
                      dtFillRoundRect  :
                        begin
                          FillRgn (handle, hrgn, DrawBrush.Handle);
                          Brush.Color := DrawPen.Color;
                          FrameRgn (handle, hrgn, brush.Handle, 1, 1)
                        end;

                      dtFrameRect,
                      dtFrameEllipse,
                      dtFrameRoundRect :
                        begin
                          Brush.Color := DrawPen.Color;
                          FrameRgn (handle, hrgn, brush.Handle, 1, 1);
                        end
                    end
                  finally
                    DeleteObject (hrgn)
                  end
              end;
            dtSelectRect,
            dtSelectArea :
              ChangeSelectionRect (rect (-2, -2, p.x, p.y));
          end;

          if not (DrawingTool in [dtSelectRect, dtSelectArea]) then
            RedrawBitmap
          else
            Invalidate
        end;

        if Cursor = crNone then
          Invalidate
      end
  end
  else
  begin  // Pt not in rect, and not LButtonDown
    ReleaseCapture;
    fMouseCaptured := False;
    Invalidate
  end
end;

procedure TBitmapEditor.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  p : TPoint;
begin
  if button = mbLeft then
    fLButtonIsDown := False;

  p.x := x;
  p.y := y;
  ScreenToClient (p);

  if PtInRect (ClientRect, p) then
  begin
    SetCapture (handle);
    fMouseCaptured := True
  end;

  if fCallEndChange then
  begin
    fCallEndChange := False;
    Picture.Graphic.Assign (drawBmp);
    if Assigned (OnEndChange) then
      OnEndChange (self)
  end
end;

procedure TBitmapEditor.Paint;
var
  x : Integer;
  r : TRect;
  pts : array [0..4] of TPoint;
begin
  PaintBitmap (fDrawbmp);

  if GridLines <= Magnification then
  begin
    x := Magnification - 1;
    while x < Width - 1 do
    begin
      Canvas.MoveTo (x, 0);
      Canvas.LineTo (x, Height);
      Inc (x, Magnification)
    end;

    x := Magnification - 1;
    while x < Height - 1do
    begin
      Canvas.MoveTo (0, x);
      Canvas.LineTo (Width, x);
      Inc (x, Magnification)
    end
  end;

  fCrossX := -1;
  fCrossY := -1;

  if SelectionValid then
    with fSelectionRect do
    begin
      r.left := left * Magnification + Magnification div 2;
      r.top := top * Magnification + Magnification div 2;
      r.right := right * Magnification + Magnification div 2;
      r.bottom := bottom * Magnification + Magnification div 2;

      pts [0] := r.TopLeft;
      pts [1].x := r.Right;
      pts [1].y := r.Top;
      pts [2] := r.BottomRight;
      pts [3].x := r.Left;
      pts [3].y := r.Bottom;
      pts [4] := pts [0];

      Canvas.Pen.Width := Magnification;
      Canvas.Pen.Mode := pmNotXOR;
      Canvas.PolyLine (pts);
      Canvas.Pen.Width := 1;
      Canvas.Pen.Mode := pmCopy;
    end;

  if fMouseCaptured and (Cursor = crNone) and not fLButtonIsDown then
    DisplayCrossHairs;
end;

procedure TBitmapEditor.PaintBitmap (bmp : TBitmap);
begin
  if bmp.Transparent then
  begin
    Canvas.Brush.Color := TransparentColor;
    Canvas.FillRect (ClientRect);
  end;
  Canvas.StretchDraw (ClientRect, bmp);
end;

procedure TBitmapEditor.PasteSelection;
var
  b : TBitmap;
  s : TMemoryStream;
  f : TBitmapFileHeader;
  Data : THandle;
  p : PChar;
  Size : Integer;
  r : TRect;
begin
  s := nil;
  b := TBitmap.Create;
  try
    data := clipboard.GetAsHandle (CF_DIB);
    if data = 0 then
      RaiseLastOSError;

    s := TMemoryStream.Create;

    FillChar(f, sizeof(f), 0);
    f.bfType := $4D42;

    s.Write (f, SizeOf (f));

    Size := GlobalSize (data);
    p := GlobalLock (data);
    try
      s.Write (p^, Size);
    finally
      GlobalUnlock (data)
    end;
    s.Seek (0, soFromBeginning);
    b.LoadFromStream (s);

    b.Palette := fClipboardPalette;
    b.PixelFormat := fClipboardPixelFormat;

    r := fSelectionRect;
    Inc (r.Right);
    Inc (r.Bottom);

    fDrawBmp.Canvas.StretchDraw (r, b);
    Invalidate;
    Picture.Graphic.Assign (drawBmp);
    if Assigned (OnEndChange) then
      OnEndChange (self)
  finally
    b.Free;
    s.Free
  end
end;

procedure TBitmapEditor.PictureChanged;
begin
  Initialize;
  Invalidate;
end;

procedure TBitmapEditor.RedrawBitmap;
begin
  Invalidate;
  if not (csDestroying in ComponentState) and Assigned (OnChange) then
    OnChange (self);
end;

procedure TBitmapEditor.Rotate180;
var
  destRect, srcRect : TRect;
begin
  with fDrawBmp do
  begin
    srcRect := Rect (0, 0, Width, Height);

      // Should technically be Width-1, Height-1,
      // But work round a bug in CopyRect...

    destRect := srcRect;
    destRect.Left := srcRect.Right;
    destRect.Top := srcRect.Bottom;
    destRect.Right := 0;
    destRect.Bottom := 0;
    Canvas.CopyRect (destRect, Canvas, srcRect);
    RedrawBitmap
  end

end;

procedure TBitmapEditor.Rotate270;
var
  newBmp : TBitmap;
begin
  fDrawBmp.PixelFormat := pf24Bit;
  newBmp := RotateBitmap270 (fDrawBmp);
  fDrawBmp.Free;

  newBmp.PixelFormat := pfDevice;
  fDrawBmp := NewBmp;
  ClientWidth := fDrawBmp.Width * Magnification;
  ClientHeight := fDrawBmp.Height * Magnification;
  RedrawBitmap
end;

procedure TBitmapEditor.Rotate90;
var
  newBmp : TBitmap;
begin
  fDrawBmp.PixelFormat := pf24Bit;
  newBmp := RotateBitmap90 (fDrawBmp);
  fDrawBmp.Free;

  newBmp.PixelFormat := pfDevice;
  fDrawBmp := NewBmp;
  ClientWidth := fDrawBmp.Width * Magnification;
  ClientHeight := fDrawBmp.Height * Magnification;
  RedrawBitmap
end;

procedure TBitmapEditor.SelectAll;
begin
  ChangeSelectionRect (rect (0, 0,drawBmp.Width - 1, drawBmp.Height - 1));
end;

procedure TBitmapEditor.SetBorderStyle(const Value: TBorderStyle);
begin
  if fBorderStyle <> value then
  begin
    fBorderStyle := Value;
    RecreateWnd
  end
end;

procedure TBitmapEditor.SetDrawBrush(const Value: TBrush);
begin
  fDrawBrush.Assign (value)
end;

procedure TBitmapEditor.SetDrawingTool(const Value: TDrawingTool);
begin
  if value <> fDrawingTool then
  begin
    fLastDrawingTool := fDrawingTool;
    fDrawingTool := Value;
    Cursor := drawingCursors [fDrawingTool];
    if SelectionValid then
      ChangeSelectionRect (rect (-1, -1, -1, -1));
  end
end;

procedure TBitmapEditor.SetDrawPen(const Value: TPen);
begin
  fDrawPen.Assign (value)
end;

procedure TBitmapEditor.SetGridLines(const Value: Integer);
begin
  if fGridLines <> value then
  begin
    fGridLines := Value;
    Invalidate
  end
end;

procedure TBitmapEditor.SetMagnification(const Value: Integer);
begin
  if fMagnification <> value then
  begin
    fMagnification := Value;
    SizeToPicture;
    Invalidate
  end
end;

procedure TBitmapEditor.SetPicture(const Value: TPicture);
begin
  fPicture.Assign (Value);
  PictureChanged;
end;

procedure TBitmapEditor.SetTransparentColor(const Value: TColor);
begin
  if (value <> ftransparentColor) then
  begin
    fTransparentColor := value;
    Initialize;
    Invalidate;
  end
end;

procedure TBitmapEditor.SizeToPicture;
begin
  if Assigned (fDrawBmp) and (fDrawBmp.Width > 0) then
  begin
    ClientWidth := fDrawBmp.Width * Magnification;
    ClientHeight := fDrawBmp.Height * Magnification
  end
  else
  if fPicture.Width = 0 then
  begin
    ClientWidth := 32 * Magnification;
    ClientHeight := 32 * Magnification
  end
  else
  begin
    ClientWidth := fPicture.Width * Magnification;
    ClientHeight := fPicture.Height * Magnification
  end
end;

procedure TBitmapEditor.ZoomIn;
begin
  if Magnification = 1 then
    Magnification := 2
  else
    if Magnification < 32 then
      Magnification := Magnification + 2
end;

procedure TBitmapEditor.ZoomOut;
begin
  if Magnification = 2 then
    Magnification := 1
  else
    if Magnification > 1 then
      Magnification := Magnification - 2
end;

end.