Der Code für das Tool JPG-Verkleiner

Hinweis es sind noch nicht alle Idioten sicherungen drin wie, 
das keine Buchstaben eingeben werden können in einer Größenangabe.
Oder das wenigsten ein Buchstabe im Namen sein solte, eigentlich 
logisch ohne Buchstaben kein Datei-Name.  :) 
Ja man muss ja nicht alles vorkauen.  :)


     	   
 Wer Fehler findet kann die Kostenlos behalten! 


//---------------------------------------------------------------------------------------------
{ Ich über nehme keine Verantwortung alles auf eigenes Risiko.
Der Code darf frei benutzt werden und verbessert und geändert.
            Bei Commercialer Nutzung hat man mich zu fragen. 
 }

unit U1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtDlgs, StdCtrls, jpeg, FileCtrl, FileSiceListBox, ExtCtrls, Spin,
  StylesButton, MyPanel2, ImgList;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    ListBox2: TListBox;
    Panel2: TPanel;
    Label6: TLabel;
    ListBox1: TListBox;
    Panel3: TPanel;
    Splitter1: TSplitter;
    Label7: TLabel;
    StylesButton1: TStylesButton;
    StylesButton2: TStylesButton;
    BildPanel1: TBildPanel;
    Label5: TLabel;
    Label8: TLabel;
    DirectoryListBox1: TDirectoryListBox;
    DriveComboBox1: TDriveComboBox;
    FileSiceListBox1: TFileSiceListBox;
    Label10: TLabel;
    Label11: TLabel;
    BildPanel2: TBildPanel;
    Label9: TLabel;
    Edit3: TEdit;
    SpinEdit1: TSpinEdit;
    Label1: TLabel;
    Edit1: TEdit;
    Label2: TLabel;
    Edit2: TEdit;
    Label3: TLabel;
    ImageList1: TImageList;
    Bevel1: TBevel;
    procedure Edit1Change(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ListBox1DblClick(Sender: TObject);
    procedure DirectoryListBox1Change(Sender: TObject);
    procedure FileSiceListBox1DblClick(Sender: TObject);
    procedure FileSiceListBox1Click(Sender: TObject);
    procedure StylesButton2Click(Sender: TObject);
    procedure StylesButton1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

uses ShellApi;

{$R *.DFM}




procedure TForm1.Edit1Change(Sender: TObject);
begin
   Edit2.Text := Edit1.Text;
end;
    

procedure TForm1.FormCreate(Sender: TObject);
var s : String;
begin
  s := '';
  s := Application.Exename[1];

  if s <> 'C' then begin
     FileSiceListBox1.FileName := s + ':\Users\Ich\Pictures\';
  end
  else begin
    FileSiceListBox1.FileName := 'C:\Users\Ich\Pictures\';
  end;
  If Not DirectoryExists(s + ':\Users\Ich\Pictures') then
     FileSiceListBox1.FileName := GetCurrentDir + '\';       
end;

// Damit man die Bilder begutachten kann ob alles gut verlaufen ist.
procedure TForm1.ListBox1DblClick(Sender: TObject);
var s: String;
begin
  if FileExists(ListBox1.Items.Strings[ListBox1.ItemIndex]) then begin
     s := ListBox1.Items.Strings[ListBox1.ItemIndex];
     ShellExecute(handle, nil, Pchar(s), nil, nil, SW_SHOW);
  end;
end;

procedure TForm1.DirectoryListBox1Change(Sender: TObject);
begin
    Label8.Caption :=  DirectoryListBox1.Directory +'\';
end;

// Bild bei doppelklick verkleinern und als Neues Bild mit Neuen Namen und
// durch nummeriert speicher in Listbox zum Überbrüfen.
procedure TForm1.FileSiceListBox1DblClick(Sender: TObject);
var Bild1, Bild2: Tbitmap;
   jpg, jpg2 : TJpegImage;
   i, NrPos: Integer;
   Hoehe, Breite: Real;
    s, s2, s3: String;
begin
   Screen.Cursor := crHourGlass;
   s := ''; s2 := '';
   NrPos :=0;
   Hoehe  := 10; Breite  := 10;

   s := FileSiceListBox1.FileName;
   NrPos := Pos('g:', s);
   if NrPos = 0 then NrPos := Pos('G:', s);   // Für Große Buchstaben
   s := Copy(s, 0, NrPos) ;

   //--------------------------------------------------------

     Bild1 := TBitmap.Create;
     Bild2 := TBitmap.Create;
     jpg := TJpegImage.Create;
     jpg2 := TJpegImage.Create;
    try
      Bild1.PixelFormat := pf24Bit;
      jpg.LoadFromFile(s); // Bild laden Pfad und DateiName übergeben
      ListBox2.Items.Add(s); // Pfad und Alte-Dateien in Listbox zum Löschen sichern
      Bild1.Assign(jpg);  // JPG den Bitmap zuweisen
      s2 := ExtractFilePath(s); // Pfad bekommen

      // Prozente ausrechnen für Verkleinerung
      if Bild1.Width > Bild1.Height then begin
         Breite := Bild1.Width / 100;
         Breite := Breite * StrtoInt(Edit2.text);
         Hoehe := Bild1.Height / 100;
         Hoehe := Hoehe * StrtoInt(Edit1.text);
         Bild2.Width  := Trunc(Breite);
         Bild2.Height := Trunc(Hoehe);
      end //if
      else begin
         Breite := Bild1.Width / 100;
         Breite := Breite * StrtoInt(Edit2.text);
         Hoehe := Bild1.Height / 100;
         Hoehe := Hoehe * StrtoInt(Edit1.text);
         Bild2.Width  := Trunc(Breite);
         Bild2.Height := Trunc(Hoehe);
      end; // else

      SetStretchBltMode(Bild2.Canvas.Handle, HALFTONE);
      StretchBlt(Bild2.Canvas.Handle, 0, 0, Bild2.Width, Bild2.Height,
      Bild1.Canvas.Handle, 0, 0, Bild1.Width, Bild1.Height, SRCCOPY);
      // Pfad mit neuen Dateinamen und Nummerierung zusammen stellen
      s3 := s2 + Edit3.Text + IntTostr(SpinEdit1.Value)  +'.jpg';
      SpinEdit1.Value := SpinEdit1.Value +1; // Zähler erhöhen
      i := 0;
      // Zur Sicherheit fahls eine Datei mit diesen namen schon vorhanden ist
      if FileExists(s3) then begin
        while i = 0 do begin
          // Pfad mit neuen Dateinamen und Nummerierung zusammen stellen
          s3 := s2 + Edit3.Text + IntTostr(SpinEdit1.Value)  +'.jpg';
          SpinEdit1.Value := SpinEdit1.Value +1; // Zähler erhöhen
          if not FileExists(s3) then i := 1;
        end; // while
      end; // if

      ListBox1.Items.Add(s3); // Pfad und Neuen-Dateiname in Listbox zu Überprüfen der Bilder.
      jpg2.Assign(Bild2); // Bitmap wieder JPG zuweisen
      jpg2.SaveToFile(s3);
    finally
      Bild1.Free;
      Bild2.Free;
      jpg.free;
      jpg2.free;
    end;


  Screen.Cursor := crDefault;
end;

// Höhe und Breite vom Bild ausgeben
procedure TForm1.FileSiceListBox1Click(Sender: TObject);
var Bild1: Tbitmap;
    jpg: TJpegImage;
    s: String;
    NrPos: Integer;
begin
   Screen.Cursor := crHourGlass;
   s := '';
   NrPos :=0;

   s := FileSiceListBox1.FileName;
   NrPos := Pos('g:', s);
   if NrPos = 0 then NrPos := Pos('G:', s);   // Für Große Buchstaben
   s := Copy(s, 0, NrPos) ;

   // Höhe und Breite vom Bild ausgeben
    Bild1 := TBitmap.Create;
    try
     jpg := TJpegImage.Create;
     try
       Bild1.PixelFormat := pf24Bit;
       jpg.LoadFromFile(s); // Bild laden Pfad und DateiName übergeben
       Bild1.Assign(jpg);  // JPG den Bitmap zuweisen
       Label11.Caption := 'Pixel: ' + Inttostr(Bild1.Width);
       Label10.Caption := 'Pixel: ' + Inttostr(Bild1.Height);
     finally Bild1.Free;
     end;
   finally jpg.free;
   end;
  Screen.Cursor := crDefault;
end;

procedure TForm1.StylesButton2Click(Sender: TObject);
var s: String;
    i: Integer;
begin
   for i := 0 to Listbox2.Items.Count -1 do begin
      if FileExists(ListBox2.Items.Strings[i]) then begin
         s := ListBox2.Items.Strings[i];
         DeleteFile(s);
      end; // if
   end; // for
   Listbox2.Clear;
end;

procedure TForm1.StylesButton1Click(Sender: TObject);
begin
  Listbox1.Clear;
end;



procedure TForm1.FormShow(Sender: TObject);
begin
   FileSiceListBox1.Brush.Color := $0000FF80;
   DirectoryListBox1.Brush.Color := $0000FF80;
   ListBox1.Brush.Color := $0000FF80;
   ListBox2.Brush.Color := $0000FF80;
end;




end.

//------------------------------------------------------------------------------------------------