From 5589d83d68ce018028405770c018a8ca87e20f15 Mon Sep 17 00:00:00 2001 From: wp Date: Sat, 24 Apr 2021 20:26:24 +0000 Subject: [PATCH] LCL/ShellCtrls: Show built-in shell icons for gtk2, gtk3 and qt5 widgetsets. Patch by Salvadorbs, issue #18247. git-svn-id: trunk@65060 - --- .gitattributes | 3 + lcl/interfaces/fpmake.pp | 6 + lcl/interfaces/gtk2/gtk2wsfactory.pas | 9 +- lcl/interfaces/gtk2/gtk2wsshellctrls.pp | 478 ++++++++++++++++++++++++ lcl/interfaces/gtk3/gtk3wsfactory.pas | 12 +- lcl/interfaces/gtk3/gtk3wsshellctrls.pp | 478 ++++++++++++++++++++++++ lcl/interfaces/qt5/qtwsfactory.pas | 11 +- lcl/interfaces/qt5/qtwsshellctrls.pp | 424 +++++++++++++++++++++ lcl/shellctrls.pas | 8 +- 9 files changed, 1416 insertions(+), 13 deletions(-) create mode 100644 lcl/interfaces/gtk2/gtk2wsshellctrls.pp create mode 100644 lcl/interfaces/gtk3/gtk3wsshellctrls.pp create mode 100644 lcl/interfaces/qt5/qtwsshellctrls.pp diff --git a/.gitattributes b/.gitattributes index 9db779789a..fe1910f888 100644 --- a/.gitattributes +++ b/.gitattributes @@ -10160,6 +10160,7 @@ 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 @@ -10213,6 +10214,7 @@ 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 @@ -11054,6 +11056,7 @@ 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 diff --git a/lcl/interfaces/fpmake.pp b/lcl/interfaces/fpmake.pp index 0afb851e2b..8a37aa438e 100644 --- a/lcl/interfaces/fpmake.pp +++ b/lcl/interfaces/fpmake.pp @@ -177,6 +177,7 @@ 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'); @@ -255,6 +256,7 @@ 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'); @@ -317,6 +319,7 @@ 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'); @@ -509,6 +512,7 @@ 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'); @@ -588,6 +592,7 @@ 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'); @@ -649,6 +654,7 @@ 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'); diff --git a/lcl/interfaces/gtk2/gtk2wsfactory.pas b/lcl/interfaces/gtk2/gtk2wsfactory.pas index e061b8e0f6..e1a72d04cb 100644 --- a/lcl/interfaces/gtk2/gtk2wsfactory.pas +++ b/lcl/interfaces/gtk2/gtk2wsfactory.pas @@ -8,7 +8,7 @@ uses // RTL Classes, // LCL - Controls, ComCtrls, Calendar, StdCtrls, Spin, + Controls, ComCtrls, Calendar, StdCtrls, Spin, ShellCtrls, Dialogs, ExtCtrls, ExtDlgs, Buttons, CheckLst, Forms, Grids, Menus, PairSplitter, WSLCLClasses; @@ -124,6 +124,7 @@ uses Gtk2WSStdCtrls, Gtk2WSPairSplitter, Gtk2WSPrivate, + Gtk2WSShellCtrls, UnityWSCtrls; // imglist @@ -624,12 +625,14 @@ end; // ShellCtrls function RegisterCustomShellTreeView: Boolean; alias : 'WSRegisterCustomShellTreeView'; begin - Result := False; + RegisterWSComponent(TCustomShellTreeView, TGTK2WSCustomShellTreeView); + Result := True; end; function RegisterCustomShellListView: Boolean; alias : 'WSRegisterCustomShellListView'; begin - Result := False; + RegisterWSComponent(TCustomShellListView, TGTK2WSCustomShellListView); + Result := True; end; function RegisterLazDeviceAPIs: Boolean; alias : 'WSRegisterLazDeviceAPIs'; diff --git a/lcl/interfaces/gtk2/gtk2wsshellctrls.pp b/lcl/interfaces/gtk2/gtk2wsshellctrls.pp new file mode 100644 index 0000000000..403397ed6e --- /dev/null +++ b/lcl/interfaces/gtk2/gtk2wsshellctrls.pp @@ -0,0 +1,478 @@ +{ + ***************************************************************************** + * 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. \ No newline at end of file diff --git a/lcl/interfaces/gtk3/gtk3wsfactory.pas b/lcl/interfaces/gtk3/gtk3wsfactory.pas index 20367ac893..10447fb0b4 100644 --- a/lcl/interfaces/gtk3/gtk3wsfactory.pas +++ b/lcl/interfaces/gtk3/gtk3wsfactory.pas @@ -20,7 +20,8 @@ unit Gtk3WSFactory; interface uses Classes, Controls, ComCtrls, Calendar, StdCtrls, Dialogs, ExtCtrls, ExtDlgs, - Buttons, Spin, CheckLst, Forms, Menus, ImgList, PairSplitter, WSLCLClasses; + Buttons, Spin, CheckLst, Forms, Menus, ImgList, PairSplitter, WSLCLClasses, + ShellCtrls; // imglist @@ -139,7 +140,8 @@ uses uses Gtk3WSImgList, Gtk3WSControls, Gtk3WSForms, Gtk3WSButtons, Gtk3WSStdCtrls, Gtk3WSComCtrls, Gtk3WSExtCtrls, Gtk3WSSpin, Gtk3WSMenus, Gtk3WSCalendar, - Gtk3WSDialogs, Gtk3WSCheckLst, Gtk3WSExtDlgs, gtk3wssplitter, Gtk3WSTrayIcon; + Gtk3WSDialogs, Gtk3WSCheckLst, Gtk3WSExtDlgs, gtk3wssplitter, Gtk3WSTrayIcon, + Gtk3WSShellCtrls; // imglist function RegisterCustomImageListResolution: Boolean; alias : 'WSRegisterCustomImageListResolution'; @@ -625,12 +627,14 @@ end; // ShellCtrls function RegisterCustomShellTreeView: Boolean; alias : 'WSRegisterCustomShellTreeView'; begin - Result := False; + RegisterWSComponent(TCustomShellTreeView, TGTK3WSCustomShellTreeView); + Result := True; end; function RegisterCustomShellListView: Boolean; alias : 'WSRegisterCustomShellListView'; begin - Result := False; + RegisterWSComponent(TCustomShellListView, TGTK3WSCustomShellListView); + Result := True; end; function RegisterLazDeviceAPIs: Boolean; alias : 'WSRegisterLazDeviceAPIs'; diff --git a/lcl/interfaces/gtk3/gtk3wsshellctrls.pp b/lcl/interfaces/gtk3/gtk3wsshellctrls.pp new file mode 100644 index 0000000000..9e9a08ede9 --- /dev/null +++ b/lcl/interfaces/gtk3/gtk3wsshellctrls.pp @@ -0,0 +1,478 @@ +{ + ***************************************************************************** + * 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. \ No newline at end of file diff --git a/lcl/interfaces/qt5/qtwsfactory.pas b/lcl/interfaces/qt5/qtwsfactory.pas index a780aeddc5..f7f0eeef9f 100644 --- a/lcl/interfaces/qt5/qtwsfactory.pas +++ b/lcl/interfaces/qt5/qtwsfactory.pas @@ -4,7 +4,7 @@ unit QtWSFactory; interface uses - Classes, Controls, ComCtrls, Calendar, StdCtrls, Spin, Grids, + Classes, Controls, ComCtrls, Calendar, StdCtrls, Spin, Grids, ShellCtrls, Dialogs, ExtCtrls, Buttons, CheckLst, Forms, Menus, RubberBand, PairSplitter, WSLCLClasses; @@ -115,7 +115,8 @@ uses QtWSSpin, QtWSStdCtrls, QtWSGrids, - QtWSDesigner; + QtWSDesigner, + QtWSShellCtrls; // imglist function RegisterCustomImageListResolution: Boolean; alias : 'WSRegisterCustomImageListResolution'; @@ -562,12 +563,14 @@ end; // ShellCtrls function RegisterCustomShellTreeView: Boolean; alias : 'WSRegisterCustomShellTreeView'; begin - Result := False; + RegisterWSComponent(TCustomShellTreeView, TQTWSCustomShellTreeView); + Result := True; end; function RegisterCustomShellListView: Boolean; alias : 'WSRegisterCustomShellListView'; begin - Result := False; + RegisterWSComponent(TCustomShellListView, TQTWSCustomShellListView); + Result := True; end; function RegisterLazDeviceAPIs: Boolean; alias : 'WSRegisterLazDeviceAPIs'; diff --git a/lcl/interfaces/qt5/qtwsshellctrls.pp b/lcl/interfaces/qt5/qtwsshellctrls.pp new file mode 100644 index 0000000000..4151808b0f --- /dev/null +++ b/lcl/interfaces/qt5/qtwsshellctrls.pp @@ -0,0 +1,424 @@ +{ + ***************************************************************************** + * 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. \ No newline at end of file diff --git a/lcl/shellctrls.pas b/lcl/shellctrls.pas index fbba4aea3b..505bb5a91a 100644 --- a/lcl/shellctrls.pas +++ b/lcl/shellctrls.pas @@ -245,6 +245,10 @@ 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 } @@ -1539,9 +1543,9 @@ begin // Image index if FUseBuiltInIcons then begin - if (ViewStyle = vsIcon) and (LargeImages = nil) then + if (ViewStyle = vsIcon) then NewItem.ImageIndex := GetBuiltInImageIndex(CurFilePath, true) - else if (ViewStyle <> vsIcon) and (SmallImages = nil) then + else if (ViewStyle <> vsIcon) then NewItem.ImageIndex := GetBuiltinImageIndex(CurFilePath, false); end; if Assigned(FOnFileAdded) then FOnFileAdded(Self,NewItem);