home *** CD-ROM | disk | FTP | other *** search
/ Mastering Visual Basic 5 / MasteringVisualBasic5.iso / olympus / ik32_15t / delphi2.shr / UPAN.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-08-01  |  5.3 KB  |  177 lines
  1. {  Project Pan.DPR Delphi 2.0 Demos
  2.  
  3.   Description:- Pan.Dpr Project:-
  4.  
  5.   Demonstrates the use of:
  6.  
  7.    1) 'Pan'
  8.    2) 'ScrollBars'
  9.    3) 'Repos'
  10.  
  11.    Date of Origin: 18/04/96
  12.    Original Author: Andrew Hutchison
  13.    Modification History:
  14.  
  15.    Date        Person                            Change
  16.    ----------------------------------------------------
  17.    18/04/96    A Hutchison                       Created
  18.  
  19.    (c) Copyright Media Architects Inc. 1996.
  20.    All rights reserved.   No part of this program may be
  21.    photocopied, reproduced, translated to another programming
  22.    language or transported to any computer system without the
  23.    prior written consent of Media Architects Inc.}
  24.  
  25. unit UPan;
  26.  
  27. interface
  28.  
  29. uses
  30.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  31.   ExtCtrls, Menus, OleCtrls, ImageKnife32, StdCtrls;
  32.  
  33. type
  34.   TForm1 = class(TForm)
  35.     OpenDialog: TOpenDialog;
  36.     MainMenu1: TMainMenu;
  37.     File1: TMenuItem;
  38.     LoadImage1: TMenuItem;
  39.     N1: TMenuItem;
  40.     Exit1: TMenuItem;
  41.     Bevel1: TBevel;
  42.     Picbuf1: TPicbuf;
  43.     ScrollBars: TCheckBox;
  44.     procedure FormCreate(Sender: TObject);
  45.     procedure LoadImage1Click(Sender: TObject);
  46.     procedure Picbuf1MouseDown(Sender: TObject; Button: TMouseButton;
  47.       Shift: TShiftState; X, Y: Integer);
  48.     procedure Picbuf1MouseMove(Sender: TObject; Shift: TShiftState; X,
  49.       Y: Integer);
  50.     procedure ScrollBarsClick(Sender: TObject);
  51.     procedure Exit1Click(Sender: TObject);
  52.   private
  53.     { Private declarations }
  54.   public
  55.     { Public declarations }
  56.   end;
  57.  
  58. var
  59.   Form1: TForm1;
  60.  
  61. {Used to find Demo Images}
  62. function GetImageLocation:String;
  63.  
  64. {Globals required for Pan Operations}
  65. var
  66. Startx, Starty, Pixelx, Pixely, Imagestartx, Imagestarty : Integer;
  67.  
  68.  
  69. implementation
  70.  
  71. {$R *.DFM}
  72.  
  73. {--------------------------------------------------------------------------------}
  74. {Set Defaults}
  75. procedure TForm1.FormCreate(Sender: TObject);
  76. begin
  77. Application.HintPause:=10;
  78. Application.HintColor:=clAqua;
  79.  
  80. {Set FileNames - uses GetImageLocation function - See Below}
  81. Picbuf1.filename := GetImageLocation  + 'images\marybeth.tif';
  82.  
  83. {Load Default Source Image if it exists}
  84. if FileExists(Picbuf1.filename) then{Delphi function call - True if file exists}
  85. Picbuf1.Load
  86. else
  87. MessageDlg('Cannot find Sample file [\images\squirrel.bmp].' +
  88. ' Users should manually load this Image into the Source Picture.', mtInformation,
  89. [mbOk], 0);
  90. end;
  91.  
  92. {--------------------------------------------------------------------------------}
  93. {Load Image into Picbuf}
  94. procedure TForm1.LoadImage1Click(Sender: TObject);
  95. begin
  96. {Open File}
  97. if OpenDialog.execute then
  98. begin
  99. {Set Name}
  100. Picbuf1.Filename := OpenDialog.FileName;
  101. {Call Load}
  102. Picbuf1.Load;
  103. {Set Pointer}
  104. Picbuf1.MousePointer := 15;
  105. end;
  106. end;
  107.  
  108. {--------------------------------------------------------------------------------}
  109. { When the user clicks the Image get the Mouse location.  With Delphi no Conversions
  110. are Required as all units are in Pixels}
  111. procedure TForm1.Picbuf1MouseDown(Sender: TObject; Button: TMouseButton;
  112.   Shift: TShiftState; X, Y: Integer);
  113. begin
  114. if ssleft in Shift then {Left Mouse Button}
  115. begin
  116. ImagestartX := Picbuf1.ScreenToImageX(X);{Mouse Down X}
  117. ImagestartY := Picbuf1.ScreenToImageY(Y);{Mouse Down Y}
  118. end;
  119. end;
  120.  
  121. {--------------------------------------------------------------------------------}
  122. {Reposition the Image, linked to the Mouse Pointer Position}
  123. procedure TForm1.Picbuf1MouseMove(Sender: TObject; Shift: TShiftState; X,
  124.   Y: Integer);
  125. begin
  126. if ssleft in Shift then {Left Mouse Button}
  127. begin
  128. Pixelx := X ; {Current Mouse Location}
  129. Pixely := Y ; {Current Mouse Location}
  130. {Make Sure Valid Location}
  131. If ((x > 0) And (y > 0) And (x < Picbuf1.Width) And (y < Picbuf1.Height)) Then
  132. Picbuf1.RePos(imagestartx, imagestarty, pixelx, pixely);            {RePos Image}
  133. end;
  134. end;
  135.  
  136. {--------------------------------------------------------------------------------}
  137. {Enable Disable Scroll Bars}
  138. procedure TForm1.ScrollBarsClick(Sender: TObject);
  139. begin
  140. if not ScrollBars.Checked then               {If NOT checked then no Scroll Bars}
  141. begin
  142. Picbuf1.ScrollBars := 0;
  143. Picbuf1.MousePointer := 15;                                    {Set Mouse Cursor}
  144. end
  145. else
  146. begin
  147. Picbuf1.ScrollBars := 3;                          {If Checked enable Scroll Bars}
  148. Picbuf1.MousePointer := 0;                                     {Set Mouse Cursor}
  149. end;
  150. end;
  151.  
  152. {-------------------------------------------------------------------------------)
  153. {Get Path of Default files:-
  154. Basically the functions gets the path name of the EXE location, strips of the last
  155. directory, ready for use - only applicable to this Demo. See Delphi on-line help}
  156. function GetImageLocation:String;
  157. Var
  158. Temp:String;
  159. DelphiLocation:Integer;
  160. begin
  161. Temp := ExtractFileDir(Application.exename);               {Get full path of EXE}
  162. Temp := UpperCase(Temp);                             {Make Sure it is upper Case}
  163. DelphiLocation := Pos('\DELPHI2',Temp);
  164. Delete(Temp,DelphiLocation,length('\DELPHI2'));         {Strip of last Directory}
  165. Result:=Temp + '\';                                         {Add the Missing '\'}
  166. end;
  167.  
  168.  
  169. {-------------------------------------------------------------------------------)
  170. {Exit Application}
  171. procedure TForm1.Exit1Click(Sender: TObject);
  172. begin
  173. Halt;
  174. end;
  175.  
  176. end.
  177.