Недавно добавленные исходники

•  TDictionary Custom Sort  3 223

•  Fast Watermark Sources  2 988

•  3D Designer  4 750

•  Sik Screen Capture  3 259

•  Patch Maker  3 466

•  Айболит (remote control)  3 526

•  ListBox Drag & Drop  2 903

•  Доска для игры Реверси  80 755

•  Графические эффекты  3 842

•  Рисование по маске  3 171

•  Перетаскивание изображений  2 544

•  Canvas Drawing  2 671

•  Рисование Луны  2 500

•  Поворот изображения  2 089

•  Рисование стержней  2 119

•  Paint on Shape  1 522

•  Генератор кроссвордов  2 180

•  Головоломка Paletto  1 730

•  Теорема Монжа об окружностях  2 156

•  Пазл Numbrix  1 649

•  Заборы и коммивояжеры  2 016

•  Игра HIP  1 261

•  Игра Go (Го)  1 200

•  Симулятор лифта  1 421

•  Программа укладки плитки  1 176

•  Генератор лабиринта  1 510

•  Проверка числового ввода  1 295

•  HEX View  1 465

•  Физический маятник  1 322

•  Задача коммивояжера  1 356

 
скрыть


Delphi FAQ - Часто задаваемые вопросы

| Базы данных | Графика и Игры | Интернет и Сети | Компоненты и Классы | Мультимедиа |
| ОС и Железо | Программа и Интерфейс | Рабочий стол | Синтаксис | Технологии | Файловая система |



Delphi Sources

Графический редактор



Часть 1.

Приложение выполняет следующие функции:

Установка основного и дополнительного цветов. Щелчок на панели цветов левой кнопкой мыши устанавливает основной цвет, а щелчок правой кнопкой – дополнительный.

Кисть – кнопка SBBrush. Закрашивает замкнутую область, ограниченныю цветом того пикселя, который указан щелчком мыши. При щелчке левой кнопкой закрашивание производится основным цветом, при щелчке правой кнопкой – вспомогательным.

Индикация цвета -кнопка SBColor. В этом режиме можно указать курсором мыши любой пиксель на изображении и, щелкнув левой кнопкой, установить цвет этого пикселя как основной, а щелкнув правой кнопкой мыши, установитьего как вспомогательный цвет.

Отмена операций, выполненных последним использованным инструментом – команда Правка|Отменить.

Открытие графического файла – команда Файл|Открыть (MOpenClick).

Вставка графического изображения типа битовой матрицы

SpeedButton: SBBrush, SBColor;
GroupIndex := 1;
AllowAllUp := true;
Glyph := ..\Images\Butons\brush.bmp;
Glyph := ..\Images\Butons\one2one.bmp;
Последовательность проектирования: ;
1. Заполнить форму;
2. var
  Bitmap: TBitMap;
  3. Form OnCreate;
  4. Form OnDestroy;
  5. MOpenClick;
  6. UndoClick;
  7. SBBrushClick и SBColor(запоминает текущий вид изображения);
  8. Image3MouseDown и копировать в Image4 MouseDown;

unit UGraphEdit;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, Buttons, ExtCtrls, Menus, ExtDlgs;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Image2: TImage;
    Image3: TImage;
    Image4: TImage;
    SBBrush: TSpeedButton;
    SBColor: TSpeedButton;
    OpenPictureDialog1: TOpenPictureDialog;
    MainMenu1: TMainMenu;
    N1: TMenuItem;
    MOpen: TMenuItem;
    N2: TMenuItem;
    Undo: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure MOpenClick(Sender: TObject);
    procedure UndoClick(Sender: TObject);
    procedure SBBrushClick(Sender: TObject);
    procedure Image3MouseDown(Sender: TObject; Button: TMouseButton; Shift:
      TShiftState; X, Y: Integer);
  private { Private declarations }
  public { Public declarations }
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
var
  BitMap: TBitMap;
    //переменная для сохранения изображения, если его нужно будет востановить командой отменить

procedure
  TForm1.FormCreate(Sender: TObject);
var
  HW, I: integer;
begin
  BitMap := TBitMap.Create;
  {задание свойств кисти основного и
  вспомогательного цветов}
  Image1.Canvas.Brush.Color := clBlack;
  Image2.Canvas.Brush.Color := clWhite;
  {заполнение окон основного и вспомогательного
  цветов}
  with
    Image1.Canvas do
    FillRect(Rect(0, 0, Width, Height));
  with Image2.Canvas do
    FillRect(Rect(0, 0, Width, Height));
  {задание ширины элемента палитры
  цветов}
  HW := Image4.Width
    div 10;
  {закраска элементов палитры цветов}
  with
    Image4.Canvas do
    for I := 1 to 10 do
    begin
      case I of

        1: Brush.Color := clBlack;
        2: Brush.Color := clAqua;
        3: Brush.Color := clBlue;
        4: Brush.Color := clFuchsia;
        5: Brush.Color := clGreen;
        6: Brush.Color := clLime;
        7: Brush.Color := clMaroon;
        8: Brush.Color := clRed;
        9: Brush.Color := clYellow;
        10: Brush.Color := clWhite;
      end;
      Rectangle((I - 1) * HW, 0, I * HW, Height);
    end;
{рисование креста на холсте – только для
тестирования}
with Image3 do
begin
  Canvas.MoveTo(0, 0);
  Canvas.LineTo(Width, Height);
  Canvas.MoveTo(0, Height);
  Canvas.LineTo(Width, 0);
end;
BitMap.Assign(Image3.Picture);
end;

procedure TForm1.FormDestroy(Sender:
  TObject);
begin
  BitMap.Free;
end;

procedure TForm1.MOpenClick(Sender:
  TObject);
begin
  if OpenPictureDialog1.Execute then
  begin
    Image3.Picture.LoadFromFile(OpenPictureDialog1.FileName);
    BitMap.Assign(Image3.Picture);
  end;
end;

procedure TForm1.UndoClick(Sender:
  TObject);
begin
  Image3.Picture.Assign(BitMap);
end;

procedure
  TForm1.SBBrushClick(Sender: TObject);
begin
  if (Sender as TSpeedButton).Down then
    BitMap.Assign(Image3.Picture);
end;

procedure
  TForm1.Image3MouseDown(Sender: TObject; Button: TMouseButton; Shift:
  TShiftState; X, Y: Integer);
begin
  if (Sender = Image4) or SBColor.Down then
    {режим установки основного и вспомогательного
    цветов}
  begin
    if (Button = mbLeft) then
      with Image1.Canvas do
      begin
        {установка основного
        цвета}
        Brush.Color := (Sender as
          TImage).Canvas.Pixels[X, Y];
        FillRect(Rect(0, 0, Width, Height));
      end
    else
      with Image2.Canvas do
      begin
        {установка вспомогательного
        цвета}
        Brush.Color := (Sender as
          TImage).Canvas.Pixels[X, Y];
        FillRect(Rect(0, 0, Width, Height));
      end;
  end
  else if SBBrush.Down then
    with Image3.Canvas do
    begin
      {режим закраски указанной области
      холста}
      if
        Button = mbLeft then
        Brush.Color := Image1.Canvas.Brush.Color
      else
        Brush.Color := Image2.Canvas.Brush.Color;
      FloodFill(X, Y, Pixels[X, Y], fsSurface);
    end;
end;
end.

8. OnMouseDown – это основной код, осуществляющий как установку основного и вспомогательных цветов, так и функцию инструмента графического редактора – кисти.

Если кнопка мыши нажата на палитре цветов, Image4, или если кнопка SBColor – кнопка указателя цвета утоплена, то приложение находится в режиме установки цветов. При нажатой левой кнопки мыши цвет пикселя под курсором мыши передается в окно основного цвета, а при нажатой правой кнопки – в окно вспомогательного цвета.

Если кнопка мыши нажата на холсте, Image3, или если кнопка SBColor – кнопка указателя цвета утоплена, то приложение находится в режиме закраски указанной области рисунка. В этом случае в зависимости от нажатой кнопки мыши выбирается основной или вспомогательный цвет и функцией FloodFill производится закраска области, координаты внутренней точки которой указаны курсором мыши, а цвет – цветом пикселя, на который указывает мышь.

Часть 2.

Дополнительные функции графического редактора:


Функция выделения фрагмента осуществляется методом DrawFocusRect.В этом режиме
при событии onMouseDown холста – компонента Image3, выполняются операторы:
{запоминание начального положения курсора мыши}

X0 := X;
//запоминание координаты мыши X,Y в переменных X0,Y0;
Y0 := Y; //начальные координаты прямоугольной области – переменной R типа TRect;
{формирование начального положения области фрагмента};

R.TopLeft := Point(X, Y);
R.BottomRight := Point(X, Y); {рисование рамки}

Image3.DrawFocusRect(R);
  //рисуется рамка пока нулевого размера методом DrawFocusRect;
RBegin := true;
{утанавливается флаг начала выделения фрагмента RBegin;При событии onMouseMove компонента Image3, 
если установлен флаг RBegin, выпол-няются операторы:}
Выделение фрагмента – кнопка SBRect. Фрагмент выделяется точечной рамкой. Выделенный фрагмент можно в дальнейшем перетащить мышью на другое место. Если в процессе перетаскивания нажата клавиша Ctrl, то производится копирование фрагмента, в противном случае вырезание, при котором область первоначального размещения фрагмента закрашивается вспомогательным цветом. Выделенный фрагмент может быть также скопирован или вырезан в буфер обмена Clipboard соответствующими командами меню.

{Стирание прежней рамки фрагмента}
Image3.Canvas.DrawFocusRect(R);
  //метод DrawFocusRect рисует рамку с помощью операции XOR;
{формирование области R};
if X0 < X then //область, передаваемая в функцию DrawFocusRect
begin
  R.Left := X0;
  R.Right := X
end // должна быть сформирована так, что R.Left<R.Right и
else
begin
  R.Left := X;
  R.Right := X0
end; // R.Top<R.Buttom
if Y0 < Y then
begin
  R.Top := Y0;
  R.Bottom := Y
end
else
begin
  R.Top := Y;
  R.Bottom := Y0
end;
{Рисования новой рамки фрагмента}
Image3.Canvas.DrawFocusRect(R);
{Рамка,ограничивающая фрагмент нарисована. Если пользовательпомещает курсор внутрь выделенной
области и нажимает кнопку мыши (onMouseDown), выполняют-ся операторы:}
with Image3.Canvas do
begin
  ;
  X0 := X; //запоминание начального положения курсора мыши
  Y0 := Y;
  DrawFocusRect(R); {стирание прежней рамки}
  ;
  RDrag := true; //устанавливает флаг перетаскивания RDrag;
  REnd := false;
  {запоминание начального положения перетаскиваемого фрагмента в переменной R0 типа TRect};
  R0.TopLeft := R.TopLeft;
  R0.BottomRight := R.BottomRight;
  {запоминание методом  Assign изображения в момент начала перетаскивания в переменно BitMap,
  чтобы в процессе перетаскивания можно было восстанавливать испорченные места изображения и
  чтобы при желании пользователя можно было в дальнейшем отменить результат перетаскивания};
  BitMap.Assign(Image3.Picture);
  {установка цвета кисти равным вспомогательному цвету, хранящемуся в компоненте Image2};
  Brush.Color := Image2.Canvas.Brush.Color;
end;
{При событии onMouseMove компонента Image3, если установлен флаг RDrag, выпол-няются операторы:
восстановление изображения под перетаскиваемым фрагментом в его прежней позиции, (т.е. стирает фрагмент)
  копируя соответствующую область методом CopyRect из компо-нента BitMap };
CopyRect(R, BitMap.Canvas, R);
{если не нажата клавиша Ctrl - стирание изображения в R0(осуществляется вырезание) ме-тодом FillRect };
if not (ssCtrl in Shift) then
  FillRect(R0);
{формирование нового положения фрагмента }
R.Left := R.Left + X - X0;
R.Right := R.Right + X - X0;
R.Top := R.Top + Y - Y0;
R.Bottom := R.Bottom + Y - Y0;
{запоминание положения курсора мыши};
X0 := X;
Y0 := Y;
{рисование фрагмента в новом положении};
CopyRect(R, BitMap.Canvas, R0); {рисование рамки}
DrawFocusRect(R);
{Таким образом проводится операция выделения фрагрента и его перетаскивания.}
Рисование прямоугольника – кнопка SBRectang. Рисуется прямоугольная рамка основным цветом.

Начало режимов рисования заполненного и незаполненного прямоугольников про-исходит по событию onMouseDown и их продолжение по событиям onMouseMove и не отличаются от рассмотренного режима выделения фрагмента.;При завершении формирования пользователем прямоугольной рамки, т.е. при собы-тии MouseUp, надо нарисовать прямоугольник. ;Рисование заполненного прямоугольника осуществляется операторами:
with Image3.Canvas do
begin
  Brush.Color := Image2.Canvas.Brush.Color; //задается цвет кисти;
  Pen.Color := Image1.Canvas.Brush.Color; //задается цвет пера;
  Rectangle(R.Left, R.Top, R.Right, R.Bottom);
end;
Рисование незакрашенного прямоугольника осуществляется операторами:
with Image3.Canvas do
begin
  Brush.Color := Image1.Canvas.Brush.Color;
  FrameRect(R); //метод FrameRect рисует цветом кисти;
end;
Рисование заполненного прямоугольника – кнопка SBFillRec. Рисуется прямоугольная рамка основным цветом и прямоугольник внутри закрашивается вспомогательным цветом.

Возможные значения свойства Mode пера Pen

pmCopy – линии проводятся цветом, заданным в свойстве Color
pmBlack Always black
pmWhiteAlways white
pmNopUnchanged
pmNot Inverse of canvas background color
pmCopy Pen color specified in Color property
pmNotCopyInverse of pen color
pmMergePenNot Combination of pen color and inverse of canvas background
pmMaskPenNotCombination of colors common to both pen and inverse of canvas background.
pmMergeNotPen Combination of canvas background color and inverse of pen color
pmMaskNotPenCombination of colors common to both canvas background and inverse of pen
pmMerge Combination of pen color and canvas background color
pmNotMergeInverse of pmMerge: combination of pen color and canvas background color
pmMask Combination of colors common to both pen and canvas background
pmNotMaskInverse of pmMask: combination of colors common to both pen and canvas background
pmXorСложение с фоном по исключающему

{ИЛИ (линия появляется только в момент отпускания мыши)
pmNotXorСложение с фоном по инверсному исключающему ИЛИ}
Начало рисования прямой линии осуществляется по событию onMouseDown:
X0 := X;
Y0 := Y;
X1 := X;
Y1 := Y;
Image3.Canvas.Pen.Color := Image1.Canvas.Brush.Color;
  //устанавливается цвет пера;
Image3.Canvas.Pen.Mode := pmNotXor;
  //режим pmNotXor позволяет при движении мыши стирать изображение линии;

Рисование прямой линии – кнопка SBLine.Рисуется прямая линия основным цветом.

Продолжение рисования прямой линии осуществляется по событию onMouseMove:
with Image3.Canvas do
begin
  {стирание прежней линии}
  MoveTo(X0, Y0);
    //стирается линия в прежнем положении (это необходимо, т.к. метод LineTo
  LineTo(X1, Y1);
    //рисует линию,начинающуюся в текущей позиции пера и заканчивающуюся
  {рисование новой линии}//в указанной точке, исключая эту конечную точку.
  MoveTo(X0, Y0); //рисуется новая линия;
  LineTo(X, Y);
  X1 := X; {запоминание новых координат конца линии}
  Y1 := Y;
end;
Заключительные операции при событии MouseUp аналогичны рассмотренным выше, но дополняются переводом пера в режим pmCopy, при котором рисуется окончатель-ная линия:
with Image3.Canvas do
begin
  MoveTo(X0, Y0); //стирание прежней линии;
  LineTo(X1, Y1);
  Pen.Mode := pmCopy; //рисование новой линии;
  MoveTo(X0, Y0);
  LineTo(X, Y);
end;
Карандаш – кнопка SBPen. Можно рисовать произвольную кривую основным цветом. Glyph:=..\Images\Butons\pencil.bmp

При реализации этого инструмента в виде:
Image3.Canvas.Pixels[X, Y] := Image3.Canvas.Brush.Color;
линия распадется на отдельные точки, так как курсор мыши перемещаетяс быстро и события onMouseMove происходят вовсе не при перемещении на соседний пик-сель. Линию,оставляемую курсором тоже нужно рисовать методом LineTo, помес-тив в обработчик события onMouseMove оператор:
Image3.Canvas.LineTo(X, Y);
Стирание изображения (ластик) – кнопка SBErase. Перемещение ластика закрашивает область под ним во вспомогательный цвет.

Ластик реализуется методом FillRect, очищающим изображение под его рамкой.

Сохранение файла осуществляется с использованием компонента SavePictureDialog оператором:
procedure TForm1.MSaveClick(Sender: TObject);
begin
  if SavePictureDialog1.Execute then
  begin
    BitMap.Assign(Image3.Picture); //сохранение изображения;
    BitMap.SaveToFile(SavePictureDialog1.FileName); //запись в файл изображения;
  end;
end;
Сохранение изображения в графическом файле – команда Файл/Сохранить как…

Копированию или вырезанию подлежит ранее выделенный пользователем объект, местоположение и размеры которого определяются переменной R. Поэтому сначала создается временный объект типа TBitMap, в который переносится копируемый фрагмент. Затем объект копируется в ClipBoard.
procedure TForm1.MCopyClick(Sender: TObject);
var
  BMCopy: TBitMap;
begin
  Image3.Canvas.DrawFocusRect(R); {стирание рамки}
  BMCopy := BitMap.Create; {создание временного объекта BMCopy }
  BMCopy.Width := R.Right - R.Left;
  BMCopy.Height := R.Bottom - R.Top;
  try
    {копирование объекта в BMCopy }
    BMCopy.Canvas.Copyrect(Rect(0, 0, BMCopy.Width, BMCopy.Height),
      Image3.Canvas, R);
    Image3.Canvas.DrawFocusRect(R); {восстановление рамки}
    ClipBoard.Assign(BMCopy); {копирование в Clipboard}
    if (Sender as TMenuItem).Name = 'MCut' then
    begin
      Image3.Canvas.Brush.Color := clWhite; {вырезание}
      Image3.Canvas.FillRect(R);
    end;
  finally
    {благодаря разделу finally память освобождается от временного объекта при любом исходе
    копирования: удачном или аварийном}
    BMCopy.Free; {освобождение памяти}
  end;
end;
Копирование или вырезание выделенного фрагмента изображения в буфер обмена Clipboard – команды Правка|Копировать или Правка|Вырезать

Чтение из ClipBoard осуществляется методом LoadFromClipBoardFormat. Предусмотрен перехват исключения EInvalidGraphic, если в ClipBoard содержится не битовая матрица:
procedure TForm1.MPasteClick(Sender: TObject);
var
  BMCopy: TBitMap;
begin
  BMCopy := BitMap.Create;
  try
    try
      BMCopy.LoadFromClipBoardFormat(cf_BitMap,
        ClipBoard.GetAsHandle(cf_Bitmap), 0);
      Image3.Canvas.CopyRect(Rect(0, 0, BMCopy.Width, BMCopy.Height);
        BMCopy.Canvas, Rect(0, 0, BMCopy.Width, BMCopy.Height));
    finally
      BMCopy.Free;
    end;
  except
    on EInvalidGraphic do
      ShowMessage('Ошибочный формат графики');
  end;
end;
Вставка графического изображения типа битовой матрицы из буфера обмена Clipboard – команды Правка|Вставить.

Попробуйте усовершенствовать редактор, добавив в него, например, выбор ширины линий, рисование эллипсов и т.д.

Далее приведен полный текст дополнений к редактору представленному в части 1:

В класс TForm1 добавить:
TForm1 = class(TForm)
  MFile: TMenuItem;
  SBRect: TSpeedButton;
  SBRectang: TSpeedButton;
  SBFillRec: TSpeedButton;
  SBErase: TSpeedButton;
  SBPen: TSpeedButton;
  SBLine: TSpeedButton;
  MSave: TMenuItem;
  MCut: TMenuItem;
  MCopy: TMenuItem;
  MPaste: TMenuItem;
  SavePictureDialog1: TSavePictureDialog;
  procedure Image3MouseDown(Sender: TObject; Button:
    TMouseButton; Shift: TShiftState; X, Y: Integer); //доб.
  procedure SBBrushClick(Sender: TObject);
  procedure Image3MouseMove(Sender: TObject; Shift:
    TShiftState; X, Y: Integer);
procedure Image3MouseUp(Sender: TObject; Button:
  TMouseButton; Shift: TShiftState; X, Y: Integer);
  procedure MOpenClick(Sender: TObject);
    procedure MCopyClick(Sender: TObject);
      procedure MPasteClick(Sender: TObject);
        procedure MSaveClick(Sender: TObject);
          …………………………………………….
end;
implementation
{$R *.DFM}
var
  BitMap, BMCopy: TBitMap;
  R, R0: TRect;
  X0, Y0, X1, Y1: longint;
const
  RBegin: boolean = false; //флаг начала выделения фрагмента
  REnd: boolean = false; //
  RDrag: boolean = false; //флаг
  перетаскивания

  procedure
  TForm1.Image3MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if (Sender = Image4) or SBColor.Down then
    {режим установки основного и вспомогательного
    цветов}
  begin
    if (Button = mbLeft) then
      with Image1.Canvas do
      begin
        {установка основного
        цвета}
        Brush.Color := (Sender as
          TImage).Canvas.Pixels[X, Y];
        FillRect(Rect(0, 0, Width, Height));
      end
    else
      with Image2.Canvas do
      begin
        {установка вспомогательного
        цвета}
        Brush.Color := (Sender as TI //mage).Canvas.Pixels[X,Y];
          FillRect(Rect(0, 0, Width, Height));
      end;
  end
  else
    with Image3.Canvas do
    begin
      X0 := X;
      Y0 := Y;
      if SBPen.Down then
      begin
        {режим карандаша}
        MoveTo(X, Y);
        Pen.Color := Image1.Canvas.Brush.Color;
      end
      else if SBLine.Down then
      begin
        {режим линии}
        X1 := X;
        Y1 := Y;
        Pen.Mode := pmNotXor;
        Pen.Color := Image1.Canvas.Brush.Color;
      end
      else if SBBrush.Down then
      begin
        {режим закраски указанной области
        холста}
        if
          Button = mbLeft then
          Brush.Color := Image1.Canvas.Brush.Color
        else
          Brush.Color := Image2.Canvas.Brush.Color;
        FloodFill(X, Y, Pixels[X, Y], fsSurface);
      end
      else if SBErase.Down then
      begin
        {режим ластика}
        R := Rect(X - 6, Y - 6, X + 6, Y + 6);
        DrawFocusRect(R);
        Brush.Color := Image2.Canvas.Brush.Color;
        FillRect(Rect(X - 5, Y - 5, X + 5, Y + 5));
      end
      else if SBRect.Down or SBRectang.Down or
        SBFillRec.Downthen
      begin
      {режим работы с фрагментом}
      if REnd then
      begin
        {стирание прежней рамки}
        DrawFocusRect(R);
        if (X < R.Right) and (X > R.Left) and (Y > R.Top) and
          (Y < R.Bottom)
          {режим начала перетаскивания
        фрагмента} then
        begin
          {установка флагов}
          RDrag := true;
          REnd := false;
          {запоминание начального положения
          перетаскиваемого фрагмента}
          R0.TopLeft := R.TopLeft;
          R0.BottomRight := R.BottomRight;
          {запоминание
          изображения}
          BitMap.Assign(Image3.Picture);
          {установка
          цвета
          кисти}
          Brush.Color := Image2.Canvas.Brush.Color;
          MCopy.Enabled := false;
          MCut.Enabled := false;
        end;
      end
      else
      begin
        {режим начала рисования рамки
        фрагмента}
        RBegin := true;
        REnd := false;
        R.TopLeft := Point(X, Y);
        R.BottomRight := Point(X, Y);
        DrawFocusRect(R);
      end;
    end;
    end;
end;

procedure
  TForm1.SBBrushClick(Sender: TObject);
begin
  if (Sender as TSpeedButton).Down then
    BitMap.Assign(Image3.Picture);
  RBegin := false;
  RDrag := false;
  REnd := false;
end;

procedure
  TForm1.Image3MouseMove(Sender: TObject; Shift: TShiftState; X, Y:
  Integer);
begin
  if not (ssLeft in Shift) then
    exit;
  {режим линии}
  if SBLine.Down then
    with
      Image3.Canvas do
    begin
      {стирание прежней линии}
      MoveTo(X0, Y0);
      LineTo(X1, Y1);
      {рисование новой линии}
      MoveTo(X0, Y0);
      LineTo(X, Y);
      {запоминание новых координат конца
      линии}
      X1 := X;
      Y1 := Y;
    end
  else if SBPen.Down then
    Image3.Canvas.LineTo(X, Y)
  else if SBErase.Down then
    with Image3.Canvas do
    begin
      {режим ластика}
      DrawFocusRect(R);
      R := Rect(X - 6, Y - 6, X + 6, Y + 6);
      DrawFocusRect(R);
      FillRect(Rect(X - 5, Y - 5, X + 5, Y + 5));
    end
  else if (SBRect.Down and (RBegin or RDrag)) or
    SBRectang.Down or SBFillRec.Down then
    with Image3.Canvas do
    begin
      if RBegin then
      begin
        {Режим рисования рамки фрагмента}
        DrawFocusRect(R);
        if X0 < X then
        begin
          R.Left := X0;
          R.Right := X
        end
        else
        begin
          R.Left := X;
          R.Right := X0
        end;
        if Y0 < Y then
        begin
          R.Top := Y0;
          R.Bottom := Y
        end
        else
        begin
          R.Top := Y;
          R.Bottom := Y0
        end;
        DrawFocusRect(R);
      end
      else if SBRect.Down then
      begin
        {Режим перетаскивания фрагмента}
        {восстановление изображения под перетаскиваемым
        фрагментом}
        CopyRect(R, BitMap.Canvas, R);
        {если не нажата клавиша Ctrl - стирание
        изображения в R0}
        if not (ssCtrl in Shift) then
          FillRect(R0);
        {формирование нового положения фрагмента
        }
        R.Left := R.Left + X - X0;
        R.Right := R.Right + X - X0;
        R.Top := R.Top + Y - Y0;
        R.Bottom := R.Bottom + Y - Y0;
        {запоминание положения курсора мыши}
        X0 := X;
        Y0 := Y;
        {рисование фрагмента в новом
        положении}
        CopyRect(R, BitMap.Canvas, R0);
        {рисование
        рамки}
        DrawFocusRect(R);
      end;
    end;
end;

procedure
  TForm1.Image3MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  with Image3.Canvas do
  begin
    if SBLine.Down then
    begin
      MoveTo(X0, Y0);
      LineTo(X1, Y1);
      Pen.Mode := pmCopy;
      MoveTo(X0, Y0);
      LineTo(X, Y);
    end
    else if SBRect.Down then
    begin
      if RDrag then
        DrawFocusRect(R);
      if RBegin and not REndthen
      begin
        REnd := true;
        MCopy.Enabled := true;
        MCut.Enabled := true;
      end
    end
    else if SBRectang.Down then
    begin
      Brush.Color := Image1.Canvas.Brush.Color;
      FrameRect(R);
    end
    else if SBFillRec.Down then
    begin
      Brush.Color := Image2.Canvas.Brush.Color;
      Pen.Color := Image1.Canvas.Brush.Color;
      Rectangle(R.Left, R.Top, R.Right, R.Bottom);
    end
    else if
      SBErase.Downthen
      Image3.Canvas.DrawFocusRect(R);
    RBegin := false;
    RDrag := false;
  end;
end;

procedure
  TForm1.MCopyClick(Sender: TObject);
{var
MyFormat: Word;
AData: THandle;
APalette: HPALETTE;}
begin
  Image3.Canvas.DrawFocusRect(R);
  BMCopy := BitMap.Create;
  BMCopy.Width := R.Right - R.Left;
  BMCopy.Height := R.Bottom - R.Top;
  try
    BMCopy.Canvas.Copyrect(Rect(0, 0, BMCopy.Width, BMCopy.Height),
      Image3.Canvas, R);
    Image3.Canvas.DrawFocusRect(R);
    {BMCopy.SaveToClipBoardFormat(MyFormat,AData,APalette);
    ClipBoard.SetAsHandle(MyFormat,AData);}
    ClipBoard.Assign(BMCopy);
    if (Sender as TMenuItem).Name = 'MCut' then
    begin
      Image3.Canvas.Brush.Color := clWhite;
      Image3.Canvas.FillRect(R);
    end;
  finally
    BMCopy.Free;
  end;
end;

procedure
  TForm1.MPasteClick(Sender: TObject);
begin
  BMCopy := BitMap.Create;
  try
    try
      BMCopy.LoadFromClipBoardFormat(cf_BitMap,
        ClipBoard.GetAsHandle(cf_Bitmap), 0);
      Image3.Canvas.CopyRect(Rect(0, 0, BMCopy.Width, BMCopy.Height),
        BMCopy.Canvas, Rect(0, 0, BMCopy.Width, BMCopy.Height));
    finally
      BMCopy.Free;
    end;
  except
    on EInvalidGraphic do
      ShowMessage('Ошибочный формат графики');
  end;
end;

procedure
  TForm1.MSaveClick(Sender: TObject);
begin
  if SavePictureDialog1.Execute then
  begin
    BitMap.Assign(Image3.Picture);
    BitMap.SaveToFile(SavePictureDialog1.FileName);
  end;
end;
end.




Похожие по теме исходники

Редактор XPad




Copyright © 2004-2024 "Delphi Sources" by BrokenByte Software. Delphi World FAQ

Группа ВКонтакте