Новичок
Профиль
Группа: Участник
Сообщений: 8
Регистрация: 26.11.2005
Репутация: нет
Всего: нет
|
Малость припозднился, ну так вот следующий код я нашол в книге В.Фаронова "Искусство создания компонентов Delphi". | Код |
unit EditPolyPoints;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, ExtCtrls, FarRgnButton, StdCtrls, Spin, Buttons,
ImgList, ComCtrls, ToolWin;
type
TEdPolyDlg = class(TForm)
Panel1: TPanel;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
seCount: TSpinEdit;
SpeedButton1: TSpeedButton;
OpenDialog1: TOpenDialog;
SaveDialog1: TSaveDialog;
Label1: TLabel;
lbStep: TLabel;
cbStep: TCheckBox;
seStep: TSpinEdit;
BitBtn3: TBitBtn;
ToolBar1: TToolBar;
ToolButton1: TToolButton;
ToolButton2: TToolButton;
ToolButton4: TToolButton;
ToolButton5: TToolButton;
ToolButton6: TToolButton;
ToolButton7: TToolButton;
ToolButton8: TToolButton;
ToolBar2: TToolBar;
il1: TImageList;
ToolButton10: TToolButton;
ToolButton11: TToolButton;
il2: TImageList;
ToolButton3: TToolButton;
ToolButton9: TToolButton;
Box: TPaintBox;
ToolButton12: TToolButton;
ToolButton13: TToolButton;
procedure BoxPaint(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
procedure SpeedButton2Click(Sender: TObject);
procedure SpeedButton3Click(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
procedure cbStepClick(Sender: TObject);
procedure seStepChange(Sender: TObject);
procedure BitBtn3Click(Sender: TObject);
procedure ToolButton1Click(Sender: TObject);
procedure ToolButton2Click(Sender: TObject);
procedure ToolButton4Click(Sender: TObject);
procedure ToolButton5Click(Sender: TObject);
procedure ToolButton6Click(Sender: TObject);
procedure ToolButton7Click(Sender: TObject);
procedure ToolButton8Click(Sender: TObject);
procedure BoxMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure BoxMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure BoxMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormShow(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure ToolButton12Click(Sender: TObject);
private
{ Private declarations }
PolyCount: Integer;
IsMoved: Integer;
function IsPoint(X, Y: Integer): Integer;
public
{ Public declarations }
procedure PaintPoly;
procedure DrawMarker(N: Integer; Color: TColor);
procedure DrawMarkers(Color: TColor);
procedure DrawLines(Color: TColor);
procedure DrawGrid(Color: TColor);
procedure DoPoints(Count: Integer);
procedure ClearBox;
procedure PointsIToPoints;
end;
var
EdPolyDlg: TEdPolyDlg; // Экземпляр окна
Polygon: TPolygon; // Исходный полигон
PolyPoints: TPolygon; // Редактируемый полигон
PolyPointsI: TPolyPointsI; // Пиксельные координаты
Step: Integer = 8; // Шаг сетки
implementation
{$R *.dfm}
const
Scale = 250; // Смещение рабочей зоны от границ Box
procedure TEdPolyDlg.DrawLines(Color: TColor);
// Вычерчивает линии полигона цветом Color
var
k: Integer;
begin
with Box.Canvas do
begin
Pen.Color := Color;
MoveTo(PolyPointsI[1].X, PolyPointsI[1].Y);
for k := 2 to PolyPoints.Count do
LineTo(PolyPointsI[k].X, PolyPointsI[k].Y);
LineTo(PolyPointsI[1].X, PolyPointsI[1].Y)
end
end;
procedure TEdPolyDlg.PaintPoly;
// Отрисовка маркеров. Разрушает старые маркеры и создает новые
// в соответствии с относительными координатами поля PolyPoints.
// При первом обращении это поле не содержит координат, в этом
// случае копируем координаты исходного полигона из поля Polygon
var
k: Integer;
begin
if PolyPoints.Count = 0 // Координаты полигона уже были скопированы?
then // -Нет. Копируем их
for k := 0 to Polygon.Count - 1 do
PolyPoints.Add(Polygon.GetX(k), Polygon.GetY(k));
ClearBox; // Стираем старое изображение полигона
PolyCount := PolyPoints.Count;
// Координаты маркеров помещаем в массив PolyPoinysI:
for k := 1 to PolyCount do
begin
PolyPointsI[k].X :=
Trunc(PolyPoints.GetX(k - 1) * Scale) + Scale div 2;
PolyPointsI[k].Y :=
Trunc(PolyPoints.GetY(k - 1) * Scale) + Scale div 2;
end;
DrawMarkers(clBlack); // Чертим маркеры
DrawLines(clBlack) // и соединяющие линии
end;
procedure TEdPolyDlg.SpeedButton1Click(Sender: TObject);
// Щелчок на кнопке выбора количества узлов
begin
ClearBox; // Удаляем старое изображение
DoPoints(seCount.Value) // Создаем новое
end;
procedure TEdPolyDlg.ClearBox;
// Очищает рабочее поле
begin
Box.Hide;
Box.Show
end;
procedure TEdPolyDlg.DoPoints(Count: Integer);
// Создает новый полигон. Count - количество узлов
var
k: Integer;
R, XR, YR, dA: Real;
begin
dA := 2 * Pi / Count; // Угол между соседними узами
R := 0.5; // Относительный радиус описывающей окружности
// Очищаем старый полигон
PolyPoints.Clear;
// Создаем узлы нового
for k := 1 to Count do
begin
XR := R * cos(k * dA);
YR := R * sin(k * dA);
PolyPoints.Add(0.5 + XR, 0.5 - YR)
end;
PaintPoly // Чертим новый полигон
end;
procedure TEdPolyDlg.BoxPaint(Sender: TObject);
// Отрисовка полигона по координатам массива PolyPointsI
begin
DrawMarkers(clBlack);
DrawLines(clBlack)
end;
procedure TEdPolyDlg.SpeedButton2Click(Sender: TObject);
// Читает полигон из файла
var
F: File of Real;
k, i, PolyCount: Integer;
X, Y: Real;
OldPoly: TPolygon;
begin
if OpenDialog1.Execute then
begin
AssignFile(F, OpenDialog1.FileName);
Reset(F);
PolyCount := FileSize(F) div 2;
// Количество узлов должно быть не меньше трех и количество чисел
// должно быть четным
if (PolyCount < 3) or (Odd(FileSize(F)) = True) then
begin // Условия не соблюдены - ощибка
ShowMessage('Ошибка в файле ' + OpenDialog1.FileName);
Exit
end;
// Создаем копию старого полигона на случай ошибки чтения:
OldPoly := TPolygon.Create;
for k := 0 to PolyPoints.Count - 1 do with PolyPoints do
OldPoly.Add(GetX(k), GetY(k));
PolyPoints.Clear; // Очищаем старый полигон
// Цикл чтения:
for k := 1 to PolyCount do
begin
{$I-} // Отключаем автоконтроль чтения
Read(F, X, Y); // Читаем два числа
{$I+} // Включаем автоконтроль
if IOResult <> 0 then // Ошибка?
begin // -Да
ShowMessage('Ошибка в файле ' + OpenDialog1.FileName);
// Восстанавливаем сохраненный полигон:
PolyPoints.Clear;
for i := 0 to OldPoly.Count - 1 do with OldPoly do
PolyPoints.Add(GetX(i), GetY(i));
OldPoly.Clear;
OldPoly.Free; // Удаляем ненужную копию
CloseFile(F); // Закрываем файл
Exit // Выходим
end;
PolyPoints.Add(X, Y) // Создаем очередной узел
end;
OldPoly.Clear;
OldPoly.Free;
CloseFile(F)
end;
seCount.Value := PolyCount;
ClearBox;
PaintPoly
end;
procedure TEdPolyDlg.SpeedButton3Click(Sender: TObject);
// Сохраняет полигон в файле
var
F: File of Real;
k: Integer;
X, Y: Real;
begin
if SaveDialog1.Execute then
begin
AssignFile(F, SaveDialog1.FileName);
Rewrite(F);
PointsIToPoints; // Получаем текущее состояние полигона
for k := 0 to PolyPoints.Count - 1 do
begin
X := PolyPoints.GetX(k);
Y := PolyPoints.GetY(k);
Write(F, X, Y)
end;
CloseFile(F)
end
end;
procedure TEdPolyDlg.PointsIToPoints;
// Преобразует пиксельные координаты в относительные
var
k, L, T, R, B, DX, DY, PolyCount: Integer;
begin
// Определяем границы чертежа:
L := PolyPointsI[1].X;
T := PolyPointsI[1].Y;
R := L;
B := T;
for k := 2 to PolyPoints.Count do
begin
if PolyPointsI[k].X < L then
L := PolyPointsI[k].X;
if PolyPointsI[k].X > R then
R := PolyPointsI[k].X;
if PolyPointsI[k].Y < T then
T := PolyPointsI[k].Y;
if PolyPointsI[k].Y > B then
B := PolyPointsI[k].Y;
end;
// Находим размеры чертежа:
DX := R - L; // Ширина
DY := B - T; // Высота
// Создаем полигон по чертежу
PolyCount := PolyPoints.Count;
PolyPoints.Clear;
for k := 1 to PolyCount do
PolyPoints.Add((PolyPointsI[k].X - L) / DX,
(PolyPointsI[k].Y - T) / DY)
end;
procedure TEdPolyDlg.BitBtn1Click(Sender: TObject);
// Щелчок на кнопке ОК
begin
PointsIToPoints; // Освежаем полигон
ModalResult := mrOK // Закрываем диалог
end;
procedure TEdPolyDlg.cbStepClick(Sender: TObject);
// Щелчок на флажке "Сетка"
begin
if cbStep.Checked then
begin
lbStep.Visible := True;
seStep.Visible := True;
seStep.Value := Step;
DrawGrid(clBlack)
end else
begin
lbStep.Visible := False;
seStep.Visible := False;
DrawGrid(EdPolyDlg.Color)
end
end;
procedure TEdPolyDlg.DrawGrid(Color: TColor);
// Отрисовка сетки
var
x, y: Integer;
begin
with Box.Canvas do
for x := 1 to Box.Width div Step do
for y := 1 to Box.Height div Step do
Pixels[x * Step, y * Step] := Color
end;
procedure TEdPolyDlg.seStepChange(Sender: TObject);
// Изменение шага сетки
begin
DrawGrid(Color); // Удаляем старую сетку
Step := seStep.Value;
DrawGrid(clBlack) // Рисуем новую
end;
procedure TEdPolyDlg.BitBtn3Click(Sender: TObject);
// Щелчок на кнопке "Освежить"
begin
DrawMarkers(clBlack);
DrawLines(clBlack);
if cbStep.Checked then
DrawGrid(clBlack)
end;
procedure TEdPolyDlg.ToolButton1Click(Sender: TObject);
// Стандартный полигон - треугольник влево
begin
with PolyPoints do
begin
Clear;
Add(0, 0.5);
Add(1, 0);
Add(1, 1);
PaintPoly
end
end;
procedure TEdPolyDlg.ToolButton2Click(Sender: TObject);
// Стандартный полигон - треугольник вправо
begin
with PolyPoints do
begin
Clear;
Add(0, 0);
Add(1, 0.5);
Add(0, 1);
PaintPoly
end
end;
procedure TEdPolyDlg.ToolButton4Click(Sender: TObject);
// Стандартный полигон - треугольник вверх
begin
with PolyPoints do
begin
Clear;
Add(0.5, 0);
Add(1, 1);
Add(0, 1);
PaintPoly
end
end;
procedure TEdPolyDlg.ToolButton5Click(Sender: TObject);
// Стандартный полигон - треугольник вниз
begin
with PolyPoints do
begin
Clear;
Add(0, 0);
Add(1, 0);
Add(0.5, 1);
PaintPoly
end
end;
procedure TEdPolyDlg.ToolButton6Click(Sender: TObject);
// Стандартный полигон - ромб
begin
with PolyPoints do
begin
Clear;
Add(0.5, 0);
Add(1, 0.5);
Add(0.5, 1);
Add(0, 0.5);
PaintPoly
end
end;
procedure TEdPolyDlg.ToolButton7Click(Sender: TObject);
// Стандартный полигон - звезда 4
begin
with PolyPoints do
begin
Clear;
Add(0, 0.5);
Add(0.35, 0.35);
Add(0.5, 0);
Add(0.65, 0.35);
Add(1, 0.5);
Add(0.65, 0.65);
Add(0.5, 1);
Add(0.35, 0.65);
PaintPoly
end
end;
procedure TEdPolyDlg.ToolButton8Click(Sender: TObject);
// Стандартный полигон - звезда 6
begin
with PolyPoints do
begin
Clear;
Add(0.5, 0);
Add(0.36, 0.25);
Add(0.07, 0.25);
Add(0.22, 0.5);
Add(0.07, 0.75);
Add(0.36, 0.75);
Add(0.5, 1);
Add(0.64, 0.75);
Add(0.93, 0.75);
Add(0.78, 0.5);
Add(0.93, 0.25);
Add(0.64, 0.25);
PaintPoly
end
end;
procedure TEdPolyDlg.ToolButton12Click(Sender: TObject);
// Стандартный полигон - квадрат
begin
with PolyPoints do
begin
Clear;
Add(0, 0);
Add(1, 0);
Add(1, 1);
Add(0, 1);
PaintPoly
end
end;
procedure TEdPolyDlg.DrawMarker(N: Integer; Color: TColor);
// Отрисовка N-го маркера в виде квадрата 5х5
var
k: Integer;
begin
with Box.Canvas do
begin
Pen.Color := Color;
for k := 1 to 5 do
begin
// Центр квадрата определяется координатами PolyPointsI[N]
MoveTo(PolyPointsI[N].X - 2, PolyPointsI[N].Y - 3 + k);
LineTo(PolyPointsI[N].X + 2, PolyPointsI[N].Y - 3 + k);
end
end
end;
procedure TEdPolyDlg.DrawMarkers(Color: TColor);
// Отрисовка всех маркеров
var
k: Integer;
begin
for k := 1 to PolyCount do
DrawMarker(k, Color)
end;
procedure TEdPolyDlg.BoxMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
// Отслеживает попадание указателя мыши на маркер и его смещение
begin
if IsMoved <> 0 then with Box.Canvas do // Мышь нажата на маркере?
begin // -Да (IsMoved - номер маркера)
DrawMarker(IsMoved, Self.Color); // Стираем маркер
Pen.Color := Self.Color;
// Стираем связанные с ним линии:
MoveTo(PolyPointsI[IsMoved].X, PolyPointsI[IsMoved].Y);
if IsMoved = PolyCount then
LineTo(PolyPointsI[1].X, PolyPointsI[1].Y) else
LineTo(PolyPointsI[IsMoved + 1].X, PolyPointsI[IsMoved + 1].Y);
MoveTo(PolyPointsI[IsMoved].X, PolyPointsI[IsMoved].Y);
if IsMoved = 1 then
LineTo(PolyPointsI[PolyCount].X, PolyPointsI[PolyCount].Y) else
LineTo(PolyPointsI[IsMoved - 1].X, PolyPointsI[IsMoved - 1].Y);
// Новые координаты маркера
PolyPointsI[IsMoved].X := X;
PolyPointsI[IsMoved].Y := Y;
BitBtn3Click(Self) // Освежаем чертеж
end else begin // Мышь еще не нажата
if IsPoint(X, Y) <> 0 then // Мышь над маркером?
Cursor := crHandPoint else // -Да
Cursor := crDefault
end
end;
function TEdPolyDlg.IsPoint(X, Y: Integer): Integer;
// Проверяет попадание указателя в пределы маркера и
// возвращает номер маркера или 0
var
k: Integer;
begin
Result := 0;
for k := 1 to PolyCount do
if (X >= PolyPointsI[k].X - 2) and (X <= PolyPointsI[k].X + 2)
and (Y >= PolyPointsI[k].Y - 2) and (Y <= PolyPointsI[k].Y + 2) then
begin // Мышь над маркером
Result := k;
Break
end
end;
procedure TEdPolyDlg.BoxMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
// Нажатие кнопки мыши над рабочей зоной. Если над маркером, его номер
// помещается в поле IsMoved
begin
IsMoved := IsPoint(X, Y)
end;
procedure TEdPolyDlg.BoxMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
// Отпускание кнопки мыши
begin
IsMoved := 0
end;
procedure TEdPolyDlg.FormShow(Sender: TObject);
// Показывает полигон в момент появления окна
begin
PaintPoly
end;
procedure TEdPolyDlg.FormCreate(Sender: TObject);
// Создает PolyPoints при создании окна
begin
PolyPoints := TPolygon.Create
end;
procedure TEdPolyDlg.FormDestroy(Sender: TObject);
// Разрушает PolyPoints при разрушении окна
begin
PolyPoints.Clear;
PolyPoints.Free
end;
end.
|
В коде много лишнего, но разобраться можно ;) |
Как поставить маркеры по точкам векторов? 
Дата 5.2.2006, 23:25 (
Загрузка ...
