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