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.

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