home *** CD-ROM | disk | FTP | other *** search
/ PC Format Collection 48 / SENT14D.ISO / tech / delphi / disk15 / graphex.pak / GRAPHWIN.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-08-24  |  8.8 KB  |  336 lines
  1. unit GraphWin;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, StdCtrls, Buttons, ColorGrd, Menus, Printers, ClipBrd, Dialogs,
  8.   ExtCtrls;
  9.  
  10. type
  11.   TDrawingTool = (dtLine, dtRectangle, dtEllipse, dtRoundRect);
  12.  
  13.   TForm1 = class(TForm)
  14.     ToolBar: TPanel;
  15.     LineButton: TSpeedButton;
  16.     RectangleButton: TSpeedButton;
  17.     EllipseButton: TSpeedButton;
  18.     RoundRectButton: TSpeedButton;
  19.     PenButton: TSpeedButton;
  20.     BrushButton: TSpeedButton;
  21.     PenBar: TPanel;
  22.     BrushBar: TPanel;
  23.     SolidPen: TSpeedButton;
  24.     DashPen: TSpeedButton;
  25.     DotPen: TSpeedButton;
  26.     DashDotPen: TSpeedButton;
  27.     DashDotDotPen: TSpeedButton;
  28.     ClearPen: TSpeedButton;
  29.     SolidBrush: TSpeedButton;
  30.     ClearBrush: TSpeedButton;
  31.     HorizontalBrush: TSpeedButton;
  32.     VerticalBrush: TSpeedButton;
  33.     FDiagonalBrush: TSpeedButton;
  34.     BDiagonalBrush: TSpeedButton;
  35.     CrossBrush: TSpeedButton;
  36.     DiagCrossBrush: TSpeedButton;
  37.     PenColor: TColorGrid;
  38.     BrushColor: TColorGrid;
  39.     PenWidth: TScrollBar;
  40.     PenSize: TLabel;
  41.     StatusBar: TPanel;
  42.     OriginPanel: TPanel;
  43.     CurrentPanel: TPanel;
  44.     ScrollBox1: TScrollBox;
  45.     Image: TImage;
  46.     MainMenu1: TMainMenu;
  47.     File1: TMenuItem;
  48.     New1: TMenuItem;
  49.     Open1: TMenuItem;
  50.     Save1: TMenuItem;
  51.     Saveas1: TMenuItem;
  52.     Print1: TMenuItem;
  53.     N1: TMenuItem;
  54.     Exit1: TMenuItem;
  55.     Edit1: TMenuItem;
  56.     Copy1: TMenuItem;
  57.     Paste1: TMenuItem;
  58.     OpenDialog1: TOpenDialog;
  59.     SaveDialog1: TSaveDialog;
  60.     Cut1: TMenuItem;
  61.     procedure LineButtonClick(Sender: TObject);
  62.     procedure RectangleButtonClick(Sender: TObject);
  63.     procedure EllipseButtonClick(Sender: TObject);
  64.     procedure RoundRectButtonClick(Sender: TObject);
  65.     procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
  66.       Shift: TShiftState; X, Y: Integer);
  67.     procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
  68.       Shift: TShiftState; X, Y: Integer);
  69.     procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  70.       Y: Integer);
  71.     procedure PenButtonClick(Sender: TObject);
  72.     procedure BrushButtonClick(Sender: TObject);
  73.     procedure PenWidthChange(Sender: TObject);
  74.     procedure SetPenStyle(Sender: TObject);
  75.     procedure PenColorClick(Sender: TObject);
  76.     procedure SetBrushStyle(Sender: TObject);
  77.     procedure BrushColorClick(Sender: TObject);
  78.     procedure FormCreate(Sender: TObject);
  79.     procedure Exit1Click(Sender: TObject);
  80.     procedure Print1Click(Sender: TObject);
  81.     procedure Open1Click(Sender: TObject);
  82.     procedure Save1Click(Sender: TObject);
  83.     procedure Saveas1Click(Sender: TObject);
  84.     procedure New1Click(Sender: TObject);
  85.     procedure Copy1Click(Sender: TObject);
  86.     procedure Paste1Click(Sender: TObject);
  87.     procedure Cut1Click(Sender: TObject);
  88.   private
  89.     { Private declarations }
  90.   public
  91.     { Public declarations }
  92.     Drawing: Boolean;
  93.     Origin, MovePt: TPoint;
  94.     DrawingTool: TDrawingTool;
  95.     CurrentFile: string;
  96.     procedure DrawShape(TopLeft, BottomRight: TPoint; AMode: TPenMode);
  97.   end;
  98.  
  99. var
  100.   Form1: TForm1;
  101.  
  102. implementation
  103.  
  104. uses BMPDlg;
  105.  
  106. {$R *.DFM}
  107.  
  108. procedure TForm1.LineButtonClick(Sender: TObject);
  109. begin
  110.   DrawingTool := dtLine;
  111. end;
  112.  
  113. procedure TForm1.RectangleButtonClick(Sender: TObject);
  114. begin
  115.   DrawingTool := dtRectangle;
  116. end;
  117.  
  118. procedure TForm1.EllipseButtonClick(Sender: TObject);
  119. begin
  120.   DrawingTool := dtEllipse;
  121. end;
  122.  
  123. procedure TForm1.RoundRectButtonClick(Sender: TObject);
  124. begin
  125.   DrawingTool := dtRoundRect;
  126. end;
  127.  
  128. procedure TForm1.DrawShape(TopLeft, BottomRight: TPoint; AMode: TPenMode);
  129. begin
  130.   with Image.Canvas do
  131.   begin
  132.     Pen.Mode := AMode;
  133.     case DrawingTool of
  134.       dtLine: begin
  135.                 MoveTo(TopLeft.X, TopLeft.Y);
  136.                 LineTo(BottomRight.X, BottomRight.Y);
  137.               end;
  138.       dtRectangle: Rectangle(TopLeft.X, TopLeft.Y, BottomRight.X, BottomRight.Y);
  139.       dtEllipse: Ellipse(TopLeft.X, TopLeft.Y, BottomRight.X, BottomRight.Y);
  140.       dtRoundRect: RoundRect(TopLeft.X, TopLeft.Y, BottomRight.X, BottomRight.Y,
  141.         (TopLeft.X - BottomRight.X) div 2, (TopLeft.Y - BottomRight.Y) div 2);
  142.     end;
  143.   end;
  144. end;
  145.  
  146. procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  147.   Shift: TShiftState; X, Y: Integer);
  148. begin
  149.   Drawing := True;
  150.   Image.Canvas.MoveTo(X, Y);
  151.   Origin := Point(X, Y);
  152.   MovePt := Origin;
  153.   OriginPanel.Caption := Format('Origin: (%d, %d)', [X, Y]);
  154. end;
  155.  
  156. procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  157.   Shift: TShiftState; X, Y: Integer);
  158. begin
  159.   if Drawing then
  160.     DrawShape(Origin, Point(X, Y), pmCopy);
  161.   Drawing := False;
  162. end;
  163.  
  164. procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  165.   Y: Integer);
  166. begin
  167.   if Drawing then
  168.   begin
  169.     DrawShape(Origin, MovePt, pmNotXor);
  170.     MovePt := Point(X, Y);
  171.     DrawShape(Origin, MovePt, pmNotXor);
  172.   end;
  173.   CurrentPanel.Caption := Format('Current: (%d, %d)', [X, Y]);
  174. end;
  175.  
  176. procedure TForm1.PenButtonClick(Sender: TObject);
  177. begin
  178.   PenBar.Visible := PenButton.Down;
  179. end;
  180.  
  181. procedure TForm1.BrushButtonClick(Sender: TObject);
  182. begin
  183.   BrushBar.Visible := BrushButton.Down;
  184. end;
  185.  
  186. procedure TForm1.PenWidthChange(Sender: TObject);
  187. begin
  188.   Image.Canvas.Pen.Width := PenWidth.Position;
  189.   PenSize.Caption := IntToStr(PenWidth.Position);
  190. end;
  191.  
  192. procedure TForm1.SetPenStyle(Sender: TObject);
  193. begin
  194.   with Image.Canvas.Pen do
  195.   begin
  196.     if Sender = SolidPen then Style := psSolid
  197.     else if Sender = DashPen then Style := psDash
  198.     else if Sender = DotPen then Style := psDot
  199.     else if Sender = DashDotPen then Style := psDashDot
  200.     else if Sender = DashDotDotPen then Style := psDashDotDot
  201.     else if Sender = ClearPen then Style := psClear;
  202.   end;
  203. end;
  204.  
  205. procedure TForm1.PenColorClick(Sender: TObject);
  206. begin
  207.   Image.Canvas.Pen.Color := PenColor.ForegroundColor;
  208. end;
  209.  
  210. procedure TForm1.SetBrushStyle(Sender: TObject);
  211. begin
  212.   with Image.Canvas.Brush do
  213.   begin
  214.     if Sender = SolidBrush then Style := bsSolid
  215.     else if Sender = ClearBrush then Style := bsClear
  216.     else if Sender = HorizontalBrush then Style := bsHorizontal
  217.     else if Sender = VerticalBrush then Style := bsVertical
  218.     else if Sender = FDiagonalBrush then Style := bsFDiagonal
  219.     else if Sender = BDiagonalBrush then Style := bsBDiagonal
  220.     else if Sender = CrossBrush then Style := bsCross
  221.     else if Sender = DiagCrossBrush then Style := bsDiagCross;
  222.   end;
  223. end;
  224.  
  225. procedure TForm1.BrushColorClick(Sender: TObject);
  226. begin
  227.   Image.Canvas.Brush.Color := BrushColor.ForegroundColor;
  228. end;
  229.  
  230. procedure TForm1.FormCreate(Sender: TObject);
  231. var
  232.   Bitmap: TBitmap;
  233. begin
  234.   Bitmap := TBitmap.Create;
  235.   Bitmap.Width := 200;
  236.   Bitmap.Height := 200;
  237.   Image.Picture.Graphic := Bitmap;
  238. end;
  239.  
  240. procedure TForm1.Exit1Click(Sender: TObject);
  241. begin
  242.   Close;
  243. end;
  244.  
  245. procedure TForm1.Print1Click(Sender: TObject);
  246. begin
  247.   with Printer do
  248.   begin
  249.     BeginDoc;
  250.     Canvas.Draw(0, 0, Image.Picture.Graphic);
  251.     EndDoc;
  252.   end;
  253. end;
  254.  
  255. procedure TForm1.Open1Click(Sender: TObject);
  256. begin
  257.   if OpenDialog1.Execute then
  258.   begin
  259.     CurrentFile := OpenDialog1.FileName;
  260.     Image.Picture.LoadFromFile(CurrentFile);
  261.   end;
  262. end;
  263.  
  264. procedure TForm1.Save1Click(Sender: TObject);
  265. begin
  266.   if CurrentFile <> '' then
  267.     Image.Picture.SaveToFile(CurrentFile)
  268.   else SaveAs1Click(Sender);
  269. end;
  270.  
  271. procedure TForm1.Saveas1Click(Sender: TObject);
  272. begin
  273.   if SaveDialog1.Execute then
  274.   begin
  275.     CurrentFile := SaveDialog1.FileName;
  276.     Save1Click(Sender);
  277.   end;
  278. end;
  279.  
  280. procedure TForm1.New1Click(Sender: TObject);
  281. var
  282.   Bitmap: TBitmap;
  283. begin
  284.   with NewBMPForm do
  285.   begin
  286.     ActiveControl := WidthEdit;
  287.     WidthEdit.Text := IntToStr(Image.Picture.Graphic.Width);
  288.     HeightEdit.Text := IntToStr(Image.Picture.Graphic.Height);
  289.     if ShowModal <> idCancel then
  290.     begin
  291.       Bitmap := TBitmap.Create;
  292.       Bitmap.Width := StrToInt(WidthEdit.Text);
  293.       Bitmap.Height := StrToInt(HeightEdit.Text);
  294.       Image.Picture.Graphic := Bitmap;
  295.       CurrentFile := '';
  296.     end;
  297.   end;
  298. end;
  299.  
  300. procedure TForm1.Copy1Click(Sender: TObject);
  301. begin
  302.   Clipboard.Assign(Image.Picture);
  303. end;
  304.  
  305. procedure TForm1.Paste1Click(Sender: TObject);
  306. var
  307.   Bitmap: TBitmap;
  308. begin
  309.   if Clipboard.HasFormat(CF_BITMAP) then
  310.   begin
  311.     Bitmap := TBitmap.Create;
  312.     try
  313.       Bitmap.Assign(Clipboard);
  314.       Image.Canvas.Draw(0, 0, Bitmap);
  315.     finally
  316.       Bitmap.Free;
  317.     end;
  318.   end;
  319. end;
  320.  
  321. procedure TForm1.Cut1Click(Sender: TObject);
  322. var
  323.   ARect: TRect;
  324. begin
  325.   Copy1Click(Sender);
  326.   with Image.Canvas do
  327.   begin
  328.     CopyMode := cmWhiteness;
  329.     ARect := Rect(0, 0, Image.Width, Image.Height);
  330.     CopyRect(ARect, Image.Canvas, ARect);
  331.     CopyMode := cmSrcCopy;
  332.   end;
  333. end;
  334.  
  335. end.
  336.