Zurück zu JPG-Verkleinern.
Delphi Code vom JPG Verkleinern mit Drag'n'Drop
Hier wird die Möglichkeit genutzt einfach vom Explorer JPG oder JPEG-Dateien rüber zu ziehen peer Drag'n'Drop,
und dann zu verkleiner.
Wer Fehler findet kann die behalten!
//---------------------------------------------------------------------------------------------
unit JPEGU1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StylesButton, Spin, StdCtrls, ExtCtrls, MyPanel2, jpeg, Menus;
type
TForm1 = class(TForm)
Panel2: TPanel;
BildPanel2: TBildPanel;
Edit3: TEdit;
Label9: TLabel;
SpinEdit1: TSpinEdit;
Panel3: TPanel;
ListBox2: TListBox;
ListBox3: TListBox;
Label6: TLabel;
StylesButton1: TStylesButton;
Panel4: TPanel;
Label7: TLabel;
StylesButton2: TStylesButton;
ListBox1: TListBox;
BildPanel1: TBildPanel;
Bevel1: TBevel;
Label3: TLabel;
Label10: TLabel;
Label11: TLabel;
Label1: TLabel;
Label2: TLabel;
Edit1: TEdit;
Edit2: TEdit;
Splitter1: TSplitter;
Label4: TLabel;
Label5: TLabel;
Label8: TLabel;
PopupMenu1: TPopupMenu;
Delte1: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure StylesButton1Click(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure StylesButton2Click(Sender: TObject);
procedure ListBox2DblClick(Sender: TObject);
procedure Edit1Change(Sender: TObject);
procedure ListBox1Click(Sender: TObject);
procedure ListBox1DblClick(Sender: TObject);
procedure ListBox2Click(Sender: TObject);
procedure Delte1Click(Sender: TObject);
private
// Um von den Explorer Botschaften empfangen zu können
procedure WMDROPFILES(var Msg: TMessage); message WM_DROPFILES;
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
uses ShellAPI;
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.HintColor := $004DE160;
Application.HintPause := 1500;
Application.HintHidePause := 3500;
//Für Drag'n'Drop auserhalb von diesen Windows Fenster in diese Fenster
DragAcceptFiles(Listbox1.Handle, true);
end;
// DragAcceptFiles DragQueryFiles DragFinish
const DF_NUMBEROFFILES = $FFFFFFFF;
{die Funktion DragQueryFile. Sie erwartet folgende Parameter:
Drop: Identifiert die Struktur die die Dateinamen enthält.
FileIndex: Index der Datei, die in den Puffer geladen werden soll.
Wenn für diesen Parameter $FFFFFFFF übergeben wird, erhält man als
Rückgabewert die Anzahl der Dateien.
FileName: PChar, in den der Dateiname geladen wird. Wird für diesen
Parameter nil übergeben, erhält man als Rückgabewert die erforderliche
Größe für den Dateinamen.
cb: Länge des Teilstückes, das gelesen werden soll
Nach der Initialisierung der Puffervariablen Dateiname bestimmen wir die Anzahl
der übergebenen Dateien. Dabei muss der zweite Parameter von DragQueryFile
auf $FFFFFFFF gesetzt werden. Wir übergeben DF_NUMBEROFFILES. Diese Konstante
haben wir zuvor als $FFFFFFFF definiert.}
procedure TForm1.WMDROPFILES(var Msg: TMessage);
var i, anzahl, size: Integer;
Dateiname: PChar;
s, s2: String;
begin
inherited;
anzahl := DragQueryFile(Msg.WParam, DF_NUMBEROFFILES, Dateiname, 255);
for i := 0 to (anzahl - 1) do
begin
size := DragQueryFile(Msg.WParam, i, nil, 0) + 1;
Dateiname := StrAlloc(size);
DragQueryFile(Msg.WParam, i, Dateiname, size);
s := StrPas(Dateiname);
// Filter : Dateiendung auslesen und in Klein Buchstaben umwandeln
s2 := LowerCase(ExtractFileExt(s)); //
if s2 = '.jpg' then
Listbox1.Items.Add(s);
if s2 = '.jpeg' then
Listbox1.Items.Add(s);
StrDispose(Dateiname); // String vom Heap entfernen
end;
DragFinish(Msg.WParam);
end;
procedure TForm1.StylesButton1Click(Sender: TObject);
begin
Listbox2.Clear;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
// ListBox3.Brush.Color := $0000FF80;
// ListBox1.Brush.Color := $0000FF80;
// ListBox2.Brush.Color := $0000FF80;
end;
procedure TForm1.StylesButton2Click(Sender: TObject);
var s: String;
i: Integer;
begin
for i := 0 to Listbox3.Items.Count -1 do begin
if FileExists(ListBox3.Items.Strings[i]) then begin
s := ListBox3.Items.Strings[i];
DeleteFile(s);
end; // if
end; // for
Listbox3.Clear;
end;
procedure TForm1.ListBox2DblClick(Sender: TObject);
var s: String;
begin
if FileExists(ListBox2.Items.Strings[ListBox2.ItemIndex]) then begin
s := ListBox2.Items.Strings[ListBox2.ItemIndex];
ShellExecute(handle, nil, Pchar(s), nil, nil, SW_SHOW);
end;
end;
procedure TForm1.Edit1Change(Sender: TObject);
begin
Edit2.Text := Edit1.Text;
end;
procedure TForm1.ListBox1Click(Sender: TObject);
var Bild1: Tbitmap;
jpg: TJpegImage;
s: String;
begin
Screen.Cursor := crHourGlass;
s := '';
s := ListBox1.Items.Strings[ListBox1.ItemIndex];
// 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.ListBox1DblClick(Sender: TObject);
var Bild1, Bild2: Tbitmap;
jpg, jpg2 : TJpegImage;
i: Integer;
Hoehe, Breite: Real;
s, s2, s3: String;
begin
Screen.Cursor := crHourGlass;
s := ''; s2 := '';
Hoehe := 10; Breite := 10;
s := ListBox1.Items.Strings[ListBox1.ItemIndex];
//--------------------------------------------------------
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
ListBox3.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
ListBox2.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;
procedure TForm1.ListBox2Click(Sender: TObject);
var Bild1: Tbitmap;
jpg: TJpegImage;
s: String;
begin
Screen.Cursor := crHourGlass;
s := '';
s := ListBox2.Items.Strings[ListBox2.ItemIndex];
// 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
Label4.Caption := 'Pixel: ' + Inttostr(Bild1.Width);
Label5.Caption := 'Pixel: ' + Inttostr(Bild1.Height);
finally Bild1.Free;
end;
finally jpg.free;
end;
Screen.Cursor := crDefault;
end;
procedure TForm1.Delte1Click(Sender: TObject);
var s: String;
begin
if ListBox3.Items.Count > 0 then begin
try
if ListBox3.Selected[ListBox3.ItemIndex] then begin
s := ListBox3.Items.Strings[ListBox3.ItemIndex];
if FileExists(s) then begin
DeleteFile(s);
Listbox3.Items.Delete(ListBox3.ItemIndex);
end; // if
end; // wenn Kein Eintrag selectiert ist muss der Fehler abgefangen werden
except
ShowMessage('Sie müssen erst eienen Eintrag wählen');
end;
end;
end;
end.
//------------------------------------------------------------------------------------------------