examples: new imagelist examples (multiresolution / high-dpi)

git-svn-id: trunk@57226 -
This commit is contained in:
ondrej 2018-02-03 12:07:40 +00:00
parent 5ed36d2fae
commit 1f765a3316
9 changed files with 1964 additions and 0 deletions

8
.gitattributes vendored
View File

@ -6385,6 +6385,14 @@ examples/imagelist/project1.lpr svneol=native#text/plain
examples/imagelist/project1.res -text
examples/imagelist/unit1.lfm svneol=native#text/plain
examples/imagelist/unit1.pas svneol=native#text/pascal
examples/imagelist_highdpi_designtime/imglistdesign.lpi svneol=native#text/xml
examples/imagelist_highdpi_designtime/imglistdesign.lpr svneol=native#text/pascal
examples/imagelist_highdpi_designtime/unit1.lfm svneol=native#text/lfm
examples/imagelist_highdpi_designtime/unit1.pas svneol=native#text/pascal
examples/imagelist_highdpi_runtime/dpiimagelist.lpi svneol=native#text/xml
examples/imagelist_highdpi_runtime/dpiimagelist.lpr svneol=native#text/pascal
examples/imagelist_highdpi_runtime/unit1.lfm svneol=native#text/lfm
examples/imagelist_highdpi_runtime/unit1.pas svneol=native#text/pascal
examples/imgviewer/file.bmp -text svneol=native#image/bmp
examples/imgviewer/file.xpm -text svneol=native#image/x-xpixmap
examples/imgviewer/frmmain.lfm svneol=native#text/plain

View File

@ -0,0 +1,128 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="ImgListDesign"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
</General>
<BuildModes Count="2">
<Item1 Name="Debug" Default="True"/>
<Item2 Name="Release">
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="ImgListDesign"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<CodeGeneration>
<SmartLinkUnit Value="True"/>
<Optimizations>
<OptimizationLevel Value="3"/>
</Optimizations>
</CodeGeneration>
<Linking>
<Debugging>
<GenerateDebugInfo Value="False"/>
</Debugging>
<LinkSmart Value="True"/>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
</Item2>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0"/>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="LCL"/>
</Item1>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="ImgListDesign.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="unit1.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="Unit1"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="ImgListDesign"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<IncludeAssertionCode Value="True"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<Checks>
<IOChecks Value="True"/>
<RangeChecks Value="True"/>
<OverflowChecks Value="True"/>
<StackChecks Value="True"/>
</Checks>
<VerifyObjMethodCallValidity Value="True"/>
</CodeGeneration>
<Linking>
<Debugging>
<DebugInfoType Value="dsDwarf2Set"/>
<UseHeaptrc Value="True"/>
<TrashVariables Value="True"/>
<UseExternalDbgSyms Value="True"/>
</Debugging>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

View File

@ -0,0 +1,25 @@
program ImgListDesign;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, Unit1
{ you can add units after this };
{$R *.res}
begin
{$IF DECLARED(GlobalSkipIfNoLeaks)}
GlobalSkipIfNoLeaks := True;
{$ENDIF}
RequireDerivedFormResource := True;
Application.Scaled := True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

File diff suppressed because it is too large Load Diff

View File

@ -0,0 +1,56 @@
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ComCtrls, ImgList,
Menus;
type
{ TForm1 }
TForm1 = class(TForm)
ImageList1: TImageList;
ListView1: TListView;
MainMenu1: TMainMenu;
MenuItem1: TMenuItem;
MenuItem2: TMenuItem;
MenuItem3: TMenuItem;
MenuItem4: TMenuItem;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
ToolBar1: TToolBar;
ToolButton1: TToolButton;
ToolButton2: TToolButton;
TreeView1: TTreeView;
procedure ImageList1GetWidthForPPI(Sender: TCustomImageList; AImageWidth,
APPI: Integer; var AResultWidth: Integer);
private
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.ImageList1GetWidthForPPI(Sender: TCustomImageList;
AImageWidth, APPI: Integer; var AResultWidth: Integer);
begin
case AResultWidth of
20..24: AResultWidth:=22;
30..36: AResultWidth:=32;
end;
end;
end.

View File

@ -0,0 +1,129 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="DPIImageList"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True/PM"/>
</XPManifest>
</General>
<BuildModes Count="2">
<Item1 Name="Debug" Default="True"/>
<Item2 Name="Release">
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="DPIImageList"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<CodeGeneration>
<SmartLinkUnit Value="True"/>
<Optimizations>
<OptimizationLevel Value="3"/>
</Optimizations>
</CodeGeneration>
<Linking>
<Debugging>
<GenerateDebugInfo Value="False"/>
</Debugging>
<LinkSmart Value="True"/>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
</Item2>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0"/>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="LCL"/>
</Item1>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="dpiimagelist.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="DPIImageList"/>
</Unit0>
<Unit1>
<Filename Value="unit1.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="Unit1"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="DPIImageList"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<IncludeAssertionCode Value="True"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<Checks>
<IOChecks Value="True"/>
<RangeChecks Value="True"/>
<OverflowChecks Value="True"/>
<StackChecks Value="True"/>
</Checks>
<VerifyObjMethodCallValidity Value="True"/>
</CodeGeneration>
<Linking>
<Debugging>
<DebugInfoType Value="dsDwarf2Set"/>
<UseHeaptrc Value="True"/>
<TrashVariables Value="True"/>
<UseExternalDbgSyms Value="True"/>
</Debugging>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

View File

@ -0,0 +1,26 @@
program DPIImageList;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, Unit1
{ you can add units after this };
{$R *.res}
begin
Application.Title := 'DPIImageList';
Application.Scaled := True;
{$IF DECLARED(GlobalSkipIfNoLeaks)}
GlobalSkipIfNoLeaks := True;
{$ENDIF}
RequireDerivedFormResource := True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

View File

@ -0,0 +1,8 @@
object Form1: TForm1
Left = 509
Height = 240
Top = 186
Width = 320
Caption = 'Form1'
LCLVersion = '1.9.0.0'
end

View File

@ -0,0 +1,227 @@
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ImgList, ComCtrls,
Menus, StdCtrls, LCLIntf;
type
TForm1 = class(TForm)
private
IL: TImageList;
procedure ILOnGetWidthForImagePPI(Sender: TCustomImageList; AImageWidth,
APPI: Integer; var AResultWidth: Integer);
protected
procedure DoCreate; override;
end;
TImageListHelper = class helper for TImageList
public
procedure AddPNGsFromFiles(const aFileNames: array of string);
procedure AddLazarusPNGs(const aBaseFileName: string);
procedure AddIconFromFile(const aFileName: string);
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TImageListHelper }
procedure TImageListHelper.AddPNGsFromFiles(const aFileNames: array of string);
var
xPNG: array of TCustomBitmap;
xFileName: string;
I: Integer;
begin
SetLength(xPNG, Length(aFileNames));
try
for I := 0 to High(aFileNames) do
begin
xFileName := aFileNames[I];
xPNG[I] := TPortableNetworkGraphic.Create;
xPNG[I].LoadFromFile(xFileName);
end;
AddMultipleResolutions(xPNG);
finally
for I := 0 to High(aFileNames) do
xPNG[I].Free;
end;
end;
procedure TImageListHelper.AddIconFromFile(const aFileName: string);
var
xICO: TIcon;
begin
xICO := TIcon.Create;
try
xICO.LoadFromFile(aFileName);
AddIcon(xICO);
finally
xICO.Free;
end;
end;
procedure TImageListHelper.AddLazarusPNGs(const aBaseFileName: string);
var
A: array of string;
const
BaseDir = '..'+PathDelim+'..'+PathDelim+'images'+PathDelim+'menu'+PathDelim;
begin
SetLength(A, 3);
A[0] := BaseDir+aBaseFileName+'.png';
A[1] := BaseDir+aBaseFileName+'_150.png';
A[2] := BaseDir+aBaseFileName+'_200.png';
AddPNGsFromFiles(A);
end;
{ TForm1 }
procedure TForm1.DoCreate;
var
MI, MI2: TMenuItem;
MM: TMainMenu;
TS: TTabSheet;
Lbl: TLabel;
PC: TPageControl;
TB16, TB24: TToolBar;
Btn: TToolButton;
I: Integer;
LV: TListView;
PM: TPopupMenu;
begin
inherited DoCreate;
IL := TImageList.Create(Self);
IL.RegisterResolutions([16, 24, 32]);
IL.AddLazarusPNGs('menu_undo');
IL.AddLazarusPNGs('menu_redo');
IL.AddIconFromFile('..'+PathDelim+'..'+PathDelim+'images'+PathDelim+'mainiconproject.ico');
IL.OnGetWidthForPPI := @ILOnGetWidthForImagePPI;
IL.Scaled := True;
TB16 := TToolBar.Create(Self);
TB16.Parent := Self;
TB16.Images := IL;
TB16.ImagesWidth := 16;
TB16.AutoSize := True;
TB24 := TToolBar.Create(Self);
TB24.Parent := Self;
TB24.Images := IL;
TB24.ImagesWidth := 24;
TB24.ButtonWidth := Scale96ToForm(30);
TB24.ButtonHeight := Scale96ToForm(30);
TB24.Height := TB24.ButtonHeight;
TB24.Caption := '24px image';
for I := 0 to 2 do
begin
Btn := TToolButton.Create(Self);
Btn.Parent := TB16;
Btn.ImageIndex := I;
end;
Lbl := TLabel.Create(Self);
Lbl.Parent := TB16;
Lbl.Caption := '16px image';
for I := 0 to 2 do
begin
Btn := TToolButton.Create(Self);
Btn.Parent := TB24;
Btn.ImageIndex := I;
end;
Lbl := TLabel.Create(Self);
Lbl.Parent := TB24;
Lbl.Caption := '24px image';
PC := TPageControl.Create(Self);
PC.Images := IL;
PC.ImagesWidth := 32;
TS := PC.AddTabSheet;
TS.ImageIndex := 0;
Lbl := TLabel.Create(Self);
Lbl.Caption := 'All controls&&images are served by 1 image list and no DPI-aware runtime code!';
Lbl.WordWrap := True;
Lbl.Parent := TS;
Lbl.BorderSpacing.Around := 6;
Lbl.Align := alClient;
TS := PC.AddTabSheet;
TS.ImageIndex := 1;
PC.Parent := Self;
PC.Align := alClient;
MM := TMainMenu.Create(Self);
MM.Images := IL;
MI := TMenuItem.Create(Self);
MI.Caption := 'main menu';
MI.ImageIndex := 0;
MI.SubMenuImages := IL;
MI.SubMenuImagesWidth := 32;
MM.Items.Add(MI);
MI2 := TMenuItem.Create(Self);
MI2.Caption := 'sub1';
MI2.ImageIndex := 0;
MI.Add(MI2);
MI2 := TMenuItem.Create(Self);
MI2.Caption := 'sub2';
MI2.ImageIndex := 1;
MI.Add(MI2);
PM := TPopupMenu.Create(Self);
PM.Images := IL;
MI2 := TMenuItem.Create(Self);
MI2.Caption := 'sub1';
MI2.ImageIndex := 0;
PM.Items.Add(MI2);
MI2 := TMenuItem.Create(Self);
MI2.Caption := 'sub2';
MI2.ImageIndex := 1;
PM.Items.Add(MI2);
TB16.PopupMenu := PM;
LV := TListView.Create(Self);
LV.Parent := TS;
LV.Align := alClient;
LV.LargeImages := IL;
LV.LargeImagesWidth := 46;
LV.ViewStyle := vsIcon;
with LV.Items.Add do
begin
ImageIndex := 0;
Caption := 'one';
end;
with LV.Items.Add do
begin
ImageIndex := 1;
Caption := 'two';
end;
TS := PC.AddTabSheet;
TS.ImageIndex := 2;
end;
procedure TForm1.ILOnGetWidthForImagePPI(Sender: TCustomImageList; AImageWidth,
APPI: Integer; var AResultWidth: Integer);
begin
if (AImageWidth=24) and (AResultWidth=36) then
AResultWidth := 32;
end;
end.