paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-05 08:37:58 +02:00
Code Issues Packages Projects Releases Wiki Activity

LCL: Undo r65060 #5589d83d68 because it breaks qt5/gtk2/gtk3 on Windows. Issue #38831.

Browse Source 
git-svn-id: trunk@65079 -
This commit is contained in:
wp 2021-05-02 09:01:56 +00:00
parent f192422579
commit 6b4be3bcd9
9 changed files with 14 additions and 1417 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -10162,7 +10162,6 @@ lcl/interfaces/gtk2/gtk2wsimglist.pp svneol=native#text/pascal
lcl/interfaces/gtk2/gtk2wsmenus.pp svneol=native#text/pascal
lcl/interfaces/gtk2/gtk2wspairsplitter.pp svneol=native#text/pascal
lcl/interfaces/gtk2/gtk2wsprivate.pp svneol=native#text/pascal
lcl/interfaces/gtk2/gtk2wsshellctrls.pp svneol=native#text/pascal
lcl/interfaces/gtk2/gtk2wsspin.pp svneol=native#text/pascal
lcl/interfaces/gtk2/gtk2wsstdctrls.pp svneol=native#text/pascal
lcl/interfaces/gtk2/interfaces.pas svneol=native#text/pascal
@ -10216,7 +10215,6 @@ lcl/interfaces/gtk3/gtk3wsfactory.pas svneol=native#text/plain
lcl/interfaces/gtk3/gtk3wsforms.pp svneol=native#text/plain
lcl/interfaces/gtk3/gtk3wsimglist.pp svneol=native#text/plain
lcl/interfaces/gtk3/gtk3wsmenus.pp svneol=native#text/plain
lcl/interfaces/gtk3/gtk3wsshellctrls.pp svneol=native#text/plain
lcl/interfaces/gtk3/gtk3wsspin.pp svneol=native#text/plain
lcl/interfaces/gtk3/gtk3wssplitter.pas svneol=native#text/pascal
lcl/interfaces/gtk3/gtk3wsstdctrls.pp svneol=native#text/plain
@ -11058,7 +11056,6 @@ lcl/interfaces/qt5/qtwsgrids.pp svneol=native#text/plain
lcl/interfaces/qt5/qtwsimglist.pp svneol=native#text/plain
lcl/interfaces/qt5/qtwsmenus.pp svneol=native#text/plain
lcl/interfaces/qt5/qtwspairsplitter.pp svneol=native#text/plain
lcl/interfaces/qt5/qtwsshellctrls.pp svneol=native#text/pascal
lcl/interfaces/qt5/qtwsspin.pp svneol=native#text/plain
lcl/interfaces/qt5/qtwsstdctrls.pp svneol=native#text/plain
lcl/interfaces/qt5/qtx11.inc svneol=native#text/plain

8
lcl/interfaces/fpmake.pp
View File

@ -177,7 +177,6 @@ begin
t.Dependencies.AddUnit('gtk2wsmenus');
t.Dependencies.AddUnit('gtk2wspairsplitter');
t.Dependencies.AddUnit('gtk2wsprivate');
t.Dependencies.AddUnit('gtk2wsshellctrls');
t.Dependencies.AddUnit('gtk2wsspin');
t.Dependencies.AddUnit('gtk2wsstdctrls');
t.Dependencies.AddUnit('unitywsctrls');
@ -204,7 +203,7 @@ begin
t.Dependencies.AddUnit('win32wsimglist');
t.Dependencies.AddUnit('win32wsmenus');
t.Dependencies.AddUnit('win32wspairsplitter');
t.Dependencies.AddUnit('win32wsshellctlrs');
t.Dependencies.AddUnit('win32wsshellctrls');
t.Dependencies.AddUnit('win32wsspin');
t.Dependencies.AddUnit('win32wsstdctrls');
t.Dependencies.AddUnit('win32wstoolwin');
@ -256,7 +255,6 @@ begin
t.Dependencies.AddUnit('qtwsimglist');
t.Dependencies.AddUnit('qtwsmenus');
t.Dependencies.AddUnit('qtwspairsplitter');
t.Dependencies.AddUnit('qtwsshellctrls');
t.Dependencies.AddUnit('qtwsspin');
t.Dependencies.AddUnit('qtwsstdctrls');
t.Dependencies.AddUnit('cocoawsbuttons');
@ -319,7 +317,6 @@ begin
t.Dependencies.AddUnit('gtk3wsimglist');
t.Dependencies.AddUnit('gtk3wsmenus');
t.Dependencies.AddUnit('gtk3wsspin');
t.Dependencies.AddUnit('gtk3wsshellctrls');
t.Dependencies.AddUnit('gtk3wsstdctrls');
t.Dependencies.AddUnit('gtk3wscalendar');
t.Dependencies.AddUnit('lazatk1');
@ -512,7 +509,6 @@ begin
P.Targets.AddImplicitUnit('gtk2/gtk2wsmenus.pp');
P.Targets.AddImplicitUnit('gtk2/gtk2wspairsplitter.pp');
P.Targets.AddImplicitUnit('gtk2/gtk2wsprivate.pp');
P.Targets.AddImplicitUnit('gtk2/gtk2wsshellctrls.pp');
P.Targets.AddImplicitUnit('gtk2/gtk2wsspin.pp');
P.Targets.AddImplicitUnit('gtk2/gtk2wsstdctrls.pp');
P.Targets.AddImplicitUnit('gtk2/unitywsctrls.pas');
@ -592,7 +588,6 @@ begin
P.Targets.AddImplicitUnit('qt/qtwsmenus.pp');
P.Targets.AddImplicitUnit('qt/qtwspairsplitter.pp');
P.Targets.AddImplicitUnit('qt/qtwsspin.pp');
P.Targets.AddImplicitUnit('qt/qtwsshellctrls.pp');
P.Targets.AddImplicitUnit('qt/qtwsstdctrls.pp');
P.Targets.AddImplicitUnit('cocoa/cocoawsbuttons.pas');
P.Targets.AddImplicitUnit('customdrawn/customdrawn_winproc.pas');
@ -654,7 +649,6 @@ begin
P.Targets.AddImplicitUnit('gtk3/gtk3wsimglist.pp');
P.Targets.AddImplicitUnit('gtk3/gtk3wsmenus.pp');
P.Targets.AddImplicitUnit('gtk3/gtk3wsspin.pp');
P.Targets.AddImplicitUnit('gtk3/gtk3wsshellctrls.pp');
P.Targets.AddImplicitUnit('gtk3/gtk3wsstdctrls.pp');
P.Targets.AddImplicitUnit('gtk3/gtk3wscalendar.pp');
P.Targets.AddImplicitUnit('gtk3/gtk3bindings/lazatk1.pas');

9
lcl/interfaces/gtk2/gtk2wsfactory.pas
View File

@ -8,7 +8,7 @@ uses
// RTL
Classes,
// LCL
Controls, ComCtrls, Calendar, StdCtrls, Spin, ShellCtrls,
Controls, ComCtrls, Calendar, StdCtrls, Spin,
Dialogs, ExtCtrls, ExtDlgs, Buttons, CheckLst, Forms, Grids, Menus,
PairSplitter, WSLCLClasses;
@ -124,7 +124,6 @@ uses
Gtk2WSStdCtrls,
Gtk2WSPairSplitter,
Gtk2WSPrivate,
Gtk2WSShellCtrls,
UnityWSCtrls;
// imglist
@ -625,14 +624,12 @@ end;
// ShellCtrls
function RegisterCustomShellTreeView: Boolean; alias : 'WSRegisterCustomShellTreeView';
begin
RegisterWSComponent(TCustomShellTreeView, TGTK2WSCustomShellTreeView);
Result := True;
Result := False;
end;
function RegisterCustomShellListView: Boolean; alias : 'WSRegisterCustomShellListView';
begin
RegisterWSComponent(TCustomShellListView, TGTK2WSCustomShellListView);
Result := True;
Result := False;
end;
function RegisterLazDeviceAPIs: Boolean; alias : 'WSRegisterLazDeviceAPIs';

478
lcl/interfaces/gtk2/gtk2wsshellctrls.pp
View File

@ -1,478 +0,0 @@
{
*****************************************************************************
* WSShellCtrls.pp *
* ------------- *
* *
* *
*****************************************************************************
*****************************************************************************
This file is part of the Lazarus Component Library (LCL)
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the license.
*****************************************************************************
}
unit gtk2wsshellctrls;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes, ComCtrls, ShellCtrls, Types,
////////////////////////////////////////////////////
// To get as little as posible circles,
// uncomment only when needed for registration
////////////////////////////////////////////////////
// Graphics, ImgList, Controls, ShellCtrls,
////////////////////////////////////////////////////
WSShellCtrls;
type
{ TGTK2WSCustomShellTreeView }
TGTK2WSCustomShellTreeView = class(TWSCustomShellTreeView)
published
class function DrawBuiltInIcon(ATreeView: TCustomShellTreeView;
ANode: TTreeNode; ARect: TRect): Types.TSize; override;
class function GetBuiltinIconSize: Types.TSize; override;
end;
{ TGTK2WSCustomShellListView }
TGTK2WSCustomShellListView = class(TWSCustomShellListView)
published
class function GetBuiltInImageIndex(AListView: TCustomShellListView;
const AFileName: String; ALargeImage: Boolean): Integer; override;
end;
implementation
uses
gtk2, gdk2pixbuf, glib2, gdk2, GraphType, IntfGraphics,
graphics, Contnrs, LCLType, SyncObjs, BaseUnix, StrUtils,
LazFileUtils, Controls, StringHashList, IniFiles;
var
FExtToMimeIconName: TFPDataHashTable = nil;
FLock: TCriticalSection = nil;
FImageList: TImageList = nil;
FCacheIcon: TStringHashList = nil;
const
ICON_SIZE_SMALL = 16;
ICON_SIZE_LARGE = 32;
procedure LoadMimeIconNames;
const
mime_globs = '/usr/share/mime/globs';
mime_generic_icons = '/usr/share/mime/generic-icons';
var
I, J: Integer;
globs: TStringList = nil;
generic_icons: THashedStringList = nil;
sMimeType,
sMimeIconName,
sExtension: String;
node: THTDataNode = nil;
iconsList: TStringList;
begin
if not Assigned(FLock) then
FLock := TCriticalSection.Create;
if not Assigned(FExtToMimeIconName) then
FExtToMimeIconName := TFPDataHashTable.Create;
FLock.Acquire;
try
if FExtToMimeIconName.Count = 0 then
begin
if FpAccess(mime_globs, R_OK) = 0 then
begin
// Load mapping: MIME type -> file extension.
globs:= TStringList.Create;
globs.NameValueSeparator:= ':';
globs.LoadFromFile(mime_globs);
// Try to load mapping: MIME type -> generic MIME icon name.
if FileExists(mime_generic_icons) then
begin
generic_icons:= THashedStringList.Create;
generic_icons.NameValueSeparator:= ':';
generic_icons.LoadFromFile(mime_generic_icons);
end;
// Create mapping: file extension -> list of MIME icon names.
for I:= 0 to globs.Count - 1 do
if (globs.Strings[I] <> EmptyStr) and // bypass empty lines
(globs.Strings[I][1] <> '#') then // and comments
begin
sMimeType := globs.Names[I];
sMimeIconName:= StringReplace(sMimeType, '/', '-', []);
sExtension:= globs.ValueFromIndex[I];
// Support only extensions, not full file name masks.
if (sExtension <> EmptyStr) and (sExtension <> '.*') then
begin
node := THTDataNode(FExtToMimeIconName.Find(sExtension));
if not Assigned(node) then
begin
iconsList := TStringList.Create;
FExtToMimeIconName.Add(sExtension, iconsList);
end
else
iconsList := TStringList(node.Data);
if iconsList.IndexOf(sMimeIconName) < 0 then
iconsList.Add(sMimeIconName);
// Shared-mime-info spec says:
// "If [generic-icon] is not specified then the mimetype is used to generate the
// generic icon by using the top-level media type (e.g. "video" in "video/ogg")
// and appending "-x-generic" (i.e. "video-x-generic" in the previous example)."
if Assigned(generic_icons) then
begin
J := generic_icons.IndexOfName(sMimeType);
if J <> -1 then
sMimeIconName := generic_icons.ValueFromIndex[J] // found generic icon
else
sMimeIconName := Copy2Symb(sMimeIconName, '-') + '-x-generic';
end
else
sMimeIconName := Copy2Symb(sMimeIconName, '-') + '-x-generic';
if iconsList.IndexOf(sMimeIconName) < 0 then
iconsList.Add(sMimeIconName);
end;
end;
end;
end;
finally
if Assigned(globs) then
FreeAndNil(globs);
if Assigned(generic_icons) then
FreeAndNil(generic_icons);
FLock.Release;
end;
end;
function IsDirectory(AFilename: String): Boolean;
var
Info: BaseUnix.Stat;
begin
Result := False;
if fpStat(AFilename, Info) >= 0 then
Result := fpS_ISDIR(Info.st_mode);
end;
function CheckIconName(const AIconName: String): Boolean;
begin
Result := ((AIconName <> EmptyStr) and (gtk_icon_theme_has_icon(gtk_icon_theme_get_default, PChar(AIconName)) or
FileExists(AIconName)));
end;
function PixBufToBitmap(Pixbuf: PGdkPixbuf): TBitmap;
var
width, height, rowstride, n_channels, i, j: Integer;
pixels: Pguchar;
pSrc: PByte;
pDst: PLongWord;
BmpData: TLazIntfImage;
hasAlphaChannel: Boolean;
QueryFlags: TRawImageQueryFlags = [riqfRGB];
Description: TRawImageDescription;
ARawImage: TRawImage;
begin
Result := nil;
n_channels:= gdk_pixbuf_get_n_channels(Pixbuf);
if ((n_channels <> 3) and (n_channels <> 4)) or // RGB or RGBA
(gdk_pixbuf_get_colorspace(pixbuf) <> GDK_COLORSPACE_RGB) or
(gdk_pixbuf_get_bits_per_sample(pixbuf) <> 8) then Exit;
width:= gdk_pixbuf_get_width(Pixbuf);
height:= gdk_pixbuf_get_height(Pixbuf);
rowstride:= gdk_pixbuf_get_rowstride(Pixbuf);
pixels:= gdk_pixbuf_get_pixels(Pixbuf);
hasAlphaChannel:= gdk_pixbuf_get_has_alpha(Pixbuf);
if hasAlphaChannel then
Include(QueryFlags, riqfAlpha);
BmpData := TLazIntfImage.Create(width, height, QueryFlags);
try
BmpData.CreateData;
Description := BmpData.DataDescription;
pDst := PLongWord(BmpData.PixelData);
for j:= 0 to Height - 1 do
begin
pSrc := PByte(pixels) + j * rowstride;
for i:= 0 to Width - 1 do
begin
pDst^ := pSrc[0] shl Description.RedShift +
pSrc[1] shl Description.GreenShift +
pSrc[2] shl Description.BlueShift;
if hasAlphaChannel then
pDst^ := pDst^ + pSrc[3] shl Description.AlphaShift;
Inc(pSrc, n_channels);
Inc(pDst);
end;
end;
Result := TBitmap.Create;
BmpData.GetRawImage(ARawImage, True);
// Simply change raw image owner without data copy
Result.LoadFromRawImage(ARawImage, True);
if not hasAlphaChannel then
Result.Transparent := True;
finally
BmpData.Free;
end;
end;
function ExtractIcon(const sIconName: String; ALargeImage: Boolean): TBitmap;
var
pbPicture: PGdkPixbuf = nil;
Size: Integer;
begin
Result := nil;
if ALargeImage then
Size := ICON_SIZE_LARGE
else
Size := ICON_SIZE_SMALL;
try
if CheckIconName(sIconName) then
begin
if FileExists(sIconName) then
pbPicture := gdk_pixbuf_new_from_file_at_size(PChar(sIconName), Size, Size, nil)
else
pbPicture := gtk_icon_theme_load_icon(gtk_icon_theme_get_for_screen(gdk_screen_get_default), Pgchar(sIconName), Size, GTK_ICON_LOOKUP_USE_BUILTIN, nil);
end;
if Assigned(pbPicture) then
Result := PixBufToBitmap(pbPicture)
else
Result := TBitmap.Create;
finally
g_object_unref(pbPicture);
end;
end;
function GetIconByDesktopFile(AFileName: String): String;
var
iniDesktop: TIniFile = nil;
begin
Result := EmptyStr;
try
iniDesktop := TIniFile.Create(AFileName);
try
Result := iniDesktop.ReadString('Desktop Entry', 'Icon', EmptyStr);
finally
FreeAndNil(iniDesktop);
end;
except
Exit;
end;
end;
function GetIconName(const AFileName: String): String;
var
I: Integer;
node: THTDataNode;
iconList: TStringList;
Extension: String;
begin
LoadMimeIconNames;
Result := EmptyStr;
//It is a link? Ok, get target file icon
if FpReadLink(AFilename) <> EmptyStr then
Extension := '*' + ExtractFileExt(FpReadLink(AFileName))
else
Extension := '*' + ExtractFileExt(AFileName);
Extension := LowerCase(Extension);
//TODO: Special folders icon https://gitlab.gnome.org/GNOME/glib/-/commit/129eb074823101102611690f053ffa246bb7784d#3549e1301fc4c17bf0dd809eca0a36fb87aac264_1582_1582
if IsDirectory(AFileName) then
begin
if FileExists(AFileName + PathDelim + '.directory') then
Result := GetIconByDesktopFile(AFileName + PathDelim + '.directory')
else
Result := 'folder';
end
else if (Extension = '*.desktop') then
begin
Result := GetIconByDesktopFile(AFileName);
end
else if FileIsExecutable(AFileName) then
begin
Result := 'application-x-executable';
end
else if (Extension = '*.ico') then
begin
Result := AFileName;
end
else if (Extension <> '*') then
begin
node := THTDataNode(FExtToMimeIconName.Find(Extension));
if Assigned(node) then
begin
iconList := TStringList(node.Data);
//First valid icon wins
for I := 0 to iconList.Count - 1 do
begin
Result := iconList.Strings[I];
if gtk_icon_theme_has_icon(gtk_icon_theme_get_default, PChar(Result)) then
break;
end;
end;
end;
//Not found icon? No problem. Use generic icon
if (not CheckIconName(Result)) or (Result = EmptyStr) then
begin
if FileIsText(AFileName) then
Result := 'text-x-generic'
else
Result := 'unknown';
end;
end;
procedure CreateLVImageList;
begin
if Assigned(FImageList) then
Exit;
FImageList := TImageList.Create(nil);
FImageList.RegisterResolutions([ICON_SIZE_SMALL, ICON_SIZE_LARGE]);
end;
{ TGTK2WSCustomShellTreeView }
class function TGTK2WSCustomShellTreeView.DrawBuiltInIcon(ATreeView: TCustomShellTreeView;
ANode: TTreeNode; ARect: TRect): Types.TSize;
var
filename: String;
bmp: TBitmap;
iconName: String;
begin
fileName := ATreeView.GetPathFromNode(ANode);
iconName := GetIconName(fileName);
bmp := ExtractIcon(iconName, False);
try
ATreeView.Canvas.Draw(ARect.Left, (ARect.Top + ARect.Bottom - bmp.Height) div 2, bmp);
Result := Types.Size(bmp.Width, bmp.Height);
finally
bmp.Free;
end;
end;
class function TGTK2WSCustomShellTreeView.GetBuiltinIconSize: Types.TSize;
begin
Result := Types.Size(ICON_SIZE_SMALL, ICON_SIZE_SMALL);
end;
{ TGTK2WSCustomShellListView }
class function TGTK2WSCustomShellListView.GetBuiltInImageIndex(
AListView: TCustomShellListView; const AFileName: String;
ALargeImage: Boolean): Integer;
var
bmpSmall, bmpLarge: TBitmap;
iconName: String;
FCacheImageIndex: Integer;
begin
Result := -1;
CreateLVImageList;
if ALargeImage then
begin
AListView.SmallImages := nil;
AListView.SmallImagesWidth := 0;
AListView.LargeImages := FImageList;
AListView.LargeImagesWidth := ICON_SIZE_LARGE;
end
else begin
AListView.SmallImages := FImageList;
AListView.SmallImagesWidth := ICON_SIZE_SMALL;
AListView.LargeImages := nil;
AListView.LargeImagesWidth := 0;
end;
if FCacheIcon = nil then
FCacheIcon := TStringHashList.Create(True);
iconName := GetIconName(AFileName);
FCacheImageIndex := FCacheIcon.Find(iconName);
if FCacheImageIndex < 0 then
begin
bmpSmall := ExtractIcon(iconName, False);
bmpLarge := ExtractIcon(iconName, True);
try
Result := FImageList.AddMultipleResolutions([bmpSmall, bmpLarge]);
FCacheIcon.Add(iconName, Pointer(Result));
finally
bmpSmall.Free;
bmpLarge.Free;
end;
end
else begin
Result := PtrInt(FCacheIcon.List[FCacheImageIndex]^.Data);
end;
end;
procedure ClearExtToMimeList;
var
nodeList: TFPObjectList;
I, J : Integer;
begin
for I := 0 to FExtToMimeIconName.HashTable.Count - 1 do
begin
begin
nodeList := TFPObjectList(FExtToMimeIconName.HashTable.Items[I]);
if Assigned(nodeList) then
for J := 0 to nodeList.Count - 1 do
TStringList(THtDataNode(nodeList.Items[J]).Data).Free;
end;
end;
end;
finalization
if Assigned(FExtToMimeIconName) then
begin
ClearExtToMimeList;
FExtToMimeIconName.Free;
end;
if Assigned(FLock) then
FLock.Free;
if Assigned(FImageList) then
FImageList.Free;
if Assigned(FCacheIcon) then
FCacheIcon.Free;
end.

12
lcl/interfaces/gtk3/gtk3wsfactory.pas
View File

@ -20,8 +20,7 @@ unit Gtk3WSFactory;
interface
uses
Classes, Controls, ComCtrls, Calendar, StdCtrls, Dialogs, ExtCtrls, ExtDlgs,
Buttons, Spin, CheckLst, Forms, Menus, ImgList, PairSplitter, WSLCLClasses,
ShellCtrls;
Buttons, Spin, CheckLst, Forms, Menus, ImgList, PairSplitter, WSLCLClasses;
// imglist
@ -140,8 +139,7 @@ uses
uses
Gtk3WSImgList, Gtk3WSControls, Gtk3WSForms, Gtk3WSButtons, Gtk3WSStdCtrls,
Gtk3WSComCtrls, Gtk3WSExtCtrls, Gtk3WSSpin, Gtk3WSMenus, Gtk3WSCalendar,
Gtk3WSDialogs, Gtk3WSCheckLst, Gtk3WSExtDlgs, gtk3wssplitter, Gtk3WSTrayIcon,
Gtk3WSShellCtrls;
Gtk3WSDialogs, Gtk3WSCheckLst, Gtk3WSExtDlgs, gtk3wssplitter, Gtk3WSTrayIcon;
// imglist
function RegisterCustomImageListResolution: Boolean; alias : 'WSRegisterCustomImageListResolution';
@ -627,14 +625,12 @@ end;
// ShellCtrls
function RegisterCustomShellTreeView: Boolean; alias : 'WSRegisterCustomShellTreeView';
begin
RegisterWSComponent(TCustomShellTreeView, TGTK3WSCustomShellTreeView);
Result := True;
Result := False;
end;
function RegisterCustomShellListView: Boolean; alias : 'WSRegisterCustomShellListView';
begin
RegisterWSComponent(TCustomShellListView, TGTK3WSCustomShellListView);
Result := True;
Result := False;
end;
function RegisterLazDeviceAPIs: Boolean; alias : 'WSRegisterLazDeviceAPIs';

478
lcl/interfaces/gtk3/gtk3wsshellctrls.pp
View File

@ -1,478 +0,0 @@
{
*****************************************************************************
* WSShellCtrls.pp *
* ------------- *
* *
* *
*****************************************************************************
*****************************************************************************
This file is part of the Lazarus Component Library (LCL)
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the license.
*****************************************************************************
}
unit gtk3wsshellctrls;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes, ComCtrls, ShellCtrls, Types,
////////////////////////////////////////////////////
// To get as little as posible circles,
// uncomment only when needed for registration
////////////////////////////////////////////////////
// Graphics, ImgList, Controls, ShellCtrls,
////////////////////////////////////////////////////
WSShellCtrls;
type
{ TGTK3WSCustomShellTreeView }
TGTK3WSCustomShellTreeView = class(TWSCustomShellTreeView)
published
class function DrawBuiltInIcon(ATreeView: TCustomShellTreeView;
ANode: TTreeNode; ARect: TRect): Types.TSize; override;
class function GetBuiltinIconSize: Types.TSize; override;
end;
{ TGTK3WSCustomShellListView }
TGTK3WSCustomShellListView = class(TWSCustomShellListView)
published
class function GetBuiltInImageIndex(AListView: TCustomShellListView;
const AFileName: String; ALargeImage: Boolean): Integer; override;
end;
implementation
uses
lazgtk3, lazgdkpixbuf2, LazGLib2, LazGdk3, LazGObject2,
GraphType, IntfGraphics, graphics, Contnrs, LCLType, SyncObjs, BaseUnix,
StrUtils, LazFileUtils, Controls, StringHashList, IniFiles;
var
FExtToMimeIconName: TFPDataHashTable = nil;
FLock: TCriticalSection = nil;
FImageList: TImageList = nil;
FCacheIcon: TStringHashList = nil;
const
ICON_SIZE_SMALL = 16;
ICON_SIZE_LARGE = 32;
procedure LoadMimeIconNames;
const
mime_globs = '/usr/share/mime/globs';
mime_generic_icons = '/usr/share/mime/generic-icons';
var
I, J: Integer;
globs: TStringList = nil;
generic_icons: THashedStringList = nil;
sMimeType,
sMimeIconName,
sExtension: String;
node: THTDataNode = nil;
iconsList: TStringList;
begin
if not Assigned(FLock) then
FLock := TCriticalSection.Create;
if not Assigned(FExtToMimeIconName) then
FExtToMimeIconName := TFPDataHashTable.Create;
FLock.Acquire;
try
if FExtToMimeIconName.Count = 0 then
begin
if FpAccess(mime_globs, R_OK) = 0 then
begin
// Load mapping: MIME type -> file extension.
globs:= TStringList.Create;
globs.NameValueSeparator:= ':';
globs.LoadFromFile(mime_globs);
// Try to load mapping: MIME type -> generic MIME icon name.
if FileExists(mime_generic_icons) then
begin
generic_icons:= THashedStringList.Create;
generic_icons.NameValueSeparator:= ':';
generic_icons.LoadFromFile(mime_generic_icons);
end;
// Create mapping: file extension -> list of MIME icon names.
for I:= 0 to globs.Count - 1 do
if (globs.Strings[I] <> EmptyStr) and // bypass empty lines
(globs.Strings[I][1] <> '#') then // and comments
begin
sMimeType := globs.Names[I];
sMimeIconName:= StringReplace(sMimeType, '/', '-', []);
sExtension:= globs.ValueFromIndex[I];
// Support only extensions, not full file name masks.
if (sExtension <> EmptyStr) and (sExtension <> '.*') then
begin
node := THTDataNode(FExtToMimeIconName.Find(sExtension));
if not Assigned(node) then
begin
iconsList := TStringList.Create;
FExtToMimeIconName.Add(sExtension, iconsList);
end
else
iconsList := TStringList(node.Data);
if iconsList.IndexOf(sMimeIconName) < 0 then
iconsList.Add(sMimeIconName);
// Shared-mime-info spec says:
// "If [generic-icon] is not specified then the mimetype is used to generate the
// generic icon by using the top-level media type (e.g. "video" in "video/ogg")
// and appending "-x-generic" (i.e. "video-x-generic" in the previous example)."
if Assigned(generic_icons) then
begin
J := generic_icons.IndexOfName(sMimeType);
if J <> -1 then
sMimeIconName := generic_icons.ValueFromIndex[J] // found generic icon
else
sMimeIconName := Copy2Symb(sMimeIconName, '-') + '-x-generic';
end
else
sMimeIconName := Copy2Symb(sMimeIconName, '-') + '-x-generic';
if iconsList.IndexOf(sMimeIconName) < 0 then
iconsList.Add(sMimeIconName);
end;
end;
end;
end;
finally
if Assigned(globs) then
FreeAndNil(globs);
if Assigned(generic_icons) then
FreeAndNil(generic_icons);
FLock.Release;
end;
end;
function IsDirectory(AFilename: String): Boolean;
var
Info: BaseUnix.Stat;
begin
Result := False;
if fpStat(AFilename, Info) >= 0 then
Result := fpS_ISDIR(Info.st_mode);
end;
function CheckIconName(const AIconName: String): Boolean;
begin
Result := ((AIconName <> EmptyStr) and (gtk_icon_theme_has_icon(gtk_icon_theme_get_default, PChar(AIconName)) or
FileExists(AIconName)));
end;
function PixBufToBitmap(Pixbuf: PGdkPixbuf): TBitmap;
var
width, height, rowstride, n_channels, i, j: Integer;
pixels: ^guchar;
pSrc: PByte;
pDst: PLongWord;
BmpData: TLazIntfImage;
hasAlphaChannel: Boolean;
QueryFlags: TRawImageQueryFlags = [riqfRGB];
Description: TRawImageDescription;
ARawImage: TRawImage;
begin
Result := nil;
n_channels:= gdk_pixbuf_get_n_channels(Pixbuf);
if ((n_channels <> 3) and (n_channels <> 4)) or // RGB or RGBA
(gdk_pixbuf_get_colorspace(pixbuf) <> GDK_COLORSPACE_RGB) or
(gdk_pixbuf_get_bits_per_sample(pixbuf) <> 8) then Exit;
width:= gdk_pixbuf_get_width(Pixbuf);
height:= gdk_pixbuf_get_height(Pixbuf);
rowstride:= gdk_pixbuf_get_rowstride(Pixbuf);
pixels:= gdk_pixbuf_get_pixels(Pixbuf);
hasAlphaChannel:= gdk_pixbuf_get_has_alpha(Pixbuf);
if hasAlphaChannel then
Include(QueryFlags, riqfAlpha);
BmpData := TLazIntfImage.Create(width, height, QueryFlags);
try
BmpData.CreateData;
Description := BmpData.DataDescription;
pDst := PLongWord(BmpData.PixelData);
for j:= 0 to Height - 1 do
begin
pSrc := PByte(pixels) + j * rowstride;
for i:= 0 to Width - 1 do
begin
pDst^ := pSrc[0] shl Description.RedShift +
pSrc[1] shl Description.GreenShift +
pSrc[2] shl Description.BlueShift;
if hasAlphaChannel then
pDst^ := pDst^ + pSrc[3] shl Description.AlphaShift;
Inc(pSrc, n_channels);
Inc(pDst);
end;
end;
Result := TBitmap.Create;
BmpData.GetRawImage(ARawImage, True);
// Simply change raw image owner without data copy
Result.LoadFromRawImage(ARawImage, True);
if not hasAlphaChannel then
Result.Transparent := True;
finally
BmpData.Free;
end;
end;
function ExtractIcon(const sIconName: String; ALargeImage: Boolean): TBitmap;
var
pbPicture: PGdkPixbuf = nil;
Size: Integer;
begin
Result := nil;
if ALargeImage then
Size := ICON_SIZE_LARGE
else
Size := ICON_SIZE_SMALL;
try
if CheckIconName(sIconName) then
begin
if FileExists(sIconName) then
pbPicture := gdk_pixbuf_new_from_file_at_size(PChar(sIconName), Size, Size, nil)
else
pbPicture := gtk_icon_theme_load_icon(gtk_icon_theme_get_for_screen(gdk_screen_get_default), Pgchar(sIconName), Size, GTK_ICON_LOOKUP_USE_BUILTIN, nil);
end;
if Assigned(pbPicture) then
Result := PixBufToBitmap(pbPicture)
else
Result := TBitmap.Create;
finally
g_object_unref(pbPicture);
end;
end;
function GetIconByDesktopFile(AFileName: String): String;
var
iniDesktop: TIniFile = nil;
begin
Result := EmptyStr;
try
iniDesktop := TIniFile.Create(AFileName);
try
Result := iniDesktop.ReadString('Desktop Entry', 'Icon', EmptyStr);
finally
FreeAndNil(iniDesktop);
end;
except
Exit;
end;
end;
function GetIconName(const AFileName: String): String;
var
I: Integer;
node: THTDataNode;
iconList: TStringList;
Extension: String;
begin
LoadMimeIconNames;
Result := EmptyStr;
//It is a link? Ok, get target file icon
if FpReadLink(AFilename) <> EmptyStr then
Extension := '*' + ExtractFileExt(FpReadLink(AFileName))
else
Extension := '*' + ExtractFileExt(AFileName);
Extension := LowerCase(Extension);
//TODO: Special folders icon https://gitlab.gnome.org/GNOME/glib/-/commit/129eb074823101102611690f053ffa246bb7784d#3549e1301fc4c17bf0dd809eca0a36fb87aac264_1582_1582
if IsDirectory(AFileName) then
begin
if FileExists(AFileName + PathDelim + '.directory') then
Result := GetIconByDesktopFile(AFileName + PathDelim + '.directory')
else
Result := 'folder';
end
else if (Extension = '*.desktop') then
begin
Result := GetIconByDesktopFile(AFileName);
end
else if FileIsExecutable(AFileName) then
begin
Result := 'application-x-executable';
end
else if (Extension = '*.ico') then
begin
Result := AFileName;
end
else if (Extension <> '*') then
begin
node := THTDataNode(FExtToMimeIconName.Find(Extension));
if Assigned(node) then
begin
iconList := TStringList(node.Data);
//First valid icon wins
for I := 0 to iconList.Count - 1 do
begin
Result := iconList.Strings[I];
if gtk_icon_theme_has_icon(gtk_icon_theme_get_default, PChar(Result)) then
break;
end;
end;
end;
//Not found icon? No problem. Use generic icon
if (not CheckIconName(Result)) or (Result = EmptyStr) then
begin
if FileIsText(AFileName) then
Result := 'text-x-generic'
else
Result := 'unknown';
end;
end;
procedure CreateLVImageList;
begin
if Assigned(FImageList) then
Exit;
FImageList := TImageList.Create(nil);
FImageList.RegisterResolutions([ICON_SIZE_SMALL, ICON_SIZE_LARGE]);
end;
{ TGTK3WSCustomShellTreeView }
class function TGTK3WSCustomShellTreeView.DrawBuiltInIcon(ATreeView: TCustomShellTreeView;
ANode: TTreeNode; ARect: TRect): Types.TSize;
var
filename: String;
bmp: TBitmap;
iconName: String;
begin
fileName := ATreeView.GetPathFromNode(ANode);
iconName := GetIconName(fileName);
bmp := ExtractIcon(iconName, False);
try
ATreeView.Canvas.Draw(ARect.Left, (ARect.Top + ARect.Bottom - bmp.Height) div 2, bmp);
Result := Types.Size(bmp.Width, bmp.Height);
finally
bmp.Free;
end;
end;
class function TGTK3WSCustomShellTreeView.GetBuiltinIconSize: Types.TSize;
begin
Result := Types.Size(ICON_SIZE_SMALL, ICON_SIZE_SMALL);
end;
{ TGTK3WSCustomShellListView }
class function TGTK3WSCustomShellListView.GetBuiltInImageIndex(
AListView: TCustomShellListView; const AFileName: String;
ALargeImage: Boolean): Integer;
var
bmpSmall, bmpLarge: TBitmap;
iconName: String;
FCacheImageIndex: Integer;
begin
Result := -1;
CreateLVImageList;
if ALargeImage then
begin
AListView.SmallImages := nil;
AListView.SmallImagesWidth := 0;
AListView.LargeImages := FImageList;
AListView.LargeImagesWidth := ICON_SIZE_LARGE;
end
else begin
AListView.SmallImages := FImageList;
AListView.SmallImagesWidth := ICON_SIZE_SMALL;
AListView.LargeImages := nil;
AListView.LargeImagesWidth := 0;
end;
if FCacheIcon = nil then
FCacheIcon := TStringHashList.Create(True);
iconName := GetIconName(AFileName);
FCacheImageIndex := FCacheIcon.Find(iconName);
if FCacheImageIndex < 0 then
begin
bmpSmall := ExtractIcon(iconName, False);
bmpLarge := ExtractIcon(iconName, True);
try
Result := FImageList.AddMultipleResolutions([bmpSmall, bmpLarge]);
FCacheIcon.Add(iconName, Pointer(Result));
finally
bmpSmall.Free;
bmpLarge.Free;
end;
end
else begin
Result := PtrInt(FCacheIcon.List[FCacheImageIndex]^.Data);
end;
end;
procedure ClearExtToMimeList;
var
nodeList: TFPObjectList;
I, J : Integer;
begin
for I := 0 to FExtToMimeIconName.HashTable.Count - 1 do
begin
begin
nodeList := TFPObjectList(FExtToMimeIconName.HashTable.Items[I]);
if Assigned(nodeList) then
for J := 0 to nodeList.Count - 1 do
TStringList(THtDataNode(nodeList.Items[J]).Data).Free;
end;
end;
end;
finalization
if Assigned(FExtToMimeIconName) then
begin
ClearExtToMimeList;
FExtToMimeIconName.Free;
end;
if Assigned(FLock) then
FLock.Free;
if Assigned(FImageList) then
FImageList.Free;
if Assigned(FCacheIcon) then
FCacheIcon.Free;
end.

11
lcl/interfaces/qt5/qtwsfactory.pas
View File

@ -4,7 +4,7 @@ unit QtWSFactory;
interface
uses
Classes, Controls, ComCtrls, Calendar, StdCtrls, Spin, Grids, ShellCtrls,
Classes, Controls, ComCtrls, Calendar, StdCtrls, Spin, Grids,
Dialogs, ExtCtrls, Buttons, CheckLst, Forms, Menus, RubberBand, PairSplitter,
WSLCLClasses;
@ -115,8 +115,7 @@ uses
QtWSSpin,
QtWSStdCtrls,
QtWSGrids,
QtWSDesigner,
QtWSShellCtrls;
QtWSDesigner;
// imglist
function RegisterCustomImageListResolution: Boolean; alias : 'WSRegisterCustomImageListResolution';
@ -563,14 +562,12 @@ end;
// ShellCtrls
function RegisterCustomShellTreeView: Boolean; alias : 'WSRegisterCustomShellTreeView';
begin
RegisterWSComponent(TCustomShellTreeView, TQTWSCustomShellTreeView);
Result := True;
Result := False;
end;
function RegisterCustomShellListView: Boolean; alias : 'WSRegisterCustomShellListView';
begin
RegisterWSComponent(TCustomShellListView, TQTWSCustomShellListView);
Result := True;
Result := False;
end;
function RegisterLazDeviceAPIs: Boolean; alias : 'WSRegisterLazDeviceAPIs';

424
lcl/interfaces/qt5/qtwsshellctrls.pp
View File

@ -1,424 +0,0 @@
{
*****************************************************************************
* WSShellCtrls.pp *
* ------------- *
* *
* *
*****************************************************************************
*****************************************************************************
This file is part of the Lazarus Component Library (LCL)
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the license.
*****************************************************************************
}
unit qtwsshellctrls;
{$mode objfpc}{$H+}
{$I qtdefines.inc}
interface
uses
SysUtils, Classes, ComCtrls, ShellCtrls, Types,
////////////////////////////////////////////////////
// To get as little as posible circles,
// uncomment only when needed for registration
////////////////////////////////////////////////////
// Graphics, ImgList, Controls, ShellCtrls,
////////////////////////////////////////////////////
WSShellCtrls;
type
{ TQTWSCustomShellTreeView }
TQTWSCustomShellTreeView = class(TWSCustomShellTreeView)
published
class function DrawBuiltInIcon(ATreeView: TCustomShellTreeView;
ANode: TTreeNode; ARect: TRect): Types.TSize; override;
class function GetBuiltinIconSize: Types.TSize; override;
end;
{ TQTWSCustomShellListView }
TQTWSCustomShellListView = class(TWSCustomShellListView)
published
class function GetBuiltInImageIndex(AListView: TCustomShellListView;
const AFileName: String; ALargeImage: Boolean): Integer; override;
end;
implementation
uses
graphics, qt5, qtobjects, Contnrs, LCLType, SyncObjs, BaseUnix, StrUtils,
LazFileUtils, Controls, StringHashList, IniFiles;
var
FExtToMimeIconName: TFPDataHashTable = nil;
FLock: TCriticalSection = nil;
FImageList: TImageList = nil;
FCacheIcon: TStringHashList = nil;
const
ICON_SIZE_SMALL = 16;
ICON_SIZE_LARGE = 32;
procedure LoadMimeIconNames;
const
mime_globs = '/usr/share/mime/globs';
mime_generic_icons = '/usr/share/mime/generic-icons';
var
I, J: Integer;
globs: TStringList = nil;
generic_icons: THashedStringList = nil;
sMimeType,
sMimeIconName,
sExtension: String;
node: THTDataNode = nil;
iconsList: TStringList;
EntriesCount: Cardinal;
begin
if not Assigned(FLock) then
FLock := TCriticalSection.Create;
if not Assigned(FExtToMimeIconName) then
FExtToMimeIconName := TFPDataHashTable.Create;
FLock.Acquire;
try
if FExtToMimeIconName.Count = 0 then
begin
if FpAccess(mime_globs, R_OK) = 0 then
begin
// Load mapping: MIME type -> file extension.
globs:= TStringList.Create;
globs.NameValueSeparator:= ':';
globs.LoadFromFile(mime_globs);
// Try to load mapping: MIME type -> generic MIME icon name.
if FileExists(mime_generic_icons) then
begin
generic_icons:= THashedStringList.Create;
generic_icons.NameValueSeparator:= ':';
generic_icons.LoadFromFile(mime_generic_icons);
end;
EntriesCount := 0;
// Create mapping: file extension -> list of MIME icon names.
for I:= 0 to globs.Count - 1 do
if (globs.Strings[I] <> EmptyStr) and // bypass empty lines
(globs.Strings[I][1] <> '#') then // and comments
begin
sMimeType := globs.Names[I];
sMimeIconName:= StringReplace(sMimeType, '/', '-', []);
sExtension:= globs.ValueFromIndex[I];
// Support only extensions, not full file name masks.
if (sExtension <> EmptyStr) and (sExtension <> '.*') then
begin
node := THTDataNode(FExtToMimeIconName.Find(sExtension));
if not Assigned(node) then
begin
iconsList := TStringList.Create;
FExtToMimeIconName.Add(sExtension, iconsList);
Inc(EntriesCount);
end
else
iconsList := TStringList(node.Data);
if iconsList.IndexOf(sMimeIconName) < 0 then
iconsList.Add(sMimeIconName);
// Shared-mime-info spec says:
// "If [generic-icon] is not specified then the mimetype is used to generate the
// generic icon by using the top-level media type (e.g. "video" in "video/ogg")
// and appending "-x-generic" (i.e. "video-x-generic" in the previous example)."
if Assigned(generic_icons) then
begin
J := generic_icons.IndexOfName(sMimeType);
if J <> -1 then
sMimeIconName := generic_icons.ValueFromIndex[J] // found generic icon
else
sMimeIconName := Copy2Symb(sMimeIconName, '-') + '-x-generic';
end
else
sMimeIconName := Copy2Symb(sMimeIconName, '-') + '-x-generic';
if iconsList.IndexOf(sMimeIconName) < 0 then
iconsList.Add(sMimeIconName);
end;
end;
end;
end;
finally
if Assigned(globs) then
FreeAndNil(globs);
if Assigned(generic_icons) then
FreeAndNil(generic_icons);
FLock.Release;
end;
end;
function IsDirectory(AFilename: String): Boolean;
var
Info: BaseUnix.Stat;
begin
Result := False;
if fpStat(AFilename, Info) >= 0 then
Result := fpS_ISDIR(Info.st_mode);
end;
function CheckIconName(const AIconName: Widestring): Boolean;
begin
//QIcon_fromTheme can load icon name and absolute filepath, too
Result := ((AIconName <> EmptyStr) and (QIcon_hasThemeIcon(@AIconName) or FileExists(AIconName)));
end;
function QIconToHBitmap(AIcon: QIconH; ASize: Types.TSize): HBITMAP;
var
AImage: QImageH;
APixmap: QPixmapH;
begin
APixmap := QPixmap_create();
QIcon_pixmap(AIcon, APixmap, Types.PSize(@ASize));
AImage := QImage_create();
QPixmap_toImage(APixmap, AImage);
QPixmap_destroy(APixmap);
Result := HBitmap(TQtImage.Create(AImage));
end;
function ExtractIcon(const sIconName: WideString; ALargeImage: Boolean): TBitmap;
var
QIcon: QIconH;
Size: Types.TSize;
begin
Result := TBitmap.Create;
if ALargeImage then
Size := Types.Size(ICON_SIZE_LARGE, ICON_SIZE_LARGE)
else
Size := Types.Size(ICON_SIZE_SMALL, ICON_SIZE_SMALL);
QIcon := QIcon_Create();
try
if CheckIconName(sIconName) then
begin
QIcon_fromTheme(QIcon, @sIconName);
Result.Handle := QIconToHBitmap(QIcon, Size);
end;
finally
QIcon_destroy(QIcon);
end;
end;
function GetIconByDesktopFile(AFileName: String): String;
var
iniDesktop: TIniFile = nil;
begin
Result := EmptyStr;
try
iniDesktop := TIniFile.Create(AFileName);
try
Result := iniDesktop.ReadString('Desktop Entry', 'Icon', EmptyStr);
finally
FreeAndNil(iniDesktop);
end;
except
Exit;
end;
end;
function GetIconName(const AFileName: WideString): WideString;
var
I: Integer;
node: THTDataNode;
iconList: TStringList;
Extension: String;
begin
LoadMimeIconNames;
Result := EmptyStr;
//It is a link? Ok, get target file icon
if FpReadLink(AFilename) <> EmptyStr then
Extension := '*' + ExtractFileExt(FpReadLink(AFileName))
else
Extension := '*' + ExtractFileExt(AFileName);
Extension := LowerCase(Extension);
//TODO: Special folders icon https://gitlab.gnome.org/GNOME/glib/-/commit/129eb074823101102611690f053ffa246bb7784d#3549e1301fc4c17bf0dd809eca0a36fb87aac264_1582_1582
if IsDirectory(AFileName) then
begin
if FileExists(AFileName + PathDelim + '.directory') then
Result := GetIconByDesktopFile(AFileName + PathDelim + '.directory')
else
Result := 'folder';
end
else if (Extension = '*.desktop') then
begin
Result := GetIconByDesktopFile(AFileName);
end
else if FileIsExecutable(AFileName) then
begin
Result := 'application-x-executable';
end
else if (Extension = '*.ico') then
begin
Result := AFileName;
end
else if (Extension <> '*') then
begin
node := THTDataNode(FExtToMimeIconName.Find(Extension));
if Assigned(node) then
begin
iconList := TStringList(node.Data);
//First valid icon wins
for I := 0 to iconList.Count - 1 do
begin
Result := iconList.Strings[I];
if QIcon_hasThemeIcon(@Result) then
break;
end;
end;
end;
//Not found icon? No problem. Use generic icon
if (not CheckIconName(Result)) or (Result = EmptyStr) then
begin
if FileIsText(AFileName) then
Result := 'text-x-generic'
else
Result := 'unknown';
end;
end;
procedure CreateLVImageList;
begin
if Assigned(FImageList) then
Exit;
FImageList := TImageList.Create(nil);
FImageList.RegisterResolutions([ICON_SIZE_SMALL, ICON_SIZE_LARGE]);
end;
{ TQTWSCustomShellTreeView }
class function TQTWSCustomShellTreeView.DrawBuiltInIcon(ATreeView: TCustomShellTreeView;
ANode: TTreeNode; ARect: TRect): Types.TSize;
var
filename: WideString;
bmp: TBitmap;
iconName: String;
begin
fileName := ATreeView.GetPathFromNode(ANode);
iconName := GetIconName(fileName);
bmp := ExtractIcon(iconName, False);
try
ATreeView.Canvas.Draw(ARect.Left, (ARect.Top + ARect.Bottom - bmp.Height) div 2, bmp);
Result := Types.Size(bmp.Width, bmp.Height);
finally
bmp.Free;
end;
end;
class function TQTWSCustomShellTreeView.GetBuiltinIconSize: Types.TSize;
begin
Result := Types.Size(ICON_SIZE_SMALL, ICON_SIZE_SMALL);
end;
{ TQTWSCustomShellListView }
class function TQTWSCustomShellListView.GetBuiltInImageIndex(
AListView: TCustomShellListView; const AFileName: String;
ALargeImage: Boolean): Integer;
var
bmpSmall, bmpLarge: TBitmap;
iconName: String;
FCacheImageIndex: Integer;
begin
Result := -1;
CreateLVImageList;
if ALargeImage then
begin
AListView.SmallImages := nil;
AListView.SmallImagesWidth := 0;
AListView.LargeImages := FImageList;
AListView.LargeImagesWidth := ICON_SIZE_LARGE;
end
else begin
AListView.SmallImages := FImageList;
AListView.SmallImagesWidth := ICON_SIZE_SMALL;
AListView.LargeImages := nil;
AListView.LargeImagesWidth := 0;
end;
if FCacheIcon = nil then
FCacheIcon := TStringHashList.Create(True);
iconName := GetIconName(AFileName);
FCacheImageIndex := FCacheIcon.Find(iconName);
if FCacheImageIndex < 0 then
begin
bmpSmall := ExtractIcon(iconName, False);
bmpLarge := ExtractIcon(iconName, True);
try
Result := FImageList.AddMultipleResolutions([bmpSmall, bmpLarge]);
FCacheIcon.Add(iconName, Pointer(Result));
finally
bmpSmall.Free;
bmpLarge.Free;
end;
end
else begin
Result := PtrInt(FCacheIcon.List[FCacheImageIndex]^.Data);
end;
end;
procedure ClearExtToMimeList;
var
nodeList: TFPObjectList;
I, J : Integer;
begin
for I := 0 to FExtToMimeIconName.HashTable.Count - 1 do
begin
begin
nodeList := TFPObjectList(FExtToMimeIconName.HashTable.Items[I]);
if Assigned(nodeList) then
for J := 0 to nodeList.Count - 1 do
TStringList(THtDataNode(nodeList.Items[J]).Data).Free;
end;
end;
end;
finalization
if Assigned(FExtToMimeIconName) then
begin
ClearExtToMimeList;
FExtToMimeIconName.Free;
end;
if Assigned(FLock) then
FLock.Free;
if Assigned(FImageList) then
FImageList.Free;
if Assigned(FCacheIcon) then
FCacheIcon.Free;
end.

8
lcl/shellctrls.pas
View File

@ -245,10 +245,6 @@ type
property OnAddItem: TAddItemEvent read FOnAddItem write FOnAddItem;
{ Protected properties which users may want to access, see bug 15374 }
property Items;
property SmallImages;
property SmallImagesWidth;
property LargeImages;
property LargeImagesWidth;
end;
{ TShellListView }
@ -1543,9 +1539,9 @@ begin
// Image index
if FUseBuiltInIcons then
begin
if (ViewStyle = vsIcon) then
if (ViewStyle = vsIcon) and (LargeImages = nil) then
NewItem.ImageIndex := GetBuiltInImageIndex(CurFilePath, true)
else if (ViewStyle <> vsIcon) then
else if (ViewStyle <> vsIcon) and (SmallImages = nil) then
NewItem.ImageIndex := GetBuiltinImageIndex(CurFilePath, false);
end;
if Assigned(FOnFileAdded) then FOnFileAdded(Self,NewItem);