Delphi - Графика
Есть прога-не большой паинт
Есть кривая, линия, круг, прямоугольник
Как при нажатие кнопки сделать трехмерные объекты из уже нарисованного, тоесть
если нарисована линия то просто палку в 3D формате, с тремя проекциями
если нарисована кривая то просто шланг в 3D формате, с тремя проекциями
если нарисован круг то просто сферу в 3D формате, с тремя проекциями
если нарисована прямоугольник то просто прямоугольник в 3D формате, с тремя проекциями
Чтоб рисунки не чем не отличались кроме того что одни в 3D формате, с тремя проекциями,
с одинаковыми размерами
Хотелось бы увидеть код, очень
Всем заранее спасибо
вот код паинта
unit Unit1;
interface
uses
Windows,Graphics,Forms,Controls, Dialogs, Buttons, ExtCtrls, StdCtrls,
Classes;
const
crMove = 1;
type
TDrawType = (dtLineDraw, dtRectangle, dtEllipse, dtRoundRect,
dtClipRect, dtCrooked);
TForm1 = class(TForm)
OpenDialog: TOpenDialog;
Panel1: TPanel;
Panel2: TPanel;
sbLine: TSpeedButton;
sbRectangle: TSpeedButton;
sbEllipse: TSpeedButton;
sbFreeForm: TSpeedButton;
Button1: TButton;
Button2: TButton;
Button3: TButton;
Panel3: TPanel;
imgDrawingPad: TImage;
SaveDialog: TSaveDialog;
procedure FormCreate(Sender: TObject);
procedure sbLineClick(Sender: TObject);
procedure imgDrawingPadMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure imgDrawingPadMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure imgDrawingPadMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure mmiExitClick(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure mmiNewFileClick(Sender: TObject);
procedure pbPasteBoxMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure pbPasteBoxMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure pbPasteBoxPaint(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
public
{ Public declarations }
MouseOrg: TPoint;
NextPoint: TPoint;
Drawing: Boolean;
DrawType: TDrawType;
FillSelected,
BorderSelected: Boolean;
EraseClipRect: Boolean;
Modified: Boolean;
FileName: String;
OldClipViewHwnd: Hwnd;
PBoxMoving: Boolean;
PBoxMouseOrg: TPoint;
PasteBitMap: TBitmap;
Pasted: Boolean;
LastDot: TPoint;
procedure DrawToImage(TL, BR: TPoint; PenMode: TPenMode);
procedure SetDrawingStyle;
end;
var
Form1: TForm1;
Rslt: Word;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
BorderIcons := [biSystemMenu]+[biMinimize];
Screen.Cursors[crMove] := LoadCursor(hInstance, 'MOVE');
FillSelected := False;
BorderSelected := True;
Modified := False;
FileName := '';
Pasted := False;
with imgDrawingPad do
begin
SetBounds(0, 0, 600, 400);
Picture.Graphic := TBitMap.Create;
Picture.Graphic.Width := 600;
Picture.Graphic.Height := 400;
end;
PasteBitmap := TBitmap.Create;
OldClipViewHwnd := SetClipBoardViewer(Handle);
end;
procedure TForm1.DrawToImage(TL, BR: TPoint; PenMode: TPenMode);
begin
with imgDrawingPad.Canvas do
begin
Pen.Mode := PenMode;
case DrawType of
dtLineDraw:
begin
MoveTo(TL.X, TL.Y);
LineTo(BR.X, BR.Y);
end;
dtRectangle:
Rectangle(TL.X, TL.Y, BR.X, BR.Y);
dtEllipse:
Ellipse(TL.X, TL.Y, BR.X, BR.Y);
dtRoundRect:
RoundRect(TL.X, TL.Y, BR.X, BR.Y,
(TL.X - BR.X) div 2, (TL.Y - BR.Y) div 2);
dtClipRect:
Rectangle(TL.X, TL.Y, BR.X, BR.Y);
end;
end;
end;
procedure TForm1.imgDrawingPadMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Modified := True;
if (DrawType = dtClipRect) and EraseClipRect then
DrawToImage(MouseOrg, NextPoint, pmNotXOR)
else if (DrawType = dtClipRect) then
EraseClipRect := True;
Drawing := True;
MouseOrg := Point(X, Y);
NextPoint := MouseOrg;
LastDot := NextPoint;
imgDrawingPad.Canvas.MoveTo(X, Y);
end;
procedure TForm1.imgDrawingPadMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
if Drawing then
begin
if DrawType = dtCrooked then
begin
imgDrawingPad.Canvas.MoveTo(LastDot.X, LastDot.Y);
imgDrawingPad.Canvas.LineTo(X, Y);
LastDot := Point(X,Y);
end
else begin
DrawToImage(MouseOrg, NextPoint, pmNotXor);
NextPoint := Point(X, Y);
DrawToImage(MouseOrg, NextPoint, pmNotXor)
end;
end;
end;
procedure TForm1.imgDrawingPadMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Drawing then
if not (DrawType = dtClipRect) then
DrawToImage(MouseOrg, Point(X, Y), pmCopy);
Drawing := False;
end;
procedure TForm1.sbLineClick(Sender: TObject);
begin
if DrawType = dtClipRect then
DrawToImage(MouseOrg, NextPoint, pmNotXOR);
if Sender is TSpeedButton then
DrawType := TDrawType(TSpeedButton(Sender).Tag);
if DrawType = dtClipRect then begin
EraseClipRect := False;
end;
SetDrawingStyle;
end;
procedure TForm1.SetDrawingStyle;
begin
with imgDrawingPad do
begin
if DrawType = dtClipRect then
begin
Canvas.Pen.Style := psDot;
Canvas.Brush.Style := bsClear;
Canvas.Pen.Color := clBlack;
end
else if FillSelected then
Canvas.Brush.Style := bsSolid
else
Canvas.Brush.Style := bsClear;
if BorderSelected then
Canvas.Pen.Style := psSolid
else
Canvas.Pen.Style := psClear;
end;
end;
procedure TForm1.mmiExitClick(Sender: TObject);
begin
Close;
end;
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose := False;
if Modified then begin
Rslt := MessageDlg('Сохранить?', mtConfirmation, mbYesNOCancel, 0);
case Rslt of
mrNo: ;
mrCancel: Exit;
end
end;
CanClose := True;
end;
procedure TForm1.mmiNewFileClick(Sender: TObject);
var
Rslt: Word;
begin
if Modified then begin
Rslt := MessageDlg('Сохранить?', mtConfirmation, mbYesNOCancel, 0);
case Rslt of
mrNo: ;
mrCancel: Exit;
end
end;
with imgDrawingPad.Canvas do begin
Brush.Style := bsSolid;
Brush.Color := clWhite;
FillRect(ClipRect);
FileName := '';
end;
SetDrawingStyle;
Modified := False;
end;
procedure TForm1.pbPasteBoxMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
PBoxMoving := True;
Screen.Cursor := crMove;
PBoxMouseOrg := Point(X, Y);
end
else
PBoxMoving := False;
end;
procedure TForm1.pbPasteBoxMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if PBoxMoving then
begin
PBoxMoving := False;
Screen.Cursor := crDefault;
end;
end;
procedure TForm1.pbPasteBoxPaint(Sender: TObject);
var
SrcRect: TRect;
begin
if Pasted then
begin
if not PBoxMoving then
begin
SrcRect := Rect(0, 0, PasteBitmap.Width, PasteBitmap.Height);
end;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
ChangeClipBoardChain(Handle, OldClipViewHwnd);
PasteBitmap.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Rslt: Word;
begin
with imgDrawingPad.Canvas do begin
Brush.Style := bsSolid;
Brush.Color := clWhite;
FillRect(ClipRect);
FileName := '';
end;
SetDrawingStyle;
Modified := False;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
Close;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if SaveDialog.Execute then
begin
imgDrawingPad.Picture.SaveToFile(SaveDialog.FileName);
end;
end;
end.
Номер выпуска : 2424
Возраст листа : 163 (дней)
Количество подписчиков : 381
Адрес в архиве : http://subscribe.ru/archive/comp.soft.prog.prog/msg/95922
Получить правила : mailto:comp.soft.prog.prog-rules@subscribe.ru
Формат "дайджест" : mailto:comp.soft.prog.prog-digest@subscribe.ru
Формат "каждое письмо" : mailto:comp.soft.prog.prog-normal@subscribe.ru
Формат "читать с веба" : mailto:comp.soft.prog.prog-webonly@subscribe.ru
-*Информационный канал Subscribe.Ru
Написать в лист: mailto:comp.soft.prog.prog-list@subscribe.ru
Отписаться: mailto:comp.soft.prog.prog--unsub@subscribe.ru
http://subscribe.ru/ mailto:ask@subscribe.ru
