Check-in [aeddb28d5f]

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Start using FreeImage to load images. Added DataModule to host the tray icon and its menu. Main form can now show a scaled version of the desktop, and allows for selection of separate monitors.
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: aeddb28d5f93139b7d1fa77fc566e5b5f03eded7
User & Date: tinus 2014-11-07 23:06:21
Context
2014-12-01
20:42
Show selected monitor border on main form, and draw each respective monitor's image. Click to (de)select a monitor. Read random file from local directory. check-in: 05c2a5be28 user: tinus tags: trunk
2014-11-07
23:06
Start using FreeImage to load images. Added DataModule to host the tray icon and its menu. Main form can now show a scaled version of the desktop, and allows for selection of separate monitors. check-in: aeddb28d5f user: tinus tags: trunk
22:48
Added wrapper units for FreeImage (version 3.16) check-in: fb041e1ec0 user: tinus tags: trunk
Changes

Changes to src/F_Main.dfm.

1
2
3
4
5
6
7
8
9
10
11
12
13





14
15
16

17
18
















19
20

21
22






23
24

object frmMain: TfrmMain
  Left = 0
  Top = 0
  Caption = 'Wallpaper Cycler'
  ClientHeight = 282
  ClientWidth = 418
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False





  PixelsPerInch = 96
  TextHeight = 13
  object trayIcon: TTrayIcon

    Left = 24
    Top = 208
















  end
  object pumTray: TPopupMenu

    Left = 72
    Top = 208






  end
end





|
|







>
>
>
>
>


<
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
>
|
|
>
>
>
>
>
>
|
|
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20

21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40

41
42
43
44
45
46
47
48
49
50
51
52
object frmMain: TfrmMain
  Left = 0
  Top = 0
  Caption = 'Wallpaper Cycler'
  ClientHeight = 369
  ClientWidth = 561
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  OnResize = FormResize
  DesignSize = (
    561
    369)
  PixelsPerInch = 96
  TextHeight = 13

  object pnlDesktop: TPanel
    Left = 8
    Top = 8
    Width = 545
    Height = 212
    Anchors = [akLeft, akTop, akRight]
    DoubleBuffered = True
    ParentBackground = False
    ParentDoubleBuffered = False
    TabOrder = 0
    object pbxDesktop: TPaintBox
      Left = 1
      Top = 1
      Width = 543
      Height = 210
      Align = alClient
      OnClick = pbxDesktopClick
      OnPaint = pbxDesktopPaint
      ExplicitLeft = 0
    end

    object shpMonitor: TShape
      Left = 176
      Top = 104
      Width = 65
      Height = 65
      Brush.Style = bsClear
      Pen.Mode = pmNot
      Pen.Style = psDot
      OnMouseDown = shpMonitorMouseDown
    end
  end
end

Changes to src/F_Main.pas.

1
2
3
4
5
6
7

8
9
10
11
12







13
14

15
16
17
18
19
20
21
22
23
24
25












































































26
unit F_Main;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Menus, Vcl.ExtCtrls;


type
  TfrmMain = class(TForm)
    trayIcon: TTrayIcon;
    pumTray: TPopupMenu;







  private
    { Private declarations }

  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.dfm}













































































end.






|
>



|
|
>
>
>
>
>
>
>


>











>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
unit F_Main;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Menus, Vcl.ExtCtrls,
  M_Main;

type
  TfrmMain = class(TForm)
    pnlDesktop: TPanel;
    pbxDesktop: TPaintBox;
    shpMonitor: TShape;
    procedure pbxDesktopPaint(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure shpMonitorMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormCreate(Sender: TObject);
    procedure pbxDesktopClick(Sender: TObject);
  private
    { Private declarations }
    FMonitorShape: array of TShape;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.dfm}

procedure TfrmMain.FormCreate(Sender: TObject);
var
  i: integer;
begin
  SetLength(FMonitorShape, Screen.MonitorCount);
  for i := Low(FMonitorShape) to High(FMonitorShape) do begin
    if Screen.Monitors[i].Primary then begin
      FMonitorShape[i] := shpMonitor;
    end else begin
      FMonitorShape[i] := TShape.Create(Self);
      FMonitorShape[i].Parent := pnlDesktop;
      FMonitorShape[i].OnMouseDown := shpMonitorMouseDown;
      FMonitorShape[i].Brush.Style := bsClear;
      FMonitorShape[i].Pen.Style := psDot;
      FMonitorShape[i].Pen.Mode := pmNot;
      FMonitorShape[i].Visible := True;
    end;
  end;
end;

procedure TfrmMain.FormResize(Sender: TObject);
var
  ScaleFactor: Double;
  DR, MR: TRect;
  function ScaleR(const R: TRect): TRect;
  begin
    Result.Left := Trunc((R.Left - DR.Left) * ScaleFactor);
    Result.Top := Trunc((R.Top - DR.Top) * ScaleFactor);
    Result.Width := Trunc(R.Width * ScaleFactor);
    Result.Height := Trunc(R.Height * ScaleFactor);
  end;
var
  i: Integer;
  Mon: TMonitor;
begin
  DR := Screen.DesktopRect;
  ScaleFactor := pnlDesktop.ClientWidth / DR.Width;
  pnlDesktop.Height := Trunc(DR.Height * ScaleFactor);
  for i := 0 to Screen.MonitorCount - 1 do begin
    Mon := Screen.Monitors[i];
    MR := ScaleR(Mon.WorkareaRect);
    FMonitorShape[i].SetBounds(MR.Left + pbxDesktop.Left,
                               MR.Top + pbxDesktop.Top,
                               MR.Width,
                               MR.Height);
  end;
end;

procedure TfrmMain.pbxDesktopClick(Sender: TObject);
var
  i: Integer;
begin
  for i := Low(FMonitorShape) to High(FMonitorShape) do begin
    FMonitorShape[i].Pen.Style := psDot;
  end;
end;

procedure TfrmMain.pbxDesktopPaint(Sender: TObject);
begin
  modMain.Desktop.Draw(pbxDesktop.Canvas, pbxDesktop.BoundsRect);
end;

procedure TfrmMain.shpMonitorMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  i: Integer;
begin
  for i := Low(FMonitorShape) to High(FMonitorShape) do begin
    if (Sender = FMonitorShape[i]) and (FMonitorShape[i].Pen.Style = psDot) then begin
      FMonitorShape[i].Pen.Style := psSolid;
    end else begin
      FMonitorShape[i].Pen.Style := psDot;
    end;
  end;
end;

end.

Changes to src/ImgSize.pas.

2
3
4
5
6
7
8

9
10
11
12
13
14
15
16
...
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
...
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
(*
  http://stackoverflow.com/questions/15209076/how-to-get-dimensions-of-image-file-in-delphi
  2014-10-04
*)

interface


uses Classes;

function GetJPGSize(const sFile: string; out wWidth, wHeight: word): Boolean; inline; overload;
function GetJPGSize(const Stream: TStream; out wWidth, wHeight: word): Boolean; overload;
function GetPNGSize(const sFile: string; out wWidth, wHeight: word): Boolean; inline; overload;
function GetPNGSize(const Stream: TStream; out wWidth, wHeight: word): Boolean; overload;
function GetGIFSize(const sGIFFile: string; out wWidth, wHeight: word): Boolean; inline; overload;
function GetGIFSize(const Stream: TStream; out wWidth, wHeight: word): Boolean; overload;
................................................................................
  begin
    x := 3 * (1 SHL ((Header.Flags and 7) + 1));
    Stream.Seek(x, TSeekOrigin.soBeginning);
  end;
  DimensionsFound := False;
  FillChar(ImageBlock, SizeOf(TGIFImageBlock), #0);
  // Step through blocks
  nResult := Stream.Read(c, 1);
  while (not (Stream.Position >= Stream.Size)) and (not DimensionsFound) do
  begin
    case c of
    ',':  // Found image
      begin
        nResult := Stream.Read(ImageBlock, SizeOf(TGIFImageBlock));
        if nResult <> SizeOf(TGIFImageBlock) then
................................................................................
        end;
        wWidth := ImageBlock.Width;
        wHeight := ImageBlock.Height;
        DimensionsFound := True;
      end;
      // nothing else, just ignore
    end;
    nResult := Stream.Read(c, 1);
  end {while};
{$I+}

end{GetGIFSize};


function GetBMPSize(const sFile: string; out Width, Height: integer): boolean;







>
|







 







|







 







|







2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
...
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
...
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
(*
  http://stackoverflow.com/questions/15209076/how-to-get-dimensions-of-image-file-in-delphi
  2014-10-04
*)

interface

uses
  Classes;

function GetJPGSize(const sFile: string; out wWidth, wHeight: word): Boolean; inline; overload;
function GetJPGSize(const Stream: TStream; out wWidth, wHeight: word): Boolean; overload;
function GetPNGSize(const sFile: string; out wWidth, wHeight: word): Boolean; inline; overload;
function GetPNGSize(const Stream: TStream; out wWidth, wHeight: word): Boolean; overload;
function GetGIFSize(const sGIFFile: string; out wWidth, wHeight: word): Boolean; inline; overload;
function GetGIFSize(const Stream: TStream; out wWidth, wHeight: word): Boolean; overload;
................................................................................
  begin
    x := 3 * (1 SHL ((Header.Flags and 7) + 1));
    Stream.Seek(x, TSeekOrigin.soBeginning);
  end;
  DimensionsFound := False;
  FillChar(ImageBlock, SizeOf(TGIFImageBlock), #0);
  // Step through blocks
  {nResult := }Stream.Read(c, 1);
  while (not (Stream.Position >= Stream.Size)) and (not DimensionsFound) do
  begin
    case c of
    ',':  // Found image
      begin
        nResult := Stream.Read(ImageBlock, SizeOf(TGIFImageBlock));
        if nResult <> SizeOf(TGIFImageBlock) then
................................................................................
        end;
        wWidth := ImageBlock.Width;
        wHeight := ImageBlock.Height;
        DimensionsFound := True;
      end;
      // nothing else, just ignore
    end;
    {nResult := }Stream.Read(c, 1);
  end {while};
{$I+}

end{GetGIFSize};


function GetBMPSize(const sFile: string; out Width, Height: integer): boolean;

Changes to src/L_FileList.pas.

1
2
3
4
5

6
7
8
9
10
11
12
13
14
15
16

17
18
19


20
21
22


23
24
25
26
27
28
29
..
35
36
37
38
39
40
41
42




















43
unit L_FileList;

interface
uses
  System.Generics.Collections;


type
  TPLInclusion = (Inherit, Include, IncludeRecursive, Exclude, ExcludeRecursive);

  TPLFileListSource = class
  public
    constructor Create(const Path: string; const Inclusion: TPLInclusion);
  end;

  TPLFileListSources = class(TList<TPLFileListSource>);


  TPLFileList = class(TList<string>)
  private
    FSources: TPLFileListSources;


  public
    constructor Create;
    destructor  Destroy; override;



    property Sources: TPLFileListSources  read FSources;
  end;

implementation

{ TPLFileList }
................................................................................
end;

destructor TPLFileList.Destroy;
begin
  FSources.Free;
  inherited;
end;





















end.




|
>






|




>
|


>
>



>
>







 








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
..
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
unit L_FileList;

interface
uses
  System.Generics.Collections,
  U_WPImages;

type
  TPLInclusion = (Inherit, Include, IncludeRecursive, Exclude, ExcludeRecursive);

  TPLFileListSource = class
  public
//    constructor Create(const Path: string; const Inclusion: TPLInclusion);
  end;

  TPLFileListSources = class(TList<TPLFileListSource>);

  // TODO: we should keep track of the source(s) of each string, as well as the string
  TPLFileList = class(TList<TWPImage>)
  private
    FSources: TPLFileListSources;
  protected
    procedure Notify(const Item: TWPImage; Action: TCollectionNotification); override;
  public
    constructor Create;
    destructor  Destroy; override;

    procedure Update;

    property Sources: TPLFileListSources  read FSources;
  end;

implementation

{ TPLFileList }
................................................................................
end;

destructor TPLFileList.Destroy;
begin
  FSources.Free;
  inherited;
end;

procedure TPLFileList.Notify(const Item: TWPImage; Action: TCollectionNotification);
begin
  // TODO: replace item by final pathname of item; shouldn't we do that for this?
  inherited;
end;

procedure TPLFileList.Update;
begin
  // TODO: expand each path into its final pathname
  // TODO: split file sources into inclusion and exclusion sources
  // TODO: check if there's no inclusion source completely prohibited by an exclusion source.
  // TODO:  if so, leave that out of our calculations.
  // TODO: loop through inclusion sources.
  // TODO:  for each file found:
  // TODO:   get the final path name
  // TODO:   check if it matches an exclusion source.
  // TODO:   if it doesn't, check if we haven't got the file already
  // TODO:   if we don't, add the file to our list.
end;

end.

Added src/M_Main.dfm.





























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
object modMain: TmodMain
  OldCreateOrder = False
  OnCreate = DataModuleCreate
  OnDestroy = DataModuleDestroy
  Height = 375
  Width = 418
  object trayIcon: TTrayIcon
    PopupMenu = pumTray
    OnDblClick = trayIconDblClick
    Left = 40
    Top = 288
  end
  object pumTray: TPopupMenu
    Left = 88
    Top = 288
    object actListShow1: TMenuItem
      Action = actListShow
      Default = True
    end
    object N1: TMenuItem
      Caption = '-'
    end
    object Exit1: TMenuItem
      Action = actFileExit
    end
  end
  object aclMain: TActionList
    Left = 168
    Top = 288
    object actListAddFile: TAction
      Category = 'List'
      Caption = 'Add file...'
    end
    object actListAddFolder: TAction
      Category = 'List'
      Caption = 'Add folder...'
    end
    object actWPSwitch: TAction
      Category = 'Wallpaper'
      Caption = 'actWPSwitch'
    end
    object actWPSwitchMonitor: TAction
      Category = 'Wallpaper'
      Caption = 'actWPSwitchMonitor'
    end
    object actWPRefresh: TAction
      Category = 'Wallpaper'
      Caption = 'actWPRefresh'
    end
    object actListShow: TAction
      Category = 'List'
      Caption = 'Show'
      OnExecute = actListShowExecute
      OnUpdate = actListShowUpdate
    end
    object actFileExit: TFileExit
      Caption = 'Exit'
      Hint = 'Exit|Quits the application'
      ImageIndex = 43
    end
  end
end

Added src/M_Main.pas.







































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
unit M_Main;

interface

uses
  System.SysUtils, System.Classes, Vcl.Menus, Vcl.ExtCtrls, Vcl.StdActns,
  System.Actions, Vcl.ActnList,
  U_WPImages;

type
  TmodMain = class(TDataModule)
    trayIcon: TTrayIcon;
    pumTray: TPopupMenu;
    aclMain: TActionList;
    actListAddFile: TAction;
    actListAddFolder: TAction;
    actWPSwitch: TAction;
    actWPSwitchMonitor: TAction;
    actWPRefresh: TAction;
    actListShow: TAction;
    actFileExit: TFileExit;
    actListShow1: TMenuItem;
    N1: TMenuItem;
    Exit1: TMenuItem;
    procedure DataModuleCreate(Sender: TObject);
    procedure DataModuleDestroy(Sender: TObject);
    procedure actListShowExecute(Sender: TObject);
    procedure actListShowUpdate(Sender: TObject);
    procedure trayIconDblClick(Sender: TObject);
  private
    { Private declarations }
    FDesktop: TWPImage;
    FMonitors: TWPImages;
    procedure SetDesktop(const Value: TWPImage);
  public
    { Public declarations }
    property Desktop: TWPImage    read FDesktop write SetDesktop;
    property Monitors: TWPImages  read FMonitors;
  end;

var
  modMain: TmodMain;

implementation
uses
  Forms,
  F_Main;

{%CLASSGROUP 'Vcl.Controls.TControl'}

{$R *.dfm}

procedure TmodMain.DataModuleCreate(Sender: TObject);
var
  i: Integer;
begin
  FDesktop := TWPImage.Create('C:\MC\MM\Image\Work\Background\composite\Chateau_de_Lassay_2.bmp');
  FMonitors := TWPImages.Create;
  for i := 0 to Screen.MonitorCount - 1 do begin
    FMonitors.Add(nil);
  end;

  trayIcon.Icon.Assign(Application.Icon);
  trayIcon.Visible := True;
end;

procedure TmodMain.DataModuleDestroy(Sender: TObject);
begin
  trayIcon.Visible := False;
end;

procedure TmodMain.SetDesktop(const Value: TWPImage);
begin
  FDesktop := Value;
end;

procedure TmodMain.trayIconDblClick(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to trayIcon.PopupMenu.Items.Count - 1 do begin
    if trayIcon.PopupMenu.Items[i].Default and trayIcon.PopupMenu.Items[i].Enabled then begin
      trayIcon.PopupMenu.Items[i].Action.Execute;
      Break;
    end;
  end;
end {TmodMain.trayIconDblClick};

procedure TmodMain.actListShowExecute(Sender: TObject);
begin
  frmMain.Visible := not frmMain.Visible;
end;

procedure TmodMain.actListShowUpdate(Sender: TObject);
begin
  actListShow.Checked := frmMain.Visible;
end;

end.

Changes to src/U_WPImages.pas.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16





17
18
19

20
21




22
23
24
25
26
27

28
29
30
31







32
33
34
35
36
37
38
39
40
41
42
43
44
45
46


47


48
49
50
51
52
53
54






55
56
57
58
59
60
61
62
63
64
65




66
67
68
















































69
70
71
72
73
74
75
76
77
78
79
80

81
unit U_WPImages;

interface
uses
  System.Generics.Collections,
  Vcl.Graphics;

type
  TWPImageZoom = (Default, ActualSize, FitHorizontal, FitVertical, FitLargest, FitSmallest);

  TWPImage = class
  private
    FPath: string;
    FWidth: Integer;
    FHeight: Integer;
    FZoom: TWPImageZoom;





    function GetRatio: Double;
  public
    constructor Create(const Path: string);


    function LoadGraphic: TGraphic;





    property Path: string       read FPath    write FPath;
    property Zoom: TWPImageZoom read FZoom    write FZoom;
    property Width: Integer     read FWidth   write FWidth;
    property Height: Integer    read FHeight  write FHeight;
    property Ratio: Double      read GetRatio;

  end;

  TWPImages = class(TList<TWPImage>)
  end;








implementation

uses
  System.Classes, System.SysUtils,
  Vcl.AxCtrls,
  ImgSize;

{ TWPImage }

constructor TWPImage.Create(const Path: string);
var
  FS: TFileStream;
  OG: TOleGraphic;
  W, H: Word;


begin


  FS := TFileStream.Create(Path, fmOpenRead or fmShareDenyNone);
  try
    // Try to identify the image type by its signature, and retrieve the image dimensions
    if GetJPGSize(FS, W, H) or GetPNGSize(FS, W, H) or GetGIFSize(FS, W, H) then begin
      Width := W;
      Height := H;
    end else if not GetBMPSize(FS, FWidth, FHeight) then begin






      // All else has failed; see if Windows recognizes it
      OG := TOleGraphic.Create;
      try
        OG.LoadFromStream(FS);
        Width := OG.Width;
        Height := OG.Height;
      finally
        OG.Free;
      end;
    end;
  finally




    FS.Free;
  end;
end {TWPImage.Create};

















































function TWPImage.GetRatio: Double;
begin
  Result := Width / Height;
end {TWPImage.GetRatio};

function TWPImage.LoadGraphic: TGraphic;
begin
  Result := TOleGraphic.Create;
  Result.LoadFromFile(Path);
end {TWPImage.LoadGraphic};


end.





|


|







>
>
>
>
>



>


>
>
>
>






>




>
>
>
>
>
>
>




|

|






<

>
>

>
>







>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>












>

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62

63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
unit U_WPImages;

interface
uses
  System.Generics.Collections,
  Vcl.Graphics, System.Types, System.Classes, FreeBitmap;

type
  TWPImageZoom = (Default, Align, FitHorizontal, FitVertical, FitLargest, FitSmallest);

  TWPImage = class
  private
    FPath: string;
    FWidth: Integer;
    FHeight: Integer;
    FZoom: TWPImageZoom;
    FExtra: TObject;

    FGraphic: TGraphic;
    FFreeBitmap: TFreeWinBitmap;

    function GetRatio: Double;
  public
    constructor Create(const Path: string);
    destructor  Destroy; override;

    function LoadGraphic: TGraphic;
    procedure Draw(const Canvas: TCanvas; const Rect: TRect;
                   Zoom: TWPImageZoom = Default;
                   HorizontalAlignment: TAlignment = taLeftJustify;
                   VerticalAlignment: TVerticalAlignment = taAlignTop);

    property Path: string       read FPath    write FPath;
    property Zoom: TWPImageZoom read FZoom    write FZoom;
    property Width: Integer     read FWidth   write FWidth;
    property Height: Integer    read FHeight  write FHeight;
    property Ratio: Double      read GetRatio;
    property Extra: TObject     read FExtra   write FExtra;
  end;

  TWPImages = class(TList<TWPImage>)
  end;

  TWPImage<TSource> = class(TWPImage)
  private
    FSource: TSource;
  public
    property Source: TSource      read FSource  write FSource;
  end;

implementation

uses
  System.SysUtils,
  Vcl.AxCtrls,
  ImgSize, Winapi.Windows;

{ TWPImage }

constructor TWPImage.Create(const Path: string);
var
  FS: TFileStream;

  W, H: Word;
  FB: TFreeBitmap;
  OG: TOleGraphic;
begin
  FPath := Path;

  FS := TFileStream.Create(Path, fmOpenRead or fmShareDenyNone);
  try
    // Try to identify the image type by its signature, and retrieve the image dimensions
    if GetJPGSize(FS, W, H) or GetPNGSize(FS, W, H) or GetGIFSize(FS, W, H) then begin
      Width := W;
      Height := H;
    end else if not GetBMPSize(FS, FWidth, FHeight) then begin
      FB := TFreeBitmap.Create();
      try
        if FB.LoadU(Path) then begin
          Width := FB.GetWidth;
          Height := FB.GetHeight;
        end else begin
          // All else has failed; see if Windows recognizes it
          OG := TOleGraphic.Create;
          try
            OG.LoadFromStream(FS);
            Width := OG.Width;
            Height := OG.Height;
          finally
            OG.Free;
          end;
        end;
      finally
        FB.Free;
      end;
    end;
  finally
    FS.Free;
  end;
end {TWPImage.Create};

destructor TWPImage.Destroy;
begin
  if Assigned(FGraphic) then
    FGraphic.Free;
  if Assigned(FFreeBitmap) then
    FFreeBitmap.Free;
  inherited;
end;

procedure TWPImage.Draw(const Canvas: TCanvas; const Rect: TRect;
                        Zoom: TWPImageZoom; HorizontalAlignment: TAlignment;
                        VerticalAlignment: TVerticalAlignment);
var
  RectRatio: Double;
  BkColor: TRGBQuad;
begin
  if (Rect.Width = 0) or (Rect.Height = 0) then
    Exit;

  if not Assigned(FFreeBitmap) and not Assigned(FGraphic) then begin
    FFreeBitmap := TFreeWinBitmap.Create();
    if not FFreeBitmap.LoadU(Path) then begin
      FreeAndNil(FFreeBitmap);
      FGraphic := LoadGraphic;
    end;
  end;

  if Zoom = Default then
    Zoom := Self.Zoom;

  RectRatio := Rect.Width / Rect.Height;
  case Zoom of
    FitHorizontal: ;
    FitVertical: ;
    FitLargest: ;
    FitSmallest: ;
    else begin // Align

    end;
  end;

  if Assigned(FFreeBitmap) then begin
    FFreeBitmap.DrawEx(Canvas.Handle, Rect, False, @BkColor);
  end else if Assigned(FGraphic) then begin
    Canvas.StretchDraw(Rect, FGraphic);
  end;
end;

function TWPImage.GetRatio: Double;
begin
  Result := Width / Height;
end {TWPImage.GetRatio};

function TWPImage.LoadGraphic: TGraphic;
begin
  Result := TOleGraphic.Create;
  Result.LoadFromFile(Path);
end {TWPImage.LoadGraphic};


end.

Changes to src/WPCycler.dpr.

1
2
3
4
5
6
7
8
9
10
11
12
13

14
15
16
program WPCycler;

uses
  Vcl.Forms,
  F_Main {frmMain},
  U_WPImages,
  L_FileList;

{$R *.res}

begin
  Application.Initialize;
  Application.MainFormOnTaskbar := True;

  Application.CreateForm(TfrmMain, frmMain);
  Application.Run;
end.





|
<






>



1
2
3
4
5
6

7
8
9
10
11
12
13
14
15
16
program WPCycler;

uses
  Vcl.Forms,
  F_Main {frmMain},
  M_Main {modMain: TDataModule};


{$R *.res}

begin
  Application.Initialize;
  Application.MainFormOnTaskbar := True;
  Application.CreateForm(TmodMain, modMain);
  Application.CreateForm(TfrmMain, frmMain);
  Application.Run;
end.

Changes to src/WPCycler.dproj.

36
37
38
39
40
41
42



43
44
45
46
47
48
49
    </PropertyGroup>
    <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_2)'!=''">
        <Cfg_2>true</Cfg_2>
        <CfgParent>Base</CfgParent>
        <Base>true</Base>
    </PropertyGroup>
    <PropertyGroup Condition="'$(Base)'!=''">



        <VerInfo_Locale>1043</VerInfo_Locale>
        <Icon_MainIcon>$(BDS)\bin\delphi_PROJECTICON.ico</Icon_MainIcon>
        <Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File>
        <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys>
        <DCC_Namespace>System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace)</DCC_Namespace>
        <DCC_DcuOutput>..\out\DCU\$(Platform)\$(Config)</DCC_DcuOutput>
        <DCC_ExeOutput>..\out\$(Platform)\$(Config)</DCC_ExeOutput>







>
>
>







36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
    </PropertyGroup>
    <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_2)'!=''">
        <Cfg_2>true</Cfg_2>
        <CfgParent>Base</CfgParent>
        <Base>true</Base>
    </PropertyGroup>
    <PropertyGroup Condition="'$(Base)'!=''">
        <DCC_SYMBOL_PLATFORM>false</DCC_SYMBOL_PLATFORM>
        <DCC_UnitSearchPath>.;FreeImage;$(DCC_UnitSearchPath)</DCC_UnitSearchPath>
        <DCC_UNIT_PLATFORM>false</DCC_UNIT_PLATFORM>
        <VerInfo_Locale>1043</VerInfo_Locale>
        <Icon_MainIcon>$(BDS)\bin\delphi_PROJECTICON.ico</Icon_MainIcon>
        <Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File>
        <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys>
        <DCC_Namespace>System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace)</DCC_Namespace>
        <DCC_DcuOutput>..\out\DCU\$(Platform)\$(Config)</DCC_DcuOutput>
        <DCC_ExeOutput>..\out\$(Platform)\$(Config)</DCC_ExeOutput>