home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 1999 October / PCpro_1999_10.ISO / Tools / imgwalk / walkunit.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1999-04-06  |  14.4 KB  |  459 lines
  1. unit walkunit;
  2.  
  3. // ─nderungen:
  4. // 06.04.99: durch einen Doppelklick auf das Label mit dem Zieldateinamen kann
  5. //           eine andere Datei gewΣhlt werden, statt wie bisher nur ⁿber die
  6. //           Ini-Datei
  7.  
  8. interface
  9.  
  10. uses
  11.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  12.   FileCtrl, StdCtrls, Buttons, Grids, Outline, DirOutln, ExtCtrls;
  13.  
  14. type
  15.   TImgInfo = record
  16.     iWidth, iHeight: integer;
  17.     tWidth, tHeight: integer;
  18.     sLinkName: string;
  19.     sThumbName: string;
  20.   end;
  21.  
  22. type
  23.   TForm1 = class(TForm)
  24.     btnGenerate: TBitBtn;
  25.     DriveComboBox1: TDriveComboBox;
  26.     DirectoryListBox1: TDirectoryListBox;
  27.     FileListBox1: TFileListBox;
  28.     btnExit: TBitBtn;
  29.     Label1: TLabel;
  30.     Label2: TLabel;
  31.     cbDoThumbs: TCheckBox;
  32.     Label3: TLabel;
  33.     Image1: TImage;
  34.     cbConvert2JPEG: TCheckBox;
  35.     cbIncludeBMP: TCheckBox;
  36.     cbUseRelativePath: TCheckBox;
  37.     GroupBox1: TGroupBox;
  38.     SpeedButton1: TSpeedButton;
  39.     Label4: TLabel;
  40.     Label5: TLabel;
  41.     SaveDialog1: TSaveDialog;
  42.     procedure btnExitClick(Sender: TObject);
  43.     procedure btnGenerateClick(Sender: TObject);
  44.     procedure FormCreate(Sender: TObject);
  45.     procedure SpeedButton1Click(Sender: TObject);
  46.     procedure Label5DblClick(Sender: TObject);
  47.   private
  48.     { Private-Deklarationen }
  49.   public
  50.     { Public-Deklarationen }
  51.     TemplatePfad: string;
  52.     procedure CreateImageHtml (const DirName: string);
  53.     function ConvertBMP2JPEG (const FName: string): integer;
  54.     function ProcessImage (const DirName: string; var BigImageName: string): TImgInfo;
  55.     function ReadSettings: integer;
  56.   end;
  57.  
  58. var
  59.   Form1: TForm1;
  60.  
  61. implementation
  62.  
  63. {$R *.DFM}
  64.  
  65. // ToDo-Liste:
  66. // (1) Erzeugen von Thumbnails
  67. // (2) Progress Indicator
  68. // (3) Funktion KeepWindowsAlive wΣhrend der BMP->JPEG Konvertierung
  69. // (4) Header/Footer-Dateien einbinden
  70.  
  71. uses IniFiles, Consts, GIFImage, JPEG;
  72.  
  73. const
  74.   ThumbDir: string = 'Thumb';
  75.   ThumbPrefix: string = 't_';
  76.   ImagesHTML: string = 'images.htm';
  77.   MaxThumbSize: integer = 300;
  78.   TemplatePath: string = '';
  79.   HeaderName: string = 'htest.htm';
  80.   FooterName: string = 'ftest.htm';
  81.  
  82. procedure FileCopy (SourceName, TargetName: string);
  83. var
  84.   SourceFile, TargetFile: System.Text;
  85.   Line: string;
  86. begin
  87.   if FileExists (SourceName) then begin
  88.     AssignFile (SourceFile, SourceName);
  89.     AssignFile (TargetFile, TargetName);
  90.     Reset (SourceFile);
  91.     Rewrite (TargetFile);
  92.     while (not eof(SourceFile)) do begin
  93.       ReadLn (SourceFile, Line);
  94.       WriteLn (TargetFile, Line);
  95.     end;
  96.     CloseFile (SourceFile);
  97.     CloseFile (TargetFile);
  98.   end;
  99. end;
  100.  
  101. procedure FileAdd (SourceName, TargetName: string);
  102. var
  103.   SourceFile, TargetFile: System.Text;
  104.   Line: string;
  105. begin
  106.   if FileExists (SourceName) then begin
  107.     AssignFile (SourceFile, SourceName);
  108.     AssignFile (TargetFile, TargetName);
  109.     Reset (SourceFile);
  110.     Append (TargetFile);
  111.     while (not eof(SourceFile)) do begin
  112.       ReadLn (SourceFile, Line);
  113.       WriteLn (TargetFile, Line);
  114.     end;
  115.     CloseFile (SourceFile);
  116.     CloseFile (TargetFile);
  117.   end;
  118. end;
  119.  
  120. function GetFileSize (const FName: string): integer;
  121. var
  122.   SearchRec: TSearchRec;
  123. begin
  124.   if FindFirst (FName, faAnyFile, SearchRec) = 0 then begin
  125.     Result := SearchRec.Size;
  126.   end else Result := 0;
  127.   FindClose (SearchRec);
  128. end;
  129.  
  130. // herausgel÷st aus der Datei fmxutils.pas aus dem Beispielprogrammen
  131. // ─nderung: keine Prⁿfung mehr, ob die Zieldatei ein Verzeichnis ist!
  132. procedure CopyAFile(const FileName, DestName: TFileName);
  133. var
  134.   CopyBuffer: Pointer; { buffer for copying }
  135.   BytesCopied: Longint;
  136.   Source, Dest: Integer; { handles }
  137.   Destination: TFileName; { holder for expanded destination name }
  138. const
  139.   ChunkSize: Longint = 8192; { copy in 8K chunks }
  140. begin
  141.   Destination := ExpandFileName(DestName); { expand the destination path }
  142.   (*
  143.   if HasAttr(Destination, faDirectory) then { if destination is a directory... }
  144.     Destination := Destination + '\' + ExtractFileName(FileName); { ...clone file name }
  145.   *)
  146.   GetMem(CopyBuffer, ChunkSize); { allocate the buffer }
  147.   try
  148.     Source := FileOpen(FileName, fmShareDenyWrite); { open source file }
  149.     if Source < 0 then raise EFOpenError.CreateFmt(SFOpenError, [FileName]);
  150.     try
  151.       Dest := FileCreate(Destination); { create output file; overwrite existing }
  152.       if Dest < 0 then raise EFCreateError.CreateFmt(SFCreateError, [Destination]);
  153.       try
  154.         repeat
  155.           BytesCopied := FileRead(Source, CopyBuffer^, ChunkSize); { read chunk }
  156.           if BytesCopied > 0 then { if we read anything... }
  157.             FileWrite(Dest, CopyBuffer^, BytesCopied); { ...write chunk }
  158.         until BytesCopied < ChunkSize; { until we run out of chunks }
  159.       finally
  160.         FileClose(Dest); { close the destination file }
  161.       end;
  162.     finally
  163.       FileClose(Source); { close the source file }
  164.     end;
  165.   finally
  166.     FreeMem(CopyBuffer, ChunkSize); { free the buffer }
  167.   end;
  168. end;
  169.  
  170. //==============================================================================
  171.  
  172. function TForm1.ReadSettings: integer;
  173. var
  174.   IniName: string;
  175.   IniFile: TIniFile;
  176. begin
  177.   IniName := ChangeFileExt (Application.ExeName, '.ini');
  178.   if FileExists (IniName) then begin
  179.     IniFile := TIniFile.Create (IniName);
  180.     ThumbDir := IniFile.ReadString ('ImageWalker', 'ThumbDir', ThumbDir);
  181.     ThumbPrefix := IniFile.ReadString ('ImageWalker', 'ThumbPrefix', ThumbPrefix);
  182.     ImagesHTML := IniFile.ReadString ('ImageWalker', 'HTMLFile', ImagesHTML);
  183.     MaxThumbSize := IniFile.ReadInteger ('ImageWalker', 'MaxThumbSize', MaxThumbSize);
  184.     TemplatePath := IniFile.ReadString ('ImageWalker', 'TemplatePfad', TemplatePath);
  185.     HeaderName := IniFile.ReadString ('ImageWalker', 'Header', 'htest.htm');
  186.     FooterName := IniFile.ReadString ('ImageWalker', 'Footer', 'ftest.htm');
  187.     IniFile.Free;
  188.     Label5.Caption := ImagesHTML;
  189.     Result := 0;
  190.   end else Result := -1;
  191. end;
  192.  
  193. function TForm1.ConvertBMP2JPEG (const FName: string): integer;
  194. var
  195.   MyJPEG: TJPEGImage;
  196.   MyBMP: TBitmap;
  197. begin
  198.   MyBMP := TBitmap.Create;
  199.   try
  200.     MyBMP.LoadFromFile (FName);
  201.     MyJPEG := TJPEGImage.Create;
  202.     MyJPEG.Assign (MyBMP);
  203.     // Windows Messageloop aufrufen
  204.     Application.ProcessMessages;
  205.     MyJPEG.SaveToFile (ChangeFileExt(FName, '.jpg'));
  206.     MyJPEG.Free;
  207.   finally
  208.     MyBMP.Free;
  209.   end;
  210. end;
  211.  
  212. function Need2Resize (const x,y: integer): boolean;
  213. begin
  214.   if ((x < MaxThumbSize) and (y < MaxThumbSize))
  215.     then Result := false
  216.     else Result := true;
  217. end;
  218.  
  219. // allgemeingⁿltige Gr÷▀enbestimmung fⁿr die Bitmaps
  220. // die Abmessungen werden solange verkleinert, bis Schwellenwert unterschritten
  221. procedure NewSize (var x,y: integer);
  222. begin
  223.   repeat
  224.     // Halbierung der Werte pro Durchlauf
  225.     // x := x div 2;
  226.     // y := y div 2;
  227.     // alternativ: Reduzierung um "Wurzel-2"
  228.     x := trunc(x / sqrt(2.0));
  229.     y := trunc(y / sqrt(2.0));
  230.   until ((x <= MaxThumbSize) and (y <= MaxThumbSize));
  231. end;
  232.  
  233. function TForm1.ProcessImage (const DirName: string; var BigImageName: string): TImgInfo;
  234. var
  235.   w, h: integer;
  236.   ext, ThumbName: string;
  237.   TmpPath: string;
  238.   tmpResult: TImgInfo;
  239.   bmp, bmp0: TBitmap;
  240.   gif, gif0: TGifImage;
  241.   jpg, jpg0: TJPEGImage;
  242. begin
  243.   Label2.Caption := ExtractFileName (BigImageName);
  244.   Label2.Refresh;
  245.  
  246.   ext := lowercase(ExtractFileExt (BigImageName));
  247.   Image1.Picture.Assign (NIL);
  248.   Image1.Picture.LoadFromFile (BigImageName);
  249.   Image1.Refresh;
  250.   w := Image1.Picture.Width;
  251.   h := Image1.Picture.Height;
  252.   tmpResult.iWidth := w;
  253.   tmpResult.iHeight := h;
  254.  
  255.   if (ext = '.bmp') then begin
  256.     if cbConvert2JPEG.Checked then begin
  257.       ConvertBMP2JPEG (BigImageName);
  258.       tmpResult.sLinkName := ChangeFileExt (BigImageName, '.jpg');
  259.     end else tmpResult.sLinkName := BigImageName;
  260.     if cbDoThumbs.Checked then begin
  261.       // Thumbnail als JPEG erzeugen
  262.       bmp := TBitmap.Create;
  263.       if Need2Resize (w, h) then begin
  264.         NewSize (w, h);
  265.         bmp.Width := w;
  266.         bmp.Height := h;
  267.         bmp.Canvas.StretchDraw (Rect(0,0, bmp.Width, bmp.Height),
  268.                                 Image1.Picture.Bitmap);
  269.       end else begin
  270.         bmp.Width := w;
  271.         bmp.Height := h;
  272.         bmp.Canvas.Draw (0, 0, Image1.Picture.Bitmap);
  273.       end;
  274.       jpg := TJPEGImage.Create;
  275.       jpg.Assign (bmp);
  276.       ThumbName := ThumbDir + '\' + ChangeFileExt(ThumbPrefix + BigImageName, '.jpg');
  277.       jpg.SaveToFile (ThumbName);
  278.       jpg.Free;
  279.       bmp.Free;
  280.       tmpResult.tWidth := w;
  281.       tmpResult.tHeight := h;
  282.       tmpResult.sThumbName := ThumbName;
  283.     end;
  284.   end;
  285.  
  286.   if ((ext = '.gif') and cbDoThumbs.Checked) then begin
  287.     // der aktuelle Weg ist noch ein bi▀chen "von hinten durch die Brust" !!
  288.     if Need2Resize (w, h) then begin
  289.       gif0 := TGifImage.Create;
  290.       gif0.LoadFromFile (BigImageName);
  291.       bmp0 := TBitmap.Create;
  292.       bmp0.Assign (gif0);
  293.       bmp := TBitmap.Create;
  294.       NewSize (w, h);
  295.       bmp.Width := w;
  296.       bmp.Height := h;
  297.       bmp.Canvas.StretchDraw (Rect(0,0, bmp.Width, bmp.Height), bmp0);
  298.       gif0.Free;
  299.       bmp0.Free;
  300.       gif := TGifImage.Create;
  301.       gif.Assign (bmp);
  302.       ThumbName := ThumbDir + '\' + ThumbPrefix + BigImageName;
  303.       gif.SaveToFile (ThumbName);
  304.       gif.Free;
  305.       bmp.Free;
  306.     end else CopyAFile (BigImageName, ThumbDir + '\' + ThumbPrefix + BigImageName);
  307.     tmpResult.tWidth := w;
  308.     tmpResult.tHeight := h;
  309.     tmpResult.sThumbName := ThumbDir + '\' + ThumbPrefix + BigImageName;
  310.     tmpResult.sLinkName := BigImageName;
  311.   end;
  312.  
  313.   if ((ext = '.jpg') and cbDoThumbs.Checked) then begin
  314.     if Need2Resize (w, h) then begin
  315.       jpg0 := TJpegImage.Create;
  316.       jpg0.LoadFromFile (BigImageName);
  317.       bmp0 := TBitmap.Create;
  318.       bmp0.Assign (jpg0);
  319.       bmp := TBitmap.Create;
  320.       NewSize (w, h);
  321.       bmp.Width := w;
  322.       bmp.Height := h;
  323.       bmp.Canvas.StretchDraw (Rect(0,0, bmp.Width, bmp.Height), bmp0);
  324.       jpg0.Free;
  325.       bmp0.Free;
  326.       jpg := TJpegImage.Create;
  327.       jpg.Assign (bmp);
  328.       ThumbName := ThumbDir + '\' + ThumbPrefix + BigImageName;
  329.       jpg.SaveToFile (ThumbName);
  330.       jpg.Free;
  331.       bmp.Free;
  332.     end else CopyAFile (BigImageName, ThumbDir + '\t_' + BigImageName);
  333.     tmpResult.tWidth := w;
  334.     tmpResult.tHeight := h;
  335.     tmpResult.sThumbName := ThumbDir + '\' + ThumbPrefix + BigImageName;
  336.     tmpResult.sLinkName := BigImageName;
  337.   end;
  338.  
  339.   Result := tmpResult;
  340. end;
  341.  
  342. procedure TForm1.CreateImageHtml (const DirName: string);
  343. var
  344.   HTMLName: string;
  345.   ImageName: string;
  346.   ThumbName: string;
  347.   HTMLFile: TextFile;
  348.   i: integer;
  349.   x: TImgInfo;
  350.   IORes: integer;
  351. begin
  352.   HTMLName := DirName + '\' + ImagesHTML;
  353.  
  354.   AssignFile (HTMLFile, HTMLName);
  355.   Rewrite (HTMLFile);
  356.   WriteLn (HTMLFile, '<!-- ImageWalker v0.9 -->');
  357.   CloseFile (HTMLFile);
  358.   // Headerdatei einlesen und in HTML-Datei schreiben
  359.   FileAdd (TemplatePath + HeaderName, HTMLName);
  360.   Append (HTMLFile);
  361.   // wenn Thumbs erzeugt werden sollen, ggf. Thumbverzeichnis generieren
  362.   // dabei prⁿfen, ob bereits ein Verzeichnis mit diesem Namen existiert
  363.   if cbDoThumbs.Checked then begin
  364.     {$I-}
  365.     MkDir (ThumbDir);
  366.     {$I+}
  367.     IORes := IOResult;
  368.     if (IORes <> 0)
  369.       then begin
  370.         if (IORes = 183)
  371.           then Label3.Caption := 'Verzeichnis ' + ThumbDir + ' existiert bereits'
  372.           else Label3.Caption := 'Verzeichnis ' + ThumbDir + ' konnte nicht angelegt werden'
  373.       end else Label3.Caption := 'Verzeichnis ' + ThumbDir + ' erzeugt';
  374.     Label3.Refresh;
  375.   end;
  376.  
  377.   // HTML SubHeader erzeugen
  378.   WriteLn (HTMLFile, '<h2>Verzeichnis: ' + DirName + '</h2><p>');
  379.   WriteLn (HTMLFile, 'enthΣlt ' + IntToStr(FileListbox1.Items.Count) + ' Dateien<p>');
  380.   WriteLn (HTMLFile, 'erstellt am: ' + FormatDateTime('dd.mm.yyyy hh:mm:ss', Now));
  381.   WriteLn (HTMLFile, '<table border="4">');
  382.   WriteLn (HTMLFile, '<tr><th>Dateiname</th><th>Gr÷▀e</th><th>Bild</th></tr>');
  383.  
  384.   Screen.Cursor := crHourglass;
  385.   try
  386.     // einzelne Bilder bearbeiten
  387.     for i := 0 to FileListbox1.Items.Count-1 do begin
  388.       ImageName := FileListbox1.Items[i];
  389.       x := ProcessImage (DirName, ImageName);
  390.       Application.ProcessMessages;
  391.       ThumbName := x.sThumbName;
  392.       WriteLn (HTMLFile, '<tr>');
  393.       WriteLn (HTMLFile, '  <td>' + ImageName + '</td>');
  394.       Write   (HTMLFile, '  <td>');
  395.       Write   (HTMLFile, IntToStr(GetFileSize(DirName + '\' + ImageName)) + ' Bytes<br>');
  396.       Write   (HTMLFile, IntToStr(x.iWidth) + ' x ' + IntToStr(x.iHeight)+ ' Pixel');
  397.       WriteLn (HTMLFile, '</td>');
  398.       Write   (HTMLFile, '  <td>');
  399.       // Link erzeugen, da▀ bei Klick auf Thumbnail das Originalbild angezeigt wird
  400.       Write   (HTMLFile, '<a href="' + x.sLinkName + '">');
  401.       Write   (HTMLFile, '<img align="top" width="' + IntToStr(x.tWidth) + '" height="');
  402.       Write   (HTMLFile, IntToStr(x.tHeight) + '" src="'+ x.sThumbName + '">');
  403.       Write   (HTMLFile, '</a>');
  404.       WriteLn (HTMLFile, '</td>');
  405.       WriteLn (HTMLFile, '</tr>');
  406.     end;
  407.   finally
  408.     Screen.Cursor := crDefault;
  409.   end;
  410.  
  411.   // HTML-Tabelle abschlie▀en
  412.   WriteLn (HTMLFile, '</table>');
  413.   WriteLn (HTMLFile, '<p>');
  414.   WriteLn (HTMLFile, 'generiert von ImageWalker');
  415.  
  416.   // Zieldatei schlie▀en, damit FileAdd erfolgreich sein kann
  417.   CloseFile (HTMLFile);
  418.   // Footerdatei einlesen und in HTML-Datei schreiben
  419.   FileAdd (TemplatePath + FooterName, HTMLName);
  420.   Label3.Caption := 'Arbeitsablauf beendet';
  421.   Label3.Refresh;
  422. end;
  423.  
  424. procedure TForm1.btnExitClick(Sender: TObject);
  425. begin
  426.   Close;
  427. end;
  428.  
  429. procedure TForm1.btnGenerateClick(Sender: TObject);
  430. begin
  431.   // Datei mit dem Namen ImagesHTML generieren
  432.   CreateImageHtml (DirectoryListbox1.Directory);
  433. end;
  434.  
  435. procedure TForm1.FormCreate(Sender: TObject);
  436. begin
  437.   ReadSettings;
  438. end;
  439.  
  440.  
  441. procedure TForm1.SpeedButton1Click(Sender: TObject);
  442. begin
  443.   ShowMessage ('ImageWalker v1.01 vom 06.04.1999' + #13#10 +
  444.                '(c) 1999 Andreas Golgath fⁿr die PC Professionell' + #13#10 +
  445.                'Software und Quelltext dⁿrfen frei verwendet werden' + #13#10 +
  446.                #13#10 +
  447.                'This software is based, in part, on the work of Anders Melander');
  448. end;
  449.  
  450. procedure TForm1.Label5DblClick(Sender: TObject);
  451. begin
  452.   if (SaveDialog1.Execute) then begin
  453.     ImagesHTML := SaveDialog1.Filename;
  454.     Label5.Caption := ImagesHTML;
  455.   end;
  456. end;
  457.  
  458. end.
  459.