home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic 4 Power Pack / Visual_Basic4_Power_Pack.bin / vb4files / ilib_vb / bimage.pa_ / bimage.pa
Encoding:
Text File  |  1996-11-20  |  14.0 KB  |  471 lines
  1. {
  2. Written by Jan Dekkers and Kevin Adams (c) 1995, 1996. If you are a non
  3. registered client, you may use or alter this demo only for evaluation
  4. purposes.
  5.  
  6. Copyright by SkyLine Tools. All rights reserved.
  7.  
  8. Part of Imagelib VCL/DLL Library.
  9. }
  10.  
  11. unit Bimage;
  12.  
  13. {Includes settings to compile in either 16 or 32 bit}
  14. {$I DEFILIB.INC}
  15.  
  16. interface
  17.  
  18. uses
  19. {$IFDEF DEL32}
  20.   Windows,
  21. {$ELSE}
  22.   WinTypes,
  23.   WinProcs,
  24. {$ENDIF}
  25.   DLL95V1,    {ImageLib Dll interface and misc. functions}
  26.   SysUtils,
  27.   Messages,
  28.   Classes,
  29.   Graphics,
  30.   Controls,
  31.   Forms,
  32.   Dialogs,
  33.   StdCtrls,
  34.   FileCtrl,
  35.   Spin,
  36.   Buttons,
  37.   UFullscr,   {Full screen display unit}
  38.   Menus,
  39.   UAbout,
  40.   Tmultip,    {PMultiImage VCL component}
  41.   Gauges;
  42.  
  43.  
  44. type
  45.   TConvertForm1 = class(TForm)
  46.     DriveComboBox1: TDriveComboBox;
  47.     DirectoryListBox1: TDirectoryListBox;
  48.     FileListBox1: TFileListBox;
  49.     Convert: TBitBtn;
  50.     QualitySpin: TSpinEdit;
  51.     Smoothspin: TSpinEdit;
  52.     QualityLabel: TLabel;
  53.     SmoothLabel: TLabel;
  54.     GroupBox1: TGroupBox;
  55.     res4: TRadioButton;
  56.     res24: TRadioButton;
  57.     res8: TRadioButton;
  58.     GroupBox2: TGroupBox;
  59.     MainMenu1: TMainMenu;
  60.     N1: TMenuItem;
  61.     E1: TMenuItem;
  62.     A1: TMenuItem;
  63.     ComboBox1: TComboBox;
  64.     Sstretch: TCheckBox;
  65.     GroupBox3: TGroupBox;
  66.     CTOJPEG: TRadioButton;
  67.     CTOBMP: TRadioButton;
  68.     Label1: TLabel;
  69.     FileListBox2: TFileListBox;
  70.     DirectoryListBox2: TDirectoryListBox;
  71.     DriveComboBox2: TDriveComboBox;
  72.     Label2: TLabel;
  73.     CheckBox1: TCheckBox;
  74.     CTOGIF: TRadioButton;
  75.     CTOPCX: TRadioButton;
  76.     CTOPNG: TRadioButton;
  77.     MultiImage1: TPMultiImage;
  78.     GroupBox4: TGroupBox;
  79.     Saveres4: TRadioButton;
  80.     Saveres24: TRadioButton;
  81.     Saveres8: TRadioButton;
  82.     CheckBox2: TCheckBox;
  83.     SaveResAuto: TRadioButton;
  84.     SaveRes4System: TRadioButton;
  85.     resAuto: TRadioButton;
  86.     res4System: TRadioButton;
  87.     SaveResJpegGray: TRadioButton;
  88.     CTOTIF: TRadioButton;
  89.     TiffCombo: TComboBox;
  90.     Label3: TLabel;
  91.     Res1: TRadioButton;
  92.     Gauge1: TGauge;
  93.     procedure DriveComboBox1Change(Sender: TObject);
  94.     procedure DirectoryListBox1Change(Sender: TObject);
  95.     procedure FileListBox1Change(Sender: TObject);
  96.     procedure SstretchOnOff(Sender: TObject);
  97.     procedure FormCreate(Sender: TObject);
  98.     procedure ResClick(Sender: TObject);
  99.     procedure DitherClick(Sender: TObject);
  100.     procedure MultiImage1Click(Sender: TObject);
  101.     procedure E1Click(Sender: TObject);
  102.     procedure A1Click(Sender: TObject);
  103.     procedure ComboBox1Change(Sender: TObject);
  104.     procedure ConvertClick(Sender: TObject);
  105.     procedure DirectoryListBox2Change(Sender: TObject);
  106.     procedure DriveComboBox2Change(Sender: TObject);
  107.     procedure FileListBox2Change(Sender: TObject);
  108.     procedure QualitySpinChange(Sender: TObject);
  109.     procedure SmoothspinChange(Sender: TObject);
  110.     procedure CTOJPEGClick(Sender: TObject);
  111.     procedure SaveRes(Sender: TObject);
  112.     procedure CheckBox2Click(Sender: TObject);
  113.     procedure TiffComboChange(Sender: TObject);
  114.     procedure FormDestroy(Sender: TObject);
  115.   private
  116.     function NameOnly(PName : string) : string;
  117.   public
  118.     { Public declarations }
  119.   end;
  120.  
  121. var
  122.   ConvertForm1: TConvertForm1;
  123.  
  124. implementation
  125.  
  126. {$R *.DFM}
  127. {---------------------------------------------------------------------}
  128. {---------------------------------------------------------------------}
  129.  
  130. {Changed in version 2.21 from a procedure to a function with cdecl.
  131.  To cancel return a 0 else return a 1}
  132. Function BImageLibCallBack(i : integer) : integer; cdecl; export;
  133. {Callback function from the dll, CDECL and EXPORT ARE REQUIRED}
  134. begin
  135.  if Application.Terminated then begin
  136.    {User wants to terminate the program. Pass a 0 to the dll}
  137.    Result:=0;
  138.   end else begin
  139.   {Be nice to others <g>}
  140.    Application.ProcessMessages;
  141.    {process a Gauge}
  142.    if ConvertForm1 <> Nil then
  143.     ConvertForm1.Gauge1.Progress:=i;
  144.    {tell the dll that everything is OK}
  145.    Result:=1;
  146.    end;
  147. end;
  148. {---------------------------------------------------------------------}
  149.  
  150. {update the drive of DirectoryListBox1 with the drive of DriveComboBox1}
  151. procedure TConvertForm1.DriveComboBox1Change(Sender: TObject);
  152. begin
  153.      DirectoryListBox1.Drive := DriveComboBox1.Drive;
  154. end;
  155. {---------------------------------------------------------------------}
  156.  
  157. {update the directory of FileListBox1 with the directory of FileListBox1}
  158. procedure TConvertForm1.DirectoryListBox1Change(Sender: TObject);
  159. begin
  160.      FileListBox1.Directory := DirectoryListBox1.Directory;
  161. end;
  162. {---------------------------------------------------------------------}
  163.  
  164. {Display the image of the FileListBox1.filename}
  165. procedure TConvertForm1.FileListBox1Change(Sender: TObject);
  166. begin
  167.  {set hourglass cursor}
  168.   screen.cursor:=crHourGlass;
  169.  try
  170.  {display an image using the vcl}
  171.   MultiImage1.imagename:=FileListBox1.filename;
  172.  finally
  173.   {set default cursor}
  174.   screen.cursor:=crDefault;
  175.  end;
  176. end;
  177. {---------------------------------------------------------------------}
  178.  
  179. procedure TConvertForm1.FileListBox2Change(Sender: TObject);
  180. begin
  181.  {set hourglass cursor}
  182.   screen.cursor:=crHourGlass;
  183.  try
  184.  {display an image using the vcl}
  185.   MultiImage1.imagename:=FileListBox2.filename;
  186.  finally
  187.   {set default cursor}
  188.   screen.cursor:=crDefault;
  189.  end;
  190. end;
  191. {---------------------------------------------------------------------}
  192.  
  193. {set strech mode}
  194. procedure TConvertForm1.SstretchOnOff(Sender: TObject);
  195. begin
  196.   MultiImage1.stretch:=Sstretch.Checked;
  197. end;
  198. {---------------------------------------------------------------------}
  199.  
  200. {what we do on create}
  201. procedure TConvertForm1.FormCreate(Sender: TObject);
  202. begin
  203.     {set the value of the QualitySpin to the value of JPegSaveQuality}
  204.     QualitySpin.value:=MultiImage1.JPegSaveQuality;
  205.  
  206.     {set the value of the Smoothspin to the value of JPegSaveSmooh}
  207.     Smoothspin.value:=MultiImage1.JPegSaveSmooth;
  208.  
  209.     {Define the callback procedure}
  210.     TPMultiImageCallBack:=BImageLibCallBack;
  211. end;
  212. {---------------------------------------------------------------------}
  213.  
  214. {Set the resolution to either 16, 256 or true color in the vcl}
  215. procedure TConvertForm1.ResClick(Sender: TObject);
  216. {Set the read resolution to either 16, 256 or true color in the vcl}
  217. begin
  218.  {set show resolution to 1 bit monochrome black and white}
  219.  if Res1.checked  then MultiImage1.ImageReadRes:=lMonoChrome;
  220.  
  221.  {set show resolution to 4 bit 16 color using the system's colors}
  222.  if Res4System.checked  then MultiImage1.ImageReadRes:=lColorVGA;
  223.  
  224.  {set show resolution to 4 bit 16 color}
  225.  if res4.checked  then MultiImage1.ImageReadRes:=lColor16;
  226.  
  227.  {set show resolution to 8 bit 256 color}
  228.  if res8.checked  then MultiImage1.ImageReadRes:=lColor256;
  229.  
  230.  {set show resolution to 24 bit true color}
  231.  if res24.checked then MultiImage1.ImageReadRes:=lColorTrue;
  232.  
  233.  {Let ImageLib determine the best resolution}
  234.  if resAuto.checked then MultiImage1.ImageReadRes:=lAutoMatic;
  235. end;
  236. {---------------------------------------------------------------------}
  237.  
  238. procedure TConvertForm1.SaveRes(Sender: TObject);
  239. {Set the save  resolution to either 16, 256 or true color in the vcl}
  240. begin
  241.  {set Jpeg save resolution to GrayScale (Other formats will neglect
  242.  this parameter and set it to 8 bit}
  243.  if SaveResJpegGray.checked  then MultiImage1.ImageWriteRes:=sJpegGray;
  244.  
  245.  {set save resolution to 4 bit 16 color using the system's colors}
  246.  if SaveRes4System.checked  then MultiImage1.ImageWriteRes:=sColorVGA;
  247.  
  248.  {set save resolution to 4 bit 16 color}
  249.  if Saveres4.checked  then MultiImage1.ImageWriteRes:=sColor16;
  250.  
  251.  {set save resolution to 8 bit 256 color}
  252.  if Saveres8.checked  then MultiImage1.ImageWriteRes:=sColor256;
  253.  
  254.  {set save resolution to 24 bit true color}
  255.  if Saveres24.checked then MultiImage1.ImageWriteRes:=sColorTrue;
  256.  
  257.  {Let ImageLib determine the best resolution}
  258.  if SaveResAuto.checked then MultiImage1.ImageWriteRes:=sAutoMatic;
  259. end;
  260. {---------------------------------------------------------------------}
  261.  
  262. procedure TConvertForm1.DitherClick(Sender: TObject);
  263. begin
  264.   {set the Display dither }
  265.   MultiImage1.ImageDither:=CheckBox1.checked;
  266. end;
  267. {---------------------------------------------------------------------}
  268.  
  269. {show fullscreen}
  270. procedure TConvertForm1.MultiImage1Click(Sender: TObject);
  271. begin
  272.   {copy image to fullscreen image}
  273.   FullSlide.MultiImage1.Picture.Graphic:=MultiImage1.Picture.Graphic;
  274.   {show the image fulscreen}
  275.   FullSlide.showmodal;
  276. end;
  277. {---------------------------------------------------------------------}
  278.  
  279. {exit the program}
  280. procedure TConvertForm1.E1Click(Sender: TObject);
  281. begin
  282.  close;
  283. end;
  284. {---------------------------------------------------------------------}
  285.  
  286. {about box}
  287. procedure TConvertForm1.A1Click(Sender: TObject);
  288. begin
  289. {Copy the image to the image of he about box}
  290.  AboutBox.Image1.Picture.Graphic:=MultiImage1.Picture.Graphic;
  291. {show the about box}
  292.  AboutBox.showmodal;
  293. end;
  294.  
  295.  
  296. {---------------------------------------------------------------------}
  297.  
  298. procedure TConvertForm1.ComboBox1Change(Sender: TObject);
  299. begin
  300.  FileListBox1.Mask:=ComboBox1.text;
  301.  FileListBox1.Update;
  302. end;
  303. {---------------------------------------------------------------------}
  304.  
  305. {return filename only. no path, no extension}
  306. function TConvertForm1.NameOnly(PName : string) : string;
  307.  var
  308.    DtP : Byte;
  309.  
  310.  function JName(PName : string) : string;
  311.   var
  312.     I : Word;
  313.   const
  314.     DDSet : set of Char = ['\', ':', #0];
  315.   begin
  316.     I := Succ(Word(Length(PName)));
  317.     repeat
  318.       Dec(I);
  319.     until (PName[I] in DDSet) or (I = 0);
  320.     JName := Copy(PName, Succ(I), 64);
  321.   end;
  322.  
  323.   begin
  324.     PName := JName(PName);
  325.     DtP := Pos('.', PName);
  326.     if DtP > 0 then
  327.       PName := Copy(PName, 1, DtP-1);
  328.     NameOnly := PName;
  329.   end;
  330. {---------------------------------------------------------------------}
  331.  
  332. {The actual conversion}
  333. procedure TConvertForm1.ConvertClick(Sender: TObject);
  334. var i          : integer;
  335.     pTempExt   : string[4];
  336.     pExtension : string[4];
  337.     pName      : string[13];
  338.     pPath      : string[100];
  339.     toTemp      : string;
  340.     frTemp      : string;
  341. begin
  342.  
  343.  if CTOJPEG.Checked then
  344.     pTempExt:='.JPG';
  345.  if CTOBMP.Checked then
  346.     pTempExt:='.BMP';
  347.  if CTOGIF.Checked then
  348.     pTempExt:='.GIF';
  349.  if CTOPCX.Checked then
  350.     pTempExt:='.PCX';
  351.  if CTOPNG.Checked then
  352.     pTempExt:='.PNG';
  353.  if CTOTIF.Checked then
  354.     pTempExt:='.TIF';
  355.  
  356.  for I := FileListBox1.Items.Count - 1 downto 0 do begin
  357.  
  358.      if FileListBox1.Selected[i] then begin
  359.  
  360.        pExtension:=UpperCase(ExtractFileExt(FileListBox1.Items.Strings[i]));
  361.        pName:=UpperCase(NameOnly(FileListBox1.Items.Strings[i]));
  362.        pPath:=UpperCase(DirectoryListBox2.Directory);
  363.  
  364.        toTemp:=pPath+'\'+pName+pTempExt;
  365.        frTemp:=UpperCase(DirectoryListBox1.Directory+'\'+FileListBox1.Items.Strings[i]);
  366.        {set hourglass cursor}
  367.         screen.cursor:=crHourGlass;
  368. try
  369.        if CTOJPEG.Checked then begin
  370.         MultiImage1.imagename:=frTemp;
  371.         MultiImage1.SaveAsJpg(toTemp)
  372.        end else
  373.        if CTOBMP.Checked then begin
  374.         MultiImage1.imagename:=frTemp;
  375.         MultiImage1.SaveAsBMP(toTemp)
  376.        end else
  377.        if CTOTIF.Checked then begin
  378.         MultiImage1.imagename:=frTemp;
  379.         MultiImage1.SaveAsTIF(toTemp)
  380.        end else
  381.        if CTOGIF.Checked then begin
  382.         MultiImage1.imagename:=frTemp;
  383.         MultiImage1.SaveAsGIF(toTemp)
  384.        end else
  385.        if CTOPCX.Checked then begin
  386.         MultiImage1.imagename:=frTemp;
  387.         MultiImage1.SaveAsPCX(toTemp)
  388.        end else
  389.        if CTOPNG.Checked then begin
  390.         MultiImage1.imagename:=frTemp;
  391.         MultiImage1.SaveAsPNG(toTemp)
  392.        end;
  393. finally
  394.       {set default cursor}
  395.       screen.cursor:=crDefault;
  396. end;
  397.       end;
  398.  end;
  399.       FileListBox2.UpDate;
  400.       FileListBox1.UpDate;
  401. end;
  402. {---------------------------------------------------------------------}
  403.  
  404. procedure TConvertForm1.DirectoryListBox2Change(Sender: TObject);
  405. begin
  406.   FileListBox2.Directory := DirectoryListBox2.Directory;
  407. end;
  408. {---------------------------------------------------------------------}
  409.  
  410. procedure TConvertForm1.DriveComboBox2Change(Sender: TObject);
  411. begin
  412.   DirectoryListBox2.Drive := DriveComboBox2.Drive;
  413. end;
  414. {---------------------------------------------------------------------}
  415.  
  416. procedure TConvertForm1.QualitySpinChange(Sender: TObject);
  417. begin
  418.   MultiImage1.JpegSaveQuality:=QualitySpin.Value;
  419. end;
  420. {---------------------------------------------------------------------}
  421.  
  422. procedure TConvertForm1.SmoothspinChange(Sender: TObject);
  423. begin
  424.   MultiImage1.JpegSaveSmooth:=Smoothspin.Value;
  425. end;
  426. {---------------------------------------------------------------------}
  427.  
  428. procedure TConvertForm1.CTOJPEGClick(Sender: TObject);
  429. begin
  430.   QualityLabel.Visible:=CTOJPEG.Checked;
  431.   SmoothLabel.Visible:=CTOJPEG.Checked;
  432.   QualitySpin.Visible:=CTOJPEG.Checked;
  433.   Smoothspin.Visible:=CTOJPEG.Checked;
  434.   CheckBox2.Visible:=CTOPNG.Checked;
  435.   TiffCombo.Visible:=CTOTIF.Checked;
  436.   Label3.Visible:=CTOTIF.Checked;
  437. end;
  438. {---------------------------------------------------------------------}
  439.  
  440. procedure TConvertForm1.CheckBox2Click(Sender: TObject);
  441. begin
  442.    MultiImage1.PNGInterLaced:=CheckBox2.Checked;
  443. end;
  444. {---------------------------------------------------------------------}
  445.  
  446. procedure TConvertForm1.TiffComboChange(Sender: TObject);
  447. begin
  448.    {Set the compression method to save tiffs}
  449.    if TiffCombo.Text ='NONE' then
  450.     MultiImage1.TifSaveCompress:=sNONE;
  451.  
  452.    if TiffCombo.Text ='CCITT' then
  453.     MultiImage1.TifSaveCompress:=sCCITT;
  454.  
  455.    if TiffCombo.Text ='LZW' then
  456.     MultiImage1.TifSaveCompress:=sLZW;
  457.  
  458.    if TiffCombo.Text ='PACKBITS' then
  459.     MultiImage1.TifSaveCompress:=sPACKBITS;
  460. end;
  461. {---------------------------------------------------------------------}
  462.  
  463. procedure TConvertForm1.FormDestroy(Sender: TObject);
  464. begin
  465.    {Unregister the callback procedure}
  466.     TPMultiImageCallBack:=nil;
  467.     ConvertForm1:=Nil;
  468. end;
  469.  
  470. end.
  471.