home *** CD-ROM | disk | FTP | other *** search
/ PC Expert 29 / Pce29cd.iso / RUNIMAGE / DELPHI40 / DEMOS / DOC / GRAPHEX / GRAPHWIN.PAS < prev    next >
Pascal/Delphi Source File  |  1998-06-16  |  9KB  |  359 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 := TBitmap.Create;
  215.   Bitmap.Width := 200;
  216.   Bitmap.Height := 200;
  217.   Image.Picture.Graphic := Bitmap;
  218. end;
  219.  
  220. procedure TForm1.SetBrushStyle(Sender: TObject);
  221. begin
  222.   with Image.Canvas.Brush do
  223.   begin
  224.     if Sender = SolidBrush then Style := bsSolid
  225.     else if Sender = ClearBrush then Style := bsClear
  226.     else if Sender = HorizontalBrush then Style := bsHorizontal
  227.     else if Sender = VerticalBrush then Style := bsVertical
  228.     else if Sender = FDiagonalBrush then Style := bsFDiagonal
  229.     else if Sender = BDiagonalBrush then Style := bsBDiagonal
  230.     else if Sender = CrossBrush then Style := bsCross
  231.     else if Sender = DiagCrossBrush then Style := bsDiagCross;
  232.   end;
  233. end;
  234.  
  235. procedure TForm1.PenColorClick(Sender: TObject);
  236. begin
  237.   ColorDialog1.Color := Image.Canvas.Pen.Color;
  238.   if ColorDialog1.Execute then
  239.     Image.Canvas.Pen.Color := ColorDialog1.Color;
  240. end;
  241.  
  242. procedure TForm1.BrushColorClick(Sender: TObject);
  243. begin
  244.   ColorDialog1.Color := Image.Canvas.Brush.Color;
  245.   if ColorDialog1.Execute then
  246.     Image.Canvas.Brush.Color := ColorDialog1.Color;
  247. end;
  248.  
  249. procedure TForm1.Exit1Click(Sender: TObject);
  250. begin
  251.   Close;
  252. end;
  253.  
  254. procedure TForm1.Open1Click(Sender: TObject);
  255. begin
  256.   if OpenDialog1.Execute then
  257.   begin
  258.     CurrentFile := OpenDialog1.FileName;
  259.     SaveStyles;
  260.     Image.Picture.LoadFromFile(CurrentFile);
  261.     RestoreStyles;
  262.   end;
  263. end;
  264.  
  265. procedure TForm1.Save1Click(Sender: TObject);
  266. begin
  267.   if CurrentFile <> EmptyStr then
  268.     Image.Picture.SaveToFile(CurrentFile)
  269.   else SaveAs1Click(Sender);
  270. end;
  271.  
  272. procedure TForm1.Saveas1Click(Sender: TObject);
  273. begin
  274.   if SaveDialog1.Execute then
  275.   begin
  276.     CurrentFile := SaveDialog1.FileName;
  277.     Save1Click(Sender);
  278.   end;
  279. end;
  280.  
  281. procedure TForm1.New1Click(Sender: TObject);
  282. var
  283.   Bitmap: TBitmap;
  284. begin
  285.   with NewBMPForm do
  286.   begin
  287.     ActiveControl := WidthEdit;
  288.     WidthEdit.Text := IntToStr(Image.Picture.Graphic.Width);
  289.     HeightEdit.Text := IntToStr(Image.Picture.Graphic.Height);
  290.     if ShowModal <> idCancel then
  291.     begin
  292.       Bitmap := TBitmap.Create;
  293.       Bitmap.Width := StrToInt(WidthEdit.Text);
  294.       Bitmap.Height := StrToInt(HeightEdit.Text);
  295.       SaveStyles;
  296.       Image.Picture.Graphic := Bitmap;
  297.       RestoreStyles;
  298.       CurrentFile := EmptyStr;
  299.     end;
  300.   end;
  301. end;
  302.  
  303. procedure TForm1.Copy1Click(Sender: TObject);
  304. begin
  305.   Clipboard.Assign(Image.Picture);
  306. end;
  307.  
  308. procedure TForm1.Cut1Click(Sender: TObject);
  309. var
  310.   ARect: TRect;
  311. begin
  312.   Copy1Click(Sender);
  313.   with Image.Canvas do
  314.   begin
  315.     CopyMode := cmWhiteness;
  316.     ARect := Rect(0, 0, Image.Width, Image.Height);
  317.     CopyRect(ARect, Image.Canvas, ARect);
  318.     CopyMode := cmSrcCopy;
  319.   end;
  320. end;
  321.  
  322. procedure TForm1.Paste1Click(Sender: TObject);
  323. var
  324.   Bitmap: TBitmap;
  325. begin
  326.   if Clipboard.HasFormat(CF_BITMAP) then
  327.   begin
  328.     Bitmap := TBitmap.Create;
  329.     try
  330.       Bitmap.Assign(Clipboard);
  331.       Image.Canvas.Draw(0, 0, Bitmap);
  332.     finally
  333.       Bitmap.Free;
  334.     end;
  335.   end;
  336. end;
  337.  
  338. procedure TForm1.SaveStyles;
  339. begin
  340.   with Image.Canvas do
  341.   begin
  342.     BrushStyle := Brush.Style;
  343.     PenStyle := Pen.Style;
  344.     PenWide := Pen.Width;
  345.   end;
  346. end;
  347.  
  348. procedure TForm1.RestoreStyles;
  349. begin
  350.   with Image.Canvas do
  351.   begin
  352.     Brush.Style := BrushStyle;
  353.     Pen.Style := PenStyle;
  354.     Pen.Width := PenWide;
  355.   end;
  356. end;
  357.  
  358. end.
  359.