nyuuzyou/wikis huggingface dataset:
Редактор свойства Color с заданными ограничениями

=== Редактор свойства Color с заданными ограничениями ===
Редактор свойства, пример которого приведен ниже, имеет ограничение на устанавливаемые цвета: только clRed, clWhite или clBlue.
unit ClrComps;
interface
uses
 SysUtils, WinTypes, WinProcs, Messages, Classes,
 Graphics, Controls, Forms, Dialogs, DsgnIntf;
type
 TColorComponent = class(TComponent)
 private
 FColor: TColor;
 protected
 procedure SetColor(Value: TColor);
 public
 constructor Create(AnOwner: TComponent); override;
 published
 property Color: TColor read FColor write SetColor;
 end;
{ Это специальный редактор свойства выбора цветов... }
 TMyColorProperty = class(TIntegerProperty)
 public
 function GetAttributes: TPropertyAttributes; override;
 function GetValue: string; override;
 procedure GetValues(Proc: TGetStrProc); override;
 procedure SetValue(const Value: string); override;
 end;
procedure Register;
implementation
{ TMyColorProperty }
function TMyColorProperty.GetAttributes: TPropertyAttributes;
begin
 Result := [paMultiSelect, paValueList];
end;
function TMyColorProperty.GetValue: string;
begin
 Result := ColorToString(TColor(GetOrdValue));
end;
procedure TMyColorProperty.GetValues(Proc: TGetStrProc);
begin
 Proc('clRed');
 Proc('clWhite');
 Proc('clBlue');
end;
procedure TMyColorProperty.SetValue(const Value: string);
var
 NewValue: Longint;
begin
 if IdentToColor(Value, NewValue) and
 ((NewValue = clRed) or
 (NewValue = clWhite) or
 (NewValue = clBlue)) then
 SetOrdValue(NewValue);
end;
{ Образец компонента... }
constructor TColorComponent.Create(AnOwner: TComponent);
begin
 inherited Create(AnOwner);
 FColor := clRed;
end;
procedure TColorComponent.SetColor(Value: TColor);
begin
 if (Value = clRed) or
 (Value = clWhite) or
 (Value = clBlue) then
 begin
 FColor := Value;
 end;
end;
procedure Register;
begin
 RegisterComponents('Samples', [TColorComponent]);
 RegisterPropertyEditor(TypeInfo(TColor), TColorComponent,
 'Color', TMyColorProperty);
end;
end.
Author: Ed Jordan
Source: Валентина Озерова, Сборник Kuliba
ID: 00039
Режим вставки и замены

=== Режим вставки и замены ===
Элементы управления Windows TEdit и TMemo не имеют режима замены. Однако этот режим можно эмулировать установив свойство SelLength edit'а или memo в 1 при обработке события KeyPress. Это заставит его перезаписывать символ в текущей позиции курсора. В примере этот способ используется для TMemo. Режим вставка/замена переключается клавишей "Insert". 
type
 TForm1 = class(TForm)
 Memo1: TMemo;
 procedure Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
 procedure Memo1KeyPress(Sender: TObject; var Key: Char);
 private
 {Private declarations}
 InsertOn : bool;
 public
 {Public declarations}
end;
var
 Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
 if (Key = VK_INSERT) and (Shift = []) then
 InsertOn := not InsertOn;
end;
procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
 if ((Memo1.SelLength = 0) and (not InsertOn)) then
 Memo1.SelLength := 1;
end;
Source: http://delphiworld.narod.ru/
ID: 00996
Режим замены

=== Режим замены ===
Элементы управления Windows TEdit и TMemo не имеют режима замены. Однако этот режим можно эмулировать установив свойство SelLength edit'а или memo в 1 при обработке события KeyPress. Это заставит его перезаписывать символ в текущей позиции курсора. В примере этот способ используется для TMemo. Режим вставка/замена переключается клавишей "Insert". 
Пример:
type
 TForm1 = class(TForm)
 Memo1: TMemo;
 procedure Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
 procedure Memo1KeyPress(Sender: TObject; var Key: Char);
 private
 { Private declarations }
 InsertOn: bool;
 public
 { Public declarations }
 end;
var
 Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
 if (Key = VK_INSERT) and (Shift = []) then
 InsertOn := not InsertOn;
end;
procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
 if ((Memo1.SelLength = 0) and (not InsertOn)) then
 Memo1.SelLength := 1;
end;
Author: Song
Source: Взято из http://forum.sources.ru
ID: 00558
Рекурсивные механизмы спуска по дереву

=== Рекурсивные механизмы спуска по дереву ===
Нужно использовать рекурсивные механизмы спуска по дереву и иметь метод определения наличия child узлов у текущего узла. 
function TDBTreeView.RecurseChilds(node: TTreeNode): Double;
begin
 while node <> nil do
 begin
 if node.HasChildren then
 Result := RecurseChilds(node.GetFirstChild);
 Result := Result + GetResultForNode(node));
 node := node.GetNextSibling;
 end;
end;
function TDBTreeView.GetResult(curnode: TTreeNode;): Double;
begin
 Result := 0;
 if curnode = nil then Exit;
 Result := RecurseChilds(curnode.GetFirstChild);
end;
Source: http://delphiworld.narod.ru/
ID: 01124
Рекурсивный поиск с помощью функции Pos

{
Function PosN get recursive - the N th position of "Substring" in
"Mainstring". Does the Mainstring not contain Substrign the result
is 0. Works with chars and strings.
}
function PosN(Substring, Mainstring: string; n: Integer): Integer;
begin
 if Pos(Substring, Mainstring) = 0 then
 begin
 Result := 0;
 Exit;
 end
 else
 begin
 if n = 1 then
 Result := Pos(Substring, Mainstring)
 else
 begin
 Result := Pos(Substring, Mainstring) + PosN(Substring, Copy(Mainstring,
 (Pos(Substring, Mainstring) + 1), Length(Mainstring)), n - 1);
 end;
 end;
end;
// Beispiele / Examples
 i := PosN('s', 'swissdelphicenter.ch', 2);
 // i=4
 i := PosN('x', 'swissdelphicenter.ch', 1);
 // i=0
 i := PosN('delphi', 'swissdelphicenter.ch', 1);
 // i=6
Source: http://www.swissdelphicenter.ch
ID: 00881
Category:Алгоритмы
Category:Работа с текстом
Решение проблемы передачи фокуса TDBGrid

=== Решение проблемы передачи фокуса TDBGrid ===
В данном документе содержится решение проблемы невозможности получения DBGrid-ом фокуса после щелчка на каком-либо элементе управления родительской формы, в то время, как DBGrid находится на ее дочерней MDI-форме.
Относится ко всем версиям Delphi
Очевидно, DBGrid имеет некоторые проблемы с управлением фокусом, если он находится на дочерней MDI-форме. Эта проблема решена в приведенном ниже наследнике TDBGrid, в котором обрабатываются мышиные сообщения и выясняется когда фокус должен быть передан сетке. Наследник создан в виде компонента, который легко устанавливается в Палитру Компонентов. Примечание: код адаптирован для всех версий Delphi. Проблемы могут быть в Delphi 2 и 3, если вы забудете заменить устаревшие в этих версиях модули "winprocs" и "wintypes" на "windows."
unit FixedDBGrid;
interface
uses
 Winprocs, wintypes, Messages, SysUtils, Classes, Graphics,
 Controls, Forms, Dialogs, Grids, DBGrids;
type
 TFixedDBGrid = class(TDBGrid)
 private
 { Private declarations }
 protected
 { Protected declarations }
 public
 { Public declarations }
 procedure WMRButtonDown(var Message: TWMRButtonDown); message WM_RBUTTONDOWN;
 procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
 published
 { Published declarations }
 end;
procedure Register;
implementation
procedure TFixedDBGrid.WMRButtonDown(var Message: TWMRButtonDown);
begin
 winprocs.SetFocus(handle); { помните, что winprocs относится только к Delphi 1! }
 inherited;
end;
procedure TFixedDBGrid.WMLButtonDown(var Message: TWMLButtonDown);
begin
 winprocs.SetFocus(handle); { помните, что winprocs относится только к Delphi 1! }
 inherited;
end;
procedure Register;
begin
 RegisterComponents('Samples', [TFixedDBGrid]);
end;
end.
Source: Взято с http://delphiworld.narod.ru
ID: 03065
Category:Базы данных
Category:DBGrid
Римские в Арабские

=== Римские -> Арабские ===
{ **** UBPFD *********** by kladovka.net.ru ****
>> Конвертация : Римские -> арабские ; Арабские->Римские
Зависимости: 
Автор: Gua, fbsdd@ukr.net, ICQ:141585495, Simferopol
Copyright: 
Дата: 03 мая 2002 г.
********************************************** }
Const
R: Array[1..13] of String[2] =
 ('I','IV','V','IX','X','XL','L','XC','C','CD','D','CM','M');
A: Array[1..13] of Integer=
 (1,4,5,9,10,40,50,90,100,400,500,900,1000);
function RomanToArabic(S : String) : Integer; // Римские в арабские
var
 i, p : Integer;
begin
 Result := 0;
 i := 13;
 p := 1;
 while p <=Length(S) do
 begin
 while Copy(S, p, Length(R[i])) <> R[i] do
 begin
 Dec(i);
 if i = 0 then Exit;
 end;
 Result := Result + A[i];
 p := p + Length(R[i]);
 end;
end;
Source: kladovka.net.ru
ID: 00224
Рисование КРИВЫХ в Delphi

У кого-нибудь есть исходный код или какая-либо информация для рисования кривых Безье? Я должен использовать их в своем компоненте.
Я делал это недавно; мне было лениво разбираться с тем, как рисовать кривые Безье с помощью Win API, поэтому я использовал функцию Polyline().
Примечание: для координатных точек я использовал реальные величины типа floating (я применял некоторый тип виртуального экрана), округляя их до целого.
PBezierPoint = ^TBezierPoint;
TBezierPoint = record
 X, Y: Double; // основной узел
 Xl, Yl: Double; // левая контрольная точка
 Xr, Yr: Double; // правая контрольная точка
end;
// P1 и P2 - две точки TBezierPoint, расположенные между 0 и 1:
// когда t = 0 X = P1.X, Y = P1.Y; когда t = 1 X = P2.X, Y = P2.Y;
procedure BezierValue(P1, P2: TBezierPoint; t: Double; var X, Y: Double);
var
 t_sq, t_cb, r1, r2, r3, r4: Double;
begin
 t_sq := t * t;
 t_cb := t * t_sq;
 r1 := (1 - 3 * t + 3 * t_sq - t_cb) * P1.X;
 r2 := (3 * t - 6 * t_sq + 3 * t_cb) * P1.Xr;
 r3 := (3 * t_sq - 3 * t_cb) * P2.Xl;
 r4 := (t_cb) * P2.X;
 X := r1 + r2 + r3 + r4;
 r1 := (1 - 3 * t + 3 * t_sq - t_cb) * P1.Y;
 r2 := (3 * t - 6 * t_sq + 3 * t_cb) * P1.Yr;
 r3 := (3 * t_sq - 3 * t_cb) * P2.Yl;
 r4 := (t_cb) * P2.Y;
 Y := r1 + r2 + r3 + r4;
end;
Для рисования кривой Безье разделяем интервал между P1 и P2 на несколько отрезков (их количество влияет на точность воспроизведения кривой, 3 - 4 точки вполне достаточно), затем в цикле создаем массив точек, используем описанную выше процедуру с параметром t от 0 до 1 и рисуем данный массив точек, используя функцию polyline().
Author: Dmitry Streblechenko 
Source: http://delphiworld.narod.ru
ID: 03733
Category:Графика
Category:Рисование
Рисование бака с жидкостью при помощи BGRABitmap

== Рисование бака с жидкостью при помощи BGRABitmap ==
У TBGRABitmap есть свойство ClipRect, в котором можно ограничить заливку. Получился такой код:
procedure TForm1.FormPaint(Sender: TObject);
var
 Bmp: TBGRABitmap;
 MidX, MidY, EllipseHorzRadius, EllipseVertRadius, GSMY: Integer;
 FuelHeightRatio: Single;
 ClipRect: TRect;
begin
 // Создаём объект TBGRABitmap
 Bmp := TBGRABitmap.Create(Width, Height, BGRAWhite);
 try
 // Определяем размеры и координаты эллипса
 MidX := Bmp.Width div 2; // Центр по X
 MidY := Bmp.Height div 2; // Центр по Y
 EllipseHorzRadius := MidX - 10; // Горизонтальный радиус эллипса
 EllipseVertRadius := MidY - 10; // Вертикальный радиус эллипса
 // Рисуем контур эллипса (резервуара)
 Bmp.EllipseAntialias(MidX, MidY, EllipseHorzRadius, EllipseVertRadius, BGRA(128, 128, 128), 2);
 // Заполненность резервуара (1 = 100%)
 FuelHeightRatio := 0.6;
 // Создаём ограничивающий прямоугольник для заливки топлива
 GSMY := (MidY + EllipseVertRadius) - Round(EllipseVertRadius * 2 * FuelHeightRatio);
 ClipRect := Rect(0, GSMY, Bmp.Width, Bmp.Height);
 // Ограничиваем область рисования (с помощью ClipRect)
 Bmp.ClipRect := ClipRect;
 // Заливаем эллипс синим цветом (только нижнюю часть)
 Bmp.FillEllipseAntialias(MidX, MidY, EllipseHorzRadius, EllipseVertRadius, BGRA(0, 0, 255, 150));
 // Рисуем изображение на канве
 Bmp.Draw(Canvas, 0, 0);
 finally
 Bmp.Free; // Освобождаем память
 end;
end;
Author: Дмитрий Логинов
Source: https://t.me/Delphi_Lazarus/363071
Category:Графика
Category:Рисование
Рисование бака с жидкостью при помощи Graphics32

Рисование бака с жидкостью при помощи Graphics32
unit gr32_proj_unit;
{$mode objfpc}{$H+}
interface
uses
 Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls,
 GR32_Paths, GR32, GR32_Polygons, GR32_Brushes, GR32_Clipper, GR32_VectorUtils,
 GR32_Backends;
type
 { TForm1 }
 TForm1 = class(TForm)
 Button1: TButton;
 Image1: TImage;
 procedure Button1Click(Sender: TObject);
 private
 public
 end;
var
 Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
var
 AEllipse, AGSMRect: TArrayOfFloatPoint;
 AGSMIntersect: TArrayOfArrayOfFloatPoint;
 MidX, MidY, EllipseHorzRadius, EllipseVertRadius: Integer;
 Bmp32: TBitmap32;
 GsmY: Integer;
 W, H: Integer;
 Clipper: TClipper;
begin
 Bmp32 := TBitmap32.Create;
 try
 W := Image1.Width;
 H := Image1.Height;
 Bmp32.SetSize(W, H);
 Bmp32.Clear(clWhite32);
 Bmp32.Font := Canvas.Font;
 MidX := W div 2; MidY := H div 2;
 EllipseHorzRadius := MidX - 10; EllipseVertRadius := MidY - 10;
 AEllipse := Ellipse(MidX, MidY, EllipseHorzRadius, EllipseVertRadius);
 PolylineFS(Bmp32, AEllipse, clGray32, True, 2);
 // Определяем координаты линии уровня топлива
 GsmY := MidY - 40;
 //Bmp32.LineA(0, GsmY, W, GsmY, clBlue32); // Рисуем линию (для отладки)
 // Определяем полигон для ГСМ, залитого в резервуар
 // Сначала создаём квадратный полигон отчечки (ниже уровня ГСМ)
 AGSMRect := Rectangle(FloatRect(0, GsmY, W, H));
 PolylineFS(Bmp32, AGSMRect, clRed32, True, 1); // Рисуем квадрат (для отладки)
 // Создаём полигон для заливки ГСМ
 Clipper := TClipper.Create;
 try
 Clipper.AddPath(AEllipse, ptSubject);
 Clipper.AddPath(AGSMRect, ptClip);
 Clipper.Execute(ctIntersection, frNonZero, AGSMIntersect);
 finally
 Clipper.Free;
 end;
 // Рисуем ГСМ в цвете с полупрозрачностью
 PolyPolygonFS(Bmp32, AGSMIntersect, SetAlpha(clBlue32, 70));
 Bmp32.DrawTo(Image1.Canvas.Handle, 0, 0);
 finally
 Bmp32.Free;
 end;
end;
end.
Author: Дмитрий Логинов
Source: https://t.me/Delphi_Lazarus/362964
Category:Графика
Category:Рисование
Рисование без мерцания

...вот я и удивляюсь - почему я получаю мерцание, если я вызываю Repaint или Refresh, а не метод OnPaint напрямую? Или это просто "вариация на тему"?
Имеются две фазы обновления окна. В первой фазе, при выводе окна, Windows посылает ему сообщение WM_ERASEBKGND, сообщающее о необходимости стирания фона перед процедурой рисования. Затем посылается сообщение WM_PAINT, служащее сигналом для закрашивания "переднего плана".
Тем не менее, вы можете пропустить первую фазу, которая вызывает мерцание, одним из двух способов: первый способ заключается в том, что вы форсируете обновление сами, с помощью вызова функции Windows API InvalidateRect. На входе он получает дескриптор окна, указатель на закрашиваемую область - передаем NIL, если вы хотите отрисовать всю область окна - и третий параметр, сообщающий о необходимости очистки фона. Вот как раз последний параметр и должен содержать значение FALSE, если вы сами будете в методе Paint полностью отрисовывать всю область:
InvalidateRect(Handle, NIL, FALSE);
Handle должен быть дескриптором формы или элемента управления.
Описав первый способ, я скажу, что существует другое подходящее решение - использовать функциональность VCL. Вы можете указать VCL не стирать фон, добавляя [csOpaque] к значению свойства ControlStyle, как показано ниже:
ControlStyle := ControlStyle + [csOpaque];
Это ограничивает заполнение заднего фона, но вы все еще можете видеть процесс "наполнения" области изображением, т.е. процесс рисования. В этом случае вы можете отделаться от эффекта мельтешения, рисуя на TBitmap и выводя его затем на экран командой CopyRect.
Если вы хотите углубиться в тему дальше, то я отошлю вас к моей статье "Optimizing Display Updates in Delphi" (Оптимизация обновления экрана в Delphi), опубликованной в первом выпуске журнала "Delphi magazine".
Author: Mike Scott 
Source: http://delphiworld.narod.ru
ID: 03729
Category:Графика
Рисование графов

...вы могли бы использовать объект TCanvas, чем рисовать самому. В вашем случае сгодится компонент TImage, он имеет bitmap и свойство canvas, на котором очень удобно рисовать.
Пример: (Создайте новую форму, добавьте к ней Image и Button. Добавьте следующий код к обработчику события нажатия кнопки)
var
 x, l: Integer;
 y, a: Double;
begin
 Image1.Picture.Bitmap := TBitmap.Create;
 Image1.Picture.Bitmap.Width := Image1.Width;
 Image1.Picture.Bitmap.Height := Image1.Height; { Эти три строчки могут быть
 размещены в обработчике Form1.Create }
 l := Image1.Picture.Bitmap.Width;
 for x := 0 to l do
 begin
 a := (x / l) * 2 * Pi; { Преобразуем позицию по оси X к углу между 0 & 2Pi }
 y := Sin(a); { Ваша функция должна находиться здесь }
 y := y * (Image1.Picture.Bitmap.Height / 2); { Масштабируем по оси Y }
 y := y * -1; { Инвертируем Y, верх экрана это 0 ! }
 y := y + (Image1.Picture.Bitmap.Height / 2);
 { Добавляем компенсацию для среднего 0 }
 Image1.Picture.Bitmap.Canvas.Pixels[Trunc(x), Trunc(y)] := clBlack;
 end;
end;
Я обнаружил, что лучшим решением будет рисование на холсте. Предпочтительно делать это в отдельной процедуре, которая принимает в качестве параметров TCanvas и TRect. Таким способом мы может передать в качестве параметров холст вашего окна и клиентскую область для рисования на экране, и холст принтера и область клиента для ее позиционирования и печати. Чтобы посмотреть доступные для рисования подпрограммы, взгляните на методы холста.
Source: http://delphiworld.narod.ru
ID: 03743
Category:Графика
Category:Рисование
Рисование звёзд и многоугольников

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Рисование звёзд и многоугольников
Зависимости: Windows, Graphics
Автор: Fenik, chook_nu@uraltc.ru, Новоуральск
Copyright: Автор Федоровских Николай
Дата: 3 июня 2002 г.
***************************************************** }
procedure DrawStar(Canvas: TCanvas; Center, Pos: TPoint;
 R2inPercent, Ends: Byte; DrawCircle: Boolean);
{
 Рисование звёзд и многоугольников
 Center - центр фигуры;
 Pos - точка, лежащая на внешнем радиусе;
 R2inPercent - сколько процентов от внешнего радиуса составляет внутренний;
 Ends - число концов (внешних углов) фигуры;
 DrawCircle - описывать или нет возле фигуры окружность;
 R2inPercent рекомендую брать в промежутке [0; 100].
 Если R2inPercent = 100, то рисуется правильный многоугольник,
 число углов которого равно Ends.
 Все точки лежат на двух окружностях, чередуясь.
}
 function Max(A, B: Integer): Integer;
 begin
 if A > B then
 Result := A
 else
 Result := B;
 end;
 function ArcTan2(Y, X: Extended): Extended;
 asm
 FLD Y
 FLD X
 FPATAN
 FWAIT
 end;
const
 Rad = Pi / 180;
var
 R, r2, rd, len: Word;
 i: Integer;
 MemBS: TBrushStyle;
 p: array of TPoint;
 MemC: TColor;
 a, ad: Double;
begin
 if Ends < 2 then
 Exit;
 { начальный угол: }
 a := ArcTan2(Center.y - Pos.y, Pos.x - Center.x) * (180 / Pi);
 R := Max(Abs(Center.x - Pos.x), Abs(Center.y - Pos.y));
 r2 := Round(R / 100 * R2inPercent); { внутренний радиус }
 if R2inPercent <> 100 then
 len := Ends * 2
 else
 len := Ends;
 SetLength(p, len); { устанавливаем длину массива точек }
 ad := 360 / len; { угол между рядом стоящими точками }
 for i := 0 to len - 1 do
 begin
 { если i нечетный, то радиус внутренний, иначе - внешний }
 if Odd(i) then
 rd := r2
 else
 rd := R;
 p[i].x := Trunc(Cos(a * Rad) * rd) + Center.x;
 p[i].y := Trunc(Sin(a * Rad) * rd) + Center.y;
 a := a + ad; { увеличиваем угол }
 end;
 { рисуем многоугольник }
 Canvas.Polygon(p);
 if DrawCircle then
 begin
 { Рисуем окружность }
 MemC := Canvas.Brush.Color;
 MemBS := Canvas.Brush.Style;
 Canvas.Brush.Style := bsClear;
 Canvas.Ellipse(Center.x - R, Center.y - R, Center.x + R, Center.y + R);
 Canvas.Brush.Color := MemC;
 Canvas.Brush.Style := MemBS;
 end;
end;
Пример использования:
DrawStar(FBitmap.Canvas, Point(FBitmap.Width div 2, FBitmap.Height div 2),
 Point(FBitmap.Width div 2, 0), 20, 12, False);
Author: Fenik
Source: http://delphibase.endimus.com
ID: 03755
Category:Графика
Category:Рисование
Рисование квадрата мышкой

private
 { Private declarations }
 AnchorX, AnchorY,
 CurX, CurY: Integer;
 Bounding: Boolean;
 end;
implementation
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
begin
 AnchorX := X;
 CurX := X;
 AnchorY := Y;
 CurY := Y;
 Bounding := True;
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
 if Bounding then
 begin
 Canvas.Pen.Mode := pmNot;
 Canvas.Pen.Width := 2;
 Canvas.Brush.Style := bsClear;
 Canvas.Rectangle(AnchorX, AnchorY, CurX, CurY);
 CurX := X;
 CurY := Y;
 Canvas.Rectangle(AnchorX, AnchorY, CurX, CurY);
 end;
end;
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
begin
 if Bounding then
 begin
 Bounding := False;
 Canvas.Pen.Mode := pmNot;
 Canvas.Brush.Style := bsClear;
 Canvas.Rectangle(AnchorX, AnchorY, CurX, CurY);
 end;
end;
Source: http://delphiworld.narod.ru/
ID: 03756
Category:Графика
Category:Рисование
Рисование линий, Как в Paint

unit Unit1;
interface
uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, ToolWin, ComCtrls, ExtCtrls;
type
 TForm1 = class(TForm)
 Image1: TImage;
 procedure FormCreate(Sender: TObject);
 procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
 procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
 procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
 Y: Integer);
 private
 { Private declarations }
 StartX: Integer;
 StartY: Integer;
 EndX: Integer;
 EndY: Integer;
 isMousePressed: Boolean;
 public
 { Public declarations }
 end;
var
 Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
 isMousePressed := False;
 Image1.Picture.Bitmap := TBitmap.create();
 Image1.Picture.Bitmap.Width := Image1.Width;
 Image1.Picture.Bitmap.Height := Image1.Height
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
begin
 StartX := X;
 StartY := Y;
 EndX := StartX;
 EndY := StartY;
 isMousePressed := True
end;
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
begin
 isMousePressed := False;
 Image1.Picture.Bitmap.Canvas.Pen.Mode := pmNOT;
 Image1.Picture.Bitmap.Canvas.moveTo(StartX, StartY);
 Image1.Picture.Bitmap.Canvas.lineTo(EndX, EndY);
 Image1.Picture.Bitmap.Canvas.Pen.Mode := pmCopy;
 EndX := X;
 EndY := Y;
 Image1.Picture.Bitmap.Canvas.MoveTo(StartX, StartY);
 Image1.Picture.Bitmap.Canvas.LineTo(EndX, EndY)
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
 if isMousePressed then
 begin
 Image1.Picture.Bitmap.Canvas.Pen.Mode := pmNOT;
 Image1.Picture.Bitmap.Canvas.MoveTo(StartX, StartY);
 Image1.Picture.Bitmap.Canvas.LineTo(EndX, EndY);
 EndX := X;
 EndY := Y;
 Image1.Picture.Bitmap.Canvas.MoveTo(StartX, StartY);
 Image1.Picture.Bitmap.Canvas.LineTo(EndX, EndY);
 Image1.Picture.Bitmap.Canvas.Pen.Mode := pmCopy
 end
end;
end.
Более развернутую демку можно найти в папке {$DELPHI7}/Demos/Doc/Graphex
Author: Mischka
Source: http://forum.sources.ru
ID: 03825
Category:Графика
Category:Рисование