Analitcs

Pesquisar no conteúdo do blog.atlabs.com.br

segunda-feira, 10 de setembro de 2012

DELPHI - Desenhando circulos (Quadrados, Retangulos, Elipses) em TImage

Reações: 
 Coloque uma imagem qualquer no conteúdo do componente Image1.Picture, não subi no exemplo para não estender a dica aqui no blog. No demo tem uma imagem dos pinguins demo do W7
Link do demo
http://www.atlabs.com.br/blog/download/DesenhaCirculos.rar
///////////////UNIT1.pas
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, jpeg, StdCtrls;

type

  TfrmPosicaoTela = class(TForm)
    Image1: TImage;
    Shape1: TShape;
    SaveDialog1: TSaveDialog;
    ckbTransparente: TCheckBox;
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure ckbTransparenteClick(Sender: TObject);
  private
    _start, _end: TPoint;
    _Desenhando : Boolean;
    procedure CopyCanvas;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmPosicaoTela: TfrmPosicaoTela;

implementation

{$R *.dfm}

procedure TfrmPosicaoTela.CopyCanvas;
var
  DC: HDC;
  Image: TBitmap;
begin
  DC:= GetDC(GetDesktopWindow);
  try
    Image := TBitmap.Create;
    Image.Width   := Image1.Width;
    Image.Height  := Image1.Height;
    BitBlt(Image.Canvas.Handle, 0,0, Image.Width, Image.Height, DC, Image1.ClientOrigin.X, Image1.ClientOrigin.Y, SRCCOPY);
    SaveDialog1.InitialDir := 'C:\';
    SaveDialog1.FileName   := 'ImagemAlterada' + FormatDateTime('ddMMyyyyHHmmss', now) + '.bmp';
    if SaveDialog1.Execute then
    begin
      Image.SaveToFile(SaveDialog1.FileName);
    end;
  finally
    FreeAndNil(Image);
    ReleaseDC(GetDesktopWindow, DC);
  end;
end;

procedure TfrmPosicaoTela.Image1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  self._start.X := X;
  self._start.Y := Y;
  self.Shape1.Width := 0;
  self.Shape1.Height:= 0;
  self.Shape1.Left  := X;
  self.Shape1.Top   := Y;
  self.Shape1.Show;
  self.Shape1.Update;
  _Desenhando := True;
end;


procedure TfrmPosicaoTela.Image1MouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
begin
  if _Desenhando then
  begin
    self.Shape1.Width := X - self._start.X;
    self.Shape1.Height:= Y - self._start.Y;
  end;
end;

procedure TfrmPosicaoTela.Image1MouseUp(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  try
    CopyCanvas;
  finally
    _Desenhando := False;
    self.Shape1.Hide;
  end;
end;

procedure TfrmPosicaoTela.ckbTransparenteClick(Sender: TObject);
begin
  if ckbTransparente.Checked then
  Shape1.Brush.Style := bsClear;
end;
end.
///////////////UNIT1.pas


///////////////UNIT1.dfm
object frmPosicaoTela: TfrmPosicaoTela
  Left = 414
  Top = 163
  BorderStyle = bsSingle
  ClientHeight = 769
  ClientWidth = 1025
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  Position = poDesktopCenter
  PixelsPerInch = 96
  TextHeight = 13
  object Image1: TImage
    Left = 0
    Top = 0
    Width = 1025
    Height = 769
    Align = alClient
    OnMouseDown = Image1MouseDown
    OnMouseMove = Image1MouseMove
    OnMouseUp = Image1MouseUp
  end
  object Shape1: TShape
    Left = 42
    Top = 84
    Width = 137
    Height = 94
    Brush.Color = clRed
    Pen.Color = clRed
    Shape = stEllipse
    Visible = False
  end
  object ckbTransparente: TCheckBox
    Left = 0
    Top = 0
    Width = 97
    Height = 17
    Caption = 'Transparente'
    TabOrder = 0
    OnClick = ckbTransparenteClick
  end
  object SaveDialog1: TSaveDialog
    Left = 525
    Top = 69
  end
end
///////////////UNIT1.dfm

Nenhum comentário:

Postar um comentário

Observação: somente um membro deste blog pode postar um comentário.

Max Gehringer