home *** CD-ROM | disk | FTP | other *** search
/ Mastering Visual Basic 5 / MasteringVisualBasic5.iso / olympus / ik32_15t / delphi2.shr / UPALETTE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-08-01  |  10.0 KB  |  296 lines
  1. {  Project Palette.DPR Delphi 2.0 Demos
  2.  
  3.   Description:- Palette.Dpr Project:-
  4.  
  5.    Demonstrates the use of:
  6.  
  7.    1) 'ConvertDepth - Increase/Reduce Colors'
  8.    2) 'LoadPal'
  9.    3) 'SavePal'
  10.    4) 'AddSystemColors'
  11.    5) 'SetScreenPal'
  12.  
  13.    Date of Origin: 18/04/96
  14.    Original Author: Andrew Hutchison
  15.    Modification History:
  16.  
  17.    Date        Person                            Change
  18.    ----------------------------------------------------
  19.    18/04/96    A Hutchison                       Created
  20.  
  21.    (c) Copyright Media Architects Inc. 1996.
  22.    All rights reserved.   No part of this program may be
  23.    photocopied, reproduced, translated to another programming
  24.    language or transported to any computer system without the
  25.    prior written consent of Media Architects Inc.}
  26.  
  27. unit Upalette;
  28.  
  29. interface
  30.  
  31. uses
  32.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  33.   ExtCtrls, OleCtrls, ImageKnife32, Menus, StdCtrls;
  34.  
  35. type
  36.   TForm1 = class(TForm)
  37.     MainMenu1: TMainMenu;
  38.     File1: TMenuItem;
  39.     LoadImage1: TMenuItem;
  40.     N1: TMenuItem;
  41.     Exit1: TMenuItem;
  42.     Palette1: TMenuItem;
  43.     LoadPalette1: TMenuItem;
  44.     SavePalette1: TMenuItem;
  45.     AddSystemColours1: TMenuItem;
  46.     RealiseCurrentPalette: TMenuItem;
  47.     Picbuf1: TPicbuf;
  48.     Bevel1: TBevel;
  49.     OpenDialog: TOpenDialog;
  50.     N2: TMenuItem;
  51.     DepthOption: TRadioGroup;
  52.     Label1: TLabel;
  53.     SystemColours: TLabel;
  54.     Label3: TLabel;
  55.     BitDepth: TLabel;
  56.     Bevel2: TBevel;
  57.     Bevel3: TBevel;
  58.     procedure LoadImage1Click(Sender: TObject);
  59.     procedure DepthOptionClick(Sender: TObject);
  60.     procedure LoadPalette1Click(Sender: TObject);
  61.     procedure SavePalette1Click(Sender: TObject);
  62.     procedure Exit1Click(Sender: TObject);
  63.     procedure AddSystemColours1Click(Sender: TObject);
  64.     procedure RealiseCurrentPaletteClick(Sender: TObject);
  65.     procedure FormCreate(Sender: TObject);
  66.     procedure FormActivate(Sender: TObject);
  67.   private
  68.     { Private declarations }
  69.   public
  70.     { Public declarations }
  71.   end;
  72.  
  73. var
  74. Form1: TForm1;
  75.  
  76. Var
  77. Onload : Boolean;{Used in Load Call}
  78. {See Below}
  79. Procedure ConvertDepth(ImageControl:TPicbuf;ConvertDepth:Integer);
  80. {See Below}
  81. Procedure SetInfo(ImageControl:TPicbuf);
  82.  
  83. implementation
  84.  
  85. {$R *.DFM}
  86.  
  87. {-------------------------------------------------------------------------------}
  88. {Load Image into Visible Picture Buffer - Menu Item Call - Check the file does
  89. not have the extension '*.Pal'}
  90. procedure TForm1.LoadImage1Click(Sender: TObject);
  91. var
  92. Temp:String;
  93. begin
  94. Onload := True;    {Set Flag - Stops Convert 'ColorDepth' being called on a load}
  95. if OpenDialog.Execute then
  96. begin
  97. {Set FileName}
  98. Picbuf1.Filename:=OpenDialog.Filename;
  99. {Convert FileName to Upper Case and store in 'TEMP'}
  100. Temp:=Uppercase(OpenDialog.Filename);
  101. {Use POS function to check that '*.PAL' file has not been Loaded [Pos:Delphi Help]}
  102. if Pos('.PAL', Temp) = 0 then
  103.   {Call Load Method if the file extension is NOT '.PAL' - if .PAl Display Message}
  104.   Picbuf1.Load
  105.   else
  106.   MessageDlg('Use Load Palette Option for Palette [.PAL] files.',mtInformation,[mbOk],0);
  107.   end;
  108. SetInfo(Picbuf1);                     {Update Labels to Loaded Image - See Below}
  109. Onload := False;       {Reset Flag - Stops Color Depth being called after a Load}
  110. end;
  111.  
  112.  
  113. {--------------------------------------------------------------------------------}
  114. {Load a Palette file - *.pal. Prompt user for non valid '.PAL' files}
  115. procedure TForm1.LoadPalette1Click(Sender: TObject);
  116. var
  117. Temp:String;{Temp String}
  118. begin
  119. OpenDialog.FilterIndex:=12;{Set Dialog to *.Pal Filter Index}
  120. if OpenDialog.Execute then
  121.   begin
  122.  
  123.   {Set FileName}
  124.   Picbuf1.Filename:=OpenDialog.Filename;
  125.  
  126.   {Convert FileName to Upper Case and store in 'TEMP'}
  127.   Temp:=Uppercase(OpenDialog.Filename);
  128.  
  129. {Use POS function to check that a valid '*.PAL' file has been Loaded [Pos:Delphi Help]}
  130. if Pos('.PAL', Temp) > 0 then
  131.  
  132. {Call Load Method if the file had the extension .PAL - if not Display Message}
  133. Picbuf1.LoadPal
  134. else
  135. MessageDlg('Non Valid Palette file. File must have extension [*.PAL].',mtInformation,[mbOk],0);
  136. end;
  137. end;
  138.  
  139. {-------------------------------------------------------------------------------}
  140. {Store Picbuf1's palette to Disk. Again prompt the user for incorrect file
  141. extensions. IE:- Should Save a palette file as a *.PAL [Not required but good
  142. programming practice}
  143. procedure TForm1.SavePalette1Click(Sender: TObject);
  144. var
  145. Temp:String;
  146. begin
  147. OpenDialog.FilterIndex := 12;{Set Dialog to *.Pal Filter Index}
  148. if OpenDialog.Execute then
  149. begin
  150.  
  151. {Set FileName}
  152. Picbuf1.Filename:=OpenDialog.Filename;
  153.  
  154. {Convert to upper case for match check - Win95/NT is case sensitive}
  155. Temp := Uppercase(OpenDialog.Filename);
  156.  
  157. {Use POS function to check that a valid '*.PAL' file has been Loaded [Pos:Delphi Help]}
  158. if Pos('.PAL', Temp) > 0 then {Post returns start location of string '.PAL' in Temp $}
  159.  
  160. {Call StorePal Method if the file had the extension .PAL - if not Display Message}
  161. Picbuf1.StorePal                                                  {Store if Valid}
  162. else
  163. MessageDlg('Non Valid Palette file name. File must have extension [*.PAL].',mtInformation,[mbOk],0);
  164. end;
  165. end;
  166.  
  167. {-------------------------------------------------------------------------------}
  168. {When the user picks a depth Radio Button ['DepthOption'], using the ItemIndex to
  169. determine what depth is required, call the 'ConvertDepth' function, passing the
  170. function the control name and the required depth. The function will check for
  171. valid combinations. See Below for function.}
  172. procedure TForm1.DepthOptionClick(Sender: TObject);
  173. begin
  174. if Onload then Exit;{Do Not Call function when an Image is Loaded}
  175.  Case DepthOption.ItemIndex of {Radio Button Group}
  176.  0:ConvertDepth(Picbuf1,4); {Convert to 4 Bit}
  177.  1:ConvertDepth(Picbuf1,8); {Convert to 8 Bit}
  178.  2:ConvertDepth(Picbuf1,24);{Convert to 24 Bit}
  179.  end;
  180. SetInfo(Picbuf1);{Call update procedure to refresh labels}
  181. end;
  182.  
  183.  
  184. {-------------------------------------------------------------------------------}
  185. {Convert any Picbuf Image to any given bit Depth 4/8/24. This function can be
  186. re-used for any picbuf control. Just pass control name and requested depth. -
  187. Pass the function the 'Picbuf Name', and the 'Required Depth'}
  188. Procedure ConvertDepth(ImageControl:TPicbuf;ConvertDepth:Integer);
  189. begin
  190. try
  191.  
  192. {Prompt User if the Control is already the requested Depth}
  193. If ImageControl.Colordepth = ConvertDepth then
  194.   begin
  195.   MessageDlg('The Image already is ' + InttoStr(ConvertDepth)+  ' Bit. OK to Continue.'
  196.   ,mtInformation,[mbOk], 0); {Image already at requested depth}
  197.   Application.Processmessages;
  198.   exit;{Abort}
  199. end;
  200.  
  201. {If the Requested Depth is greater than the current depth then use IncreaseColors}
  202. if ConvertDepth > ImageControl.Colordepth then
  203. Imagecontrol.IncreaseColors(ConvertDepth)
  204. {If the above is not true then use ReduceColors to get requested Depth}
  205. else
  206.     begin
  207.     case ConvertDepth of {Set Requested - 'ConvertDepth' is the requested depth}
  208.     4: ImageControl.Reducecolors(16, True, True, True); {reduce to 4}
  209.     8: ImageControl.Reducecolors(254, True, True, True);{reduce to 8}
  210.     end;
  211. end;
  212. except
  213. MessageDlg('Image Conversion Error. Code UPalette 194. OK to Continue.',mtInformation,[mbOk],0);
  214. end;
  215. end;
  216.  
  217. {-------------------------------------------------------------------------------}
  218. {Add System Colors to Image - 8 Bit Images Only}
  219. procedure TForm1.AddSystemColours1Click(Sender: TObject);
  220. begin
  221. Picbuf1.AddSystemColors;
  222. end;
  223.  
  224. {-------------------------------------------------------------------------------}
  225. {Update all the Lables as Required. This procedure can be called at any time - just
  226. pass the Name of the Control to get the info from - SetInfo(MyPicbuf). Note:- The
  227. 'Onload Flag' is used because when you load an Image this procedure is called. If
  228. the Image has just been Loaded the Flag is TRUE.  When this procedure is called,
  229. the RadioButton's are set to reflect the current Bit Depth of the Image. This
  230. causes the RadioButtons to call the ConvertDepth Procedure. So for a new
  231. Image Loaded, without the Flag, everytime you loaded an Image, the ConvertDepth
  232. sub would be called, causing the convert Depth to Display its Message Display,
  233. stating that the Image already is at the requested depth. What the Flag does is
  234. to Skip the ConvertDepth call if the Image was just loaded.}
  235. procedure SetInfo(ImageControl:TPicbuf);
  236. begin
  237. case ImageControl.ColorDepth of                            {Color Depth of Image}
  238.  
  239. 4:{4 Bit}
  240. begin
  241. Form1.DepthOption.ItemIndex:= 0;                {Set Radio Button to Image Depth}
  242. Form1.RealiseCurrentPalette.Enabled := True;         {Enable Realise Menu Option}
  243. Form1.SystemColours.Caption := 'N/A';              {Set Caption to N/A for 4 Bit}
  244. Form1.BitDepth.Caption:=Inttostr(ImageControl.ColorDepth);     {Display Bitdepth}
  245. end;
  246.  
  247. 8:{8 Bit}
  248. begin
  249. Form1.DepthOption.ItemIndex:= 1;
  250. Form1.RealiseCurrentPalette.Enabled := True;        
  251. Form1.SystemColours.Caption := inttostr(ImageControl.CountSystemColors);
  252. Form1.BitDepth.Caption:=Inttostr(ImageControl.ColorDepth);
  253. end;
  254.  
  255. 24:{24 Bit}
  256. begin
  257. Form1.DepthOption.ItemIndex:= 2;
  258. Form1.RealiseCurrentPalette.Enabled := False;
  259. Form1.SystemColours.Caption := 'N/A';
  260. Form1.BitDepth.Caption:=Inttostr(ImageControl.ColorDepth);
  261. end;
  262. end;
  263. end;
  264.  
  265. {--------------------------------------------------------------------------------}
  266. {Menu Item - Realise Palette}
  267. procedure TForm1.RealiseCurrentPaletteClick(Sender: TObject);
  268. begin
  269. Picbuf1.SetScreenPal;
  270. end;
  271.  
  272. {-------------------------------------------------------------------------------}
  273. {Exit Application}
  274. procedure TForm1.Exit1Click(Sender: TObject);
  275. begin
  276. Halt;
  277. end;
  278.  
  279.  
  280. {-------------------------------------------------------------------------------}
  281. {Set Defaults}
  282. procedure TForm1.FormCreate(Sender: TObject);
  283. begin
  284. Application.HintPause:=10;
  285. Application.HintColor:=clAqua;
  286. end;
  287.  
  288. procedure TForm1.FormActivate(Sender: TObject);
  289. begin
  290.   Picbuf1.Filename:='..\images\marybeth.tif';
  291.   PicBuf1.Load;
  292.   PicBuf1.ScrollBars := SB_Both;
  293. end;
  294.  
  295. end.
  296.