mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-01 02:23:40 +02:00
505 lines
12 KiB
ObjectPascal
505 lines
12 KiB
ObjectPascal
{
|
|
***************************************************************************
|
|
* *
|
|
* This source is free software; you can redistribute it and/or modify *
|
|
* it under the terms of the GNU General Public License as published by *
|
|
* the Free Software Foundation; either version 2 of the License, or *
|
|
* (at your option) any later version. *
|
|
* *
|
|
* This code is distributed in the hope that it will be useful, but *
|
|
* WITHOUT ANY WARRANTY; without even the implied warranty of *
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
|
|
* General Public License for more details. *
|
|
* *
|
|
* A copy of the GNU General Public License is available on the World *
|
|
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
|
|
* obtain it by writing to the Free Software Foundation, *
|
|
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
|
|
* *
|
|
***************************************************************************
|
|
}
|
|
unit frmmain;
|
|
|
|
{$MODE Delphi}
|
|
|
|
interface
|
|
|
|
uses
|
|
LCLIntf,SysUtils, Types, Classes, Graphics, Controls, Forms,
|
|
Dialogs, StdCtrls, ImgList, ComCtrls, ExtCtrls, ActnList, Menus,
|
|
ToolWin, LResources;
|
|
|
|
type
|
|
TMainForm = class(TForm)
|
|
MainMenu1: TMainMenu;
|
|
ToolBar1: TToolBar;
|
|
ActionList1: TActionList;
|
|
AOpen: TAction;
|
|
AOpenDir: TAction;
|
|
AExit: TAction;
|
|
LBFiles: TListBox;
|
|
SPImage: TSplitter;
|
|
File1: TMenuItem;
|
|
MIOpen: TMenuItem;
|
|
MIOPenDir: TMenuItem;
|
|
N1: TMenuItem;
|
|
MIQuit: TMenuItem;
|
|
TBOPen: TToolButton;
|
|
TBOpenDir: TToolButton;
|
|
ILMain: TImageList;
|
|
ODImage: TOpenDialog;
|
|
AClear: TAction;
|
|
MIOpenDirRec: TMenuItem;
|
|
MIClear: TMenuItem;
|
|
OpenDirRecursively: TAction;
|
|
TBOpenDirRec: TToolButton;
|
|
ADoubleSize: TAction;
|
|
MImage: TMenuItem;
|
|
D1: TMenuItem;
|
|
AHalfSize: TAction;
|
|
MIHalfSize: TMenuItem;
|
|
PImage: TPanel;
|
|
ScrollBox1: TScrollBox;
|
|
IMain: TImage;
|
|
ANextImage: TAction;
|
|
APreviousImage: TAction;
|
|
ANextImageDir: TAction;
|
|
APrevImageDir: TAction;
|
|
MINextImage: TMenuItem;
|
|
PreviousImage1: TMenuItem;
|
|
Nextimagedirectory1: TMenuItem;
|
|
Previousimagedirectory1: TMenuItem;
|
|
ToolButton4: TToolButton;
|
|
TBPRev: TToolButton;
|
|
TBNext: TToolButton;
|
|
TBPRevDir: TToolButton;
|
|
TBNextDir: TToolButton;
|
|
TBDoubleSize: TToolButton;
|
|
TBHalfSize: TToolButton;
|
|
ToolButton3: TToolButton;
|
|
N2: TMenuItem;
|
|
OpenDialog1: TOpenDialog;
|
|
procedure AOpenExecute(Sender: TObject);
|
|
procedure LBFilesClick(Sender: TObject);
|
|
procedure AOpenDirExecute(Sender: TObject);
|
|
procedure AExitExecute(Sender: TObject);
|
|
procedure OpenDirRecursivelyExecute(Sender: TObject);
|
|
procedure AClearExecute(Sender: TObject);
|
|
procedure ADoubleSizeExecute(Sender: TObject);
|
|
procedure AHalfSizeExecute(Sender: TObject);
|
|
procedure FormKeyDown(Sender: TObject; var Key: Word;
|
|
Shift: TShiftState);
|
|
procedure FormShow(Sender: TObject);
|
|
procedure ANextImageExecute(Sender: TObject);
|
|
procedure APreviousImageExecute(Sender: TObject);
|
|
procedure ANextImageDirExecute(Sender: TObject);
|
|
procedure APrevImageDirExecute(Sender: TObject);
|
|
private
|
|
FImageScale : Double;
|
|
procedure AddFile(FileName: String; ShowFile: Boolean);
|
|
procedure ShowFile(Index: Integer);
|
|
procedure AddDir(Directory: String; Recurse: Boolean);
|
|
procedure RescaleImage(NewScale: Double);
|
|
procedure NextImage;
|
|
procedure PreviousImage;
|
|
procedure NextImageDir;
|
|
procedure PreviousImageDir;
|
|
Function NextDirIndex(Direction : Integer) : Integer;
|
|
procedure ShiftImageIndex(MoveBy: Integer);
|
|
procedure ProcessCommandLine;
|
|
procedure DoError(Msg: String; Args: array of const);
|
|
{ Private declarations }
|
|
public
|
|
{ Public declarations }
|
|
end;
|
|
|
|
var
|
|
MainForm: TMainForm;
|
|
|
|
implementation
|
|
|
|
uses filectrl,lazjpeg,lcltype;
|
|
|
|
|
|
Const
|
|
ImageTypes = '.jpg.jpeg.bmp.xpm.png';
|
|
|
|
resourcestring
|
|
SSelectImageDir = 'Select directory to add images from';
|
|
SSelectImageDirRec = 'Select directory to recursively add images from';
|
|
SImageViewer = 'Image viewer';
|
|
SErrNeedArgument = 'Option at position%d (%s) needs an argument';
|
|
|
|
{ [] }
|
|
procedure TMainForm.AOpenExecute(Sender: TObject);
|
|
|
|
Var
|
|
I : Integer;
|
|
|
|
begin
|
|
With ODImage do
|
|
begin
|
|
If Execute then
|
|
for I:=0 to Files.Count-1 do
|
|
AddFile(Files[I],(I=0))
|
|
end;
|
|
end;
|
|
|
|
procedure TMainForm.AddFile(FileName :String; ShowFile : Boolean);
|
|
|
|
Var
|
|
Index : Integer;
|
|
|
|
begin
|
|
ShowFile:=ShowFile or (LBFiles.Items.Count=0);
|
|
Index:=LBFiles.Items.Add(FileName);
|
|
If ShowFile then
|
|
self.ShowFile(Index);
|
|
end;
|
|
|
|
procedure TMainForm.ShowFile(Index : Integer);
|
|
|
|
Var
|
|
LoadOK : Boolean;
|
|
|
|
begin
|
|
If Index=-1 then
|
|
begin
|
|
IMain.Picture:=Nil;
|
|
Caption:=SImageViewer;
|
|
end
|
|
else
|
|
Repeat
|
|
Try
|
|
LoadOK:=False;
|
|
IMain.Align:=AlClient;
|
|
Imain.Stretch:=False;
|
|
FImageScale:=1.0;
|
|
IMain.Picture.LoadFromFile(LBFiles.Items[Index]);
|
|
Caption:=SImageViewer+'('+LBFiles.Items[Index]+')';
|
|
LoadOK:=True;
|
|
Except
|
|
If Index<LBFiles.Items.Count-1 then
|
|
inc(Index)
|
|
else
|
|
Index:=-1;
|
|
end
|
|
Until LoadOK or (Index=-1);
|
|
With LBFiles do
|
|
begin
|
|
If Index<>ItemIndex then
|
|
LBFiles.Itemindex:=Index;
|
|
{ If Not ItemVisible(ItemIndex) then
|
|
MakeCurrentVisible;}
|
|
end;
|
|
end;
|
|
|
|
procedure TMainForm.LBFilesClick(Sender: TObject);
|
|
begin
|
|
ShowFile(LBFiles.ItemIndex);
|
|
end;
|
|
|
|
procedure TMainForm.AOpenDirExecute(Sender: TObject);
|
|
|
|
Var
|
|
Dir : String;
|
|
|
|
begin
|
|
if SelectDirectory(SSelectImageDir,'/',Dir) then
|
|
|
|
// if SelectDirectory(SSelectImageDir,'/',Dir,True) then
|
|
AddDir(Dir,False);
|
|
end;
|
|
|
|
procedure TMainForm.AddDir(Directory :String; Recurse : Boolean);
|
|
|
|
Var
|
|
Info : TSearchRec;
|
|
Ext : String;
|
|
begin
|
|
LBFiles.Items.BeginUpdate;
|
|
Try
|
|
Directory:=IncludeTrailingBackslash(Directory);
|
|
if FindFirst(Directory+'*.*',0,Info)=0 then
|
|
try
|
|
Repeat
|
|
Ext:=ExtractFileExt(Info.Name);
|
|
If Pos(Ext,ImageTypes)<>0 then
|
|
AddFile(Directory+Info.Name,False);
|
|
until (FindNext(Info)<>0)
|
|
Finally
|
|
FindClose(Info);
|
|
end;
|
|
If Recurse then
|
|
if FindFirst(Directory+'*',faDirectory,Info)=0 then
|
|
try
|
|
Repeat
|
|
If (Info.Name<>'.') and
|
|
(info.name<>'..') and
|
|
((Info.Attr and faDirectory)<>0) then
|
|
AddDir(Directory+Info.name,True);
|
|
until (FindNext(Info)<>0)
|
|
finally
|
|
FindClose(Info);
|
|
end;
|
|
Finally
|
|
LBFiles.Items.EndUpdate;
|
|
end;
|
|
end;
|
|
|
|
procedure TMainForm.AExitExecute(Sender: TObject);
|
|
begin
|
|
Close;
|
|
end;
|
|
|
|
procedure TMainForm.OpenDirRecursivelyExecute(Sender: TObject);
|
|
|
|
Var
|
|
Dir : String;
|
|
|
|
begin
|
|
if SelectDirectory(SSelectImageDirRec,'/',Dir) then
|
|
AddDir(Dir,True);
|
|
end;
|
|
|
|
procedure TMainForm.AClearExecute(Sender: TObject);
|
|
begin
|
|
LBFiles.ItemIndex:=-1;
|
|
ShowFile(-1);
|
|
LBFiles.Items.Clear;
|
|
end;
|
|
|
|
procedure TMainForm.ADoubleSizeExecute(Sender: TObject);
|
|
|
|
begin
|
|
RescaleImage(2.0);
|
|
end;
|
|
|
|
procedure TMainForm.RescaleImage(NewScale : Double);
|
|
|
|
Var
|
|
OrgWidth,OrgHeight : Integer;
|
|
Rect : TRect;
|
|
|
|
begin
|
|
OrgWidth:=IMain.Picture.Bitmap.Width;
|
|
OrgHeight:=IMain.Picture.Bitmap.Height;
|
|
FImageScale:=FImageScale*NewScale;
|
|
Rect:=IMain.BoundsRect;
|
|
Rect.Right:=Rect.Left+Round(OrgWidth*FImageScale);
|
|
Rect.Bottom:=Rect.Top+Round(OrgHeight*FImageScale);
|
|
Imain.Align:=AlNone;
|
|
IMain.BoundsRect:=Rect;
|
|
Imain.Stretch:=True;
|
|
end;
|
|
|
|
procedure TMainForm.AHalfSizeExecute(Sender: TObject);
|
|
begin
|
|
RescaleImage(0.5);
|
|
end;
|
|
|
|
procedure TMainForm.NextImage;
|
|
|
|
begin
|
|
ShiftImageIndex(1);
|
|
end;
|
|
|
|
procedure TMainForm.PreviousImage;
|
|
|
|
begin
|
|
ShiftImageIndex(-1);
|
|
end;
|
|
|
|
procedure TMainForm.ShiftImageIndex(MoveBy : Integer);
|
|
|
|
Var
|
|
ImageIndex : Integer;
|
|
|
|
begin
|
|
ImageIndex:=LBFiles.ItemIndex;
|
|
ImageIndex:=ImageIndex+MoveBy;
|
|
If ImageIndex<0 then
|
|
ImageIndex:=LBFiles.Items.Count-1;
|
|
If ImageIndex>=LBFiles.Items.Count then
|
|
begin
|
|
ImageIndex:=0;
|
|
If LBFiles.Items.Count=0 then
|
|
ImageIndex:=-1;
|
|
end;
|
|
ShowFile(ImageIndex);
|
|
end;
|
|
|
|
procedure TMainForm.FormKeyDown(Sender: TObject; var Key: Word;
|
|
Shift: TShiftState);
|
|
begin
|
|
if (shift=[ssShift]) or (shift=[ssAlt]) then
|
|
begin
|
|
if (key=VK_Prior) then
|
|
begin
|
|
RescaleImage(2.0);
|
|
Key:=0;
|
|
end
|
|
else if (key=VK_Next) then
|
|
begin
|
|
RescaleImage(0.5);
|
|
Key:=0;
|
|
end
|
|
else if (key=VK_Left) then
|
|
begin
|
|
PreviousImage;
|
|
Key:=0;
|
|
end
|
|
else if (key=VK_right) then
|
|
begin
|
|
NextImage;
|
|
Key:=0;
|
|
end
|
|
end
|
|
else if (shift=[]) then
|
|
begin
|
|
if Key=VK_UP then
|
|
Previousimage
|
|
else if Key=VK_DOWN then
|
|
NextImage;
|
|
end;
|
|
end;
|
|
procedure TMainForm.DoError(Msg : String; Args : Array Of const);
|
|
|
|
begin
|
|
ShowMessage(Format(Msg,Args));
|
|
end;
|
|
|
|
procedure TMainForm.ProcessCommandLine;
|
|
|
|
Function CheckOption(Index : Integer;Short,Long : String): Boolean;
|
|
|
|
var
|
|
O : String;
|
|
|
|
begin
|
|
O:=Paramstr(Index);
|
|
Result:=(O='-'+short) or (copy(O,1,Length(Long)+3)=('--'+long+'='));
|
|
end;
|
|
|
|
Function OptionArg(Var Index : Integer) : String;
|
|
|
|
Var
|
|
P : Integer;
|
|
|
|
begin
|
|
if (Length(ParamStr(Index))>1) and (Paramstr(Index)[2]<>'-') then
|
|
begin
|
|
If Index<ParamCount then
|
|
begin
|
|
Inc(Index);
|
|
Result:=Paramstr(Index);
|
|
end
|
|
else
|
|
DoError(SErrNeedArgument,[Index,ParamStr(Index)]);
|
|
end
|
|
else If length(ParamStr(Index))>2 then
|
|
begin
|
|
P:=Pos('=',Paramstr(Index));
|
|
If (P=0) then
|
|
DoError(SErrNeedArgument,[Index,ParamStr(Index)])
|
|
else
|
|
begin
|
|
Result:=Paramstr(Index);
|
|
Delete(Result,1,P);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
Var
|
|
I : Integer;
|
|
S : String;
|
|
FRecursive : Boolean;
|
|
|
|
begin
|
|
FRecursive:=False;
|
|
I:=0;
|
|
While (I<ParamCount) do
|
|
begin
|
|
Inc(I);
|
|
If CheckOption(I,'r','recursive') then
|
|
FRecursive:=True
|
|
else
|
|
begin
|
|
S:=ParamStr(I);
|
|
If DirectoryExists(S) then
|
|
AddDir(ExpandFileName(S),FRecursive)
|
|
else if FileExists(S) then
|
|
AddFile(ExpandFileName(S),LBFiles.Items.Count=0);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TMainForm.FormShow(Sender: TObject);
|
|
begin
|
|
ProcessCommandLine;
|
|
end;
|
|
|
|
procedure TMainForm.NextImageDir;
|
|
|
|
Var
|
|
Index : Integer;
|
|
|
|
begin
|
|
Index:=NextDirIndex(1);
|
|
If (Index<>-1) then
|
|
ShowFile(Index);
|
|
end;
|
|
|
|
Function TMainForm.NextDirIndex(Direction: Integer) : integer;
|
|
|
|
Var
|
|
Dir : String;
|
|
|
|
begin
|
|
Result:=-1;
|
|
If LBFiles.Itemindex=-1 then
|
|
Exit;
|
|
Result:=LBFiles.Itemindex;
|
|
Dir:=ExtractFilePath(LBFiles.Items[Result]);
|
|
Repeat
|
|
Result:=Result+Direction;
|
|
Until ((Result=-1) or (Result>=LBFiles.Items.Count)) or (Dir<>ExtractFilePath(LBFiles.Items[Result]));
|
|
If Result>=LBFiles.Items.Count then
|
|
Result:=-1;
|
|
end;
|
|
|
|
procedure TMainForm.PreviousImageDir;
|
|
Var
|
|
Index : Integer;
|
|
|
|
begin
|
|
Index:=NextDirIndex(-1);
|
|
If (Index<>-1) then
|
|
ShowFile(Index);
|
|
end;
|
|
|
|
procedure TMainForm.ANextImageExecute(Sender: TObject);
|
|
begin
|
|
NextImage;
|
|
end;
|
|
|
|
procedure TMainForm.APreviousImageExecute(Sender: TObject);
|
|
begin
|
|
PreviousImage
|
|
end;
|
|
|
|
procedure TMainForm.ANextImageDirExecute(Sender: TObject);
|
|
begin
|
|
NextImageDir;
|
|
end;
|
|
|
|
procedure TMainForm.APrevImageDirExecute(Sender: TObject);
|
|
begin
|
|
PreviousImageDir;
|
|
end;
|
|
|
|
initialization
|
|
{$i frmmain.lrs}
|
|
|
|
end.
|