mirrors/doublecmd
2
0
Fork 0
mirror of https://github.com/doublecmd/doublecmd.git synced 2026-06-21 09:58:13 +00:00
Code Issues Projects Releases Packages Wiki Activity

ADD: Capability to use in toolbar icons from *.exe and *.dll under Windows

Browse source 
ADD: Capability to change icon size in toolbar
This commit is contained in:
Alexander Koblov 2007-11-24 22:50:11 +00:00
commit fe2109aa23
9 changed files with 3440 additions and 3393 deletions
Download patch file Download diff file Expand all files Collapse all files

128
components/KASToolBar/kascomp.lpk
View file

@ -1,64 +1,68 @@
<?xml version="1.0"?>
<CONFIG>
<Package Version="2">
<Name Value="KASComp"/>
<Author Value="Alexander Koblov"/>
<CompilerOptions>
<Version Value="5"/>
<SearchPaths>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<DelphiCompat Value="True"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Linking>
<Debugging>
<GenerateDebugInfo Value="True"/>
</Debugging>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<?xml version="1.0"?>
<CONFIG>
<Package Version="3">
<PathDelim Value="\"/>
<Name Value="KASComp"/>
<Author Value="Alexander Koblov"/>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<SearchPaths>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<DelphiCompat Value="True"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Linking>
<Debugging>
<GenerateDebugInfo Value="True"/>
</Debugging>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Description Value="ToolBar that loading from *.ini file. Format of *.ini file
KASEdit include popup menu with operations such as cut, copy, paste, delete, etc."/>
KASEdit include popup menu with operations such as cut, copy, paste, delete, etc.
"/>
<License Value="GNU GPL 2
"/>
<Version Major="1" Release="2" Build="1"/>
<Files Count="2">
<Item1>
<Filename Value="kasedit.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="KASEdit"/>
</Item1>
<Item2>
<Filename Value="kastoolbar.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="KAStoolBar"/>
</Item2>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="LCL"/>
<MinVersion Major="1" Valid="True"/>
</Item1>
<Item2>
<PackageName Value="FCL"/>
<MinVersion Major="1" Valid="True"/>
</Item2>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)/"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
</PublishOptions>
</Package>
</CONFIG>
"/>
<Version Major="1" Release="3" Build="1"/>
<Files Count="2">
<Item1>
<Filename Value="kasedit.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="KASEdit"/>
</Item1>
<Item2>
<Filename Value="kastoolbar.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="KAStoolBar"/>
</Item2>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="FCL"/>
<MinVersion Major="1" Valid="True"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
<MinVersion Major="1" Valid="True"/>
</Item2>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)\"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<DestinationDirectory Value="$(TestDir)\publishedpackage\"/>
<IgnoreBinaries Value="False"/>
</PublishOptions>
</Package>
</CONFIG>

29
components/KASToolBar/kastoolbar.pas
View file

@ -39,6 +39,7 @@ type
TOnToolButtonClick = procedure (Sender: TObject; NumberOfButton : Integer) of object;
TChangeLineCount = procedure (AddSize : Integer) of object;
TOnLoadButtonGlyph = function (sIconFileName : String; iIconSize : Integer; clBackColor : TColor) : TBitmap of object;
{ TKAStoolBar }
@ -49,10 +50,12 @@ type
FIconList : TStringList;
FPositionX : Integer;
FPositionY : Integer;
FIconSize,
FButtonSize : Integer;
FNeedMore : Boolean;
FOnToolButtonClick : TOnToolButtonClick;
FChangeLineCount : TChangeLineCount;
FOnLoadButtonGlyph : TOnLoadButtonGlyph;
FTotalBevelWidth : Integer;
FCheckToolButton : Boolean;
FFlatButtons: Boolean;
@ -100,9 +103,11 @@ type
{ Published declarations }
property OnToolButtonClick: TOnToolButtonClick read FOnToolButtonClick write FOnToolButtonClick;
property OnChangeLineCount : TChangeLineCount read FChangeLineCount write FChangeLineCount;
property OnLoadButtonGlyph : TOnLoadButtonGlyph read FOnLoadButtonGlyph write FOnLoadButtonGlyph;
property CheckToolButton : Boolean read FCheckToolButton write FCheckToolButton default False;
property FlatButtons : Boolean read FFlatButtons write SetFlatButtons default False;
property IsDiskPanel : Boolean read FDiskPanel write FDiskPanel default False;
property ButtonGlyphSize : Integer read FIconSize write FIconSize;
property ChangePath : String read FChangePath write FChangePath;
property EnvVar : String read FEnvVar write FEnvVar;
@ -146,6 +151,12 @@ begin
else
FTotalBevelWidth := BevelWidth;
// change panel size
FLockResize := True;
Height := FIconSize + (FTotalBevelWidth * 2) + 6;
FLockResize := False;
FButtonSize := Height - FTotalBevelWidth * 2;
// writeln('FButtonSize = ' + IntToStr(FButtonSize));
if Width < Height then
@ -229,6 +240,7 @@ function TKAStoolBar.LoadBtnIcon(IconPath: String): TBitMap;
var
PNG : TPortableNetworkGraphic;
begin
Result := nil;
if IconPath <> '' then
if FileExists(IconPath) then
begin
@ -266,10 +278,11 @@ var
PNG : TPortableNetworkGraphic;
begin
FIconList[Index] := AValue;
if FileExists(AValue) then
TSpeedButton(FButtonsList.Items[Index]).Glyph := LoadBtnIcon(AValue)
with TSpeedButton(FButtonsList.Items[Index]) do
if Assigned(FOnLoadButtonGlyph) then
Glyph := FOnLoadButtonGlyph(AValue, FIconSize, Color)
else
ShowMessage('File "' + AValue + '" not found!' );
Glyph := LoadBtnIcon(AValue);
end;
procedure TKAStoolBar.SetFlatButtons(const AValue: Boolean);
@ -356,6 +369,7 @@ begin
FOldWidth := Width;
FMustResize := False;
FLockResize := False;
FIconSize := 16; // default
end;
destructor TKAStoolBar.Destroy;
@ -460,10 +474,11 @@ begin
ToolButton.Flat := FFlatButtons;
if FileExists(IconPath) then
ToolButton.Glyph := LoadBtnIcon(IconPath);
with ToolButton do
if Assigned(FOnLoadButtonGlyph) then
Glyph := FOnLoadButtonGlyph(IconPath, FIconSize, Color)
else
Glyph := LoadBtnIcon(IconPath);
ToolButton.OnClick:=TNotifyEvent(@ToolButtonClick);

4
doc/fmain.txt
View file

@ -11,4 +11,6 @@
20.10.2007 ADD: Возможность редактирования текущего каталога, по правому щелчку мыши
FIX: AutoSize кнопки вызова меню дисков
UPD: При создания ссылки/символьной ссылки в качестве имени ссылки
подставляется имя исходного файла/каталога
подставляется имя исходного файла/каталога
24.11.2007 ADD: Возможность использовать на панели инструментов значки из *.exe и *.dll
файлов под Windows

5
fconfigtoolbar.lfm
View file

@ -305,7 +305,6 @@ object frmConfigToolBar: TfrmConfigToolBar
Left = 62
Height = 21
Width = 43
Enabled = False
Font.Height = -11
Font.Name = 'MS Sans Serif'
TabOrder = 0
@ -349,12 +348,14 @@ object frmConfigToolBar: TfrmConfigToolBar
TabOrder = 15
object ktbBar: TKAStoolBar
Left = 1
Height = 23
Height = 24
Width = 296
BevelOuter = bvNone
TabOrder = 0
OnToolButtonClick = ktbBarToolButtonClick
OnLoadButtonGlyph = ktbBarLoadButtonGlyph
CheckToolButton = True
ButtonGlyphSize = 16
end
end
object stToolBarFileName: TStaticText

23
fconfigtoolbar.pas
View file

@ -62,6 +62,8 @@ type
procedure FormShow(Sender: TObject);
procedure btnOKClick(Sender: TObject);
procedure btnAddButtonClick(Sender: TObject);
function ktbBarLoadButtonGlyph(sIconFileName: String; iIconSize: Integer;
clBackColor: TColor): TBitmap;
procedure ktbBarToolButtonClick(Sender: TObject; NumberOfButton : Integer);
procedure Save;
procedure btnDeleteButtonClick(Sender: TObject);
@ -113,6 +115,7 @@ end;
procedure TfrmConfigToolBar.FormShow(Sender: TObject);
begin
FillActionLists;
kedtBarSize.Text := IntToStr(gToolBarIconSize);
cbFlatIcons.Checked := gToolBarFlat;
sbIconExample.Flat:= gToolBarFlat;
ktbBar.FlatButtons := gToolBarFlat;
@ -155,8 +158,10 @@ end;
procedure TfrmConfigToolBar.btnOKClick(Sender: TObject);
begin
Save;
gToolBarIconSize := StrToIntDef(kedtBarSize.Text, 16);
gToolBarFlat := cbFlatIcons.Checked;
ktbBar.SaveToFile(gpIniDir + 'default.bar');
frmMain.MainToolBar.ButtonGlyphSize := gToolBarIconSize;
frmMain.MainToolBar.DeleteAllToolButtons;
frmMain.MainToolBar.FlatButtons := gToolBarFlat;
frmMain.MainToolBar.LoadFromFile(gpIniDir + 'default.bar');
@ -171,6 +176,12 @@ begin
//ShowMessage(IntToStr(NewToolButton));
end;
function TfrmConfigToolBar.ktbBarLoadButtonGlyph(sIconFileName: String;
iIconSize: Integer; clBackColor: TColor): TBitmap;
begin
Result := LoadBitmapFromFile(sIconFileName, iIconSize, clBackColor);
end;
(*Select button on panel*)
procedure TfrmConfigToolBar.ktbBarToolButtonClick(Sender: TObject; NumberOfButton : Integer);
begin
@ -206,12 +217,12 @@ procedure TfrmConfigToolBar.btnDeleteButtonClick(Sender: TObject);
begin
if (LastToolButton >= 0) and (ktbBar.ButtonCount > 0) then
begin
ktbBar.RemoveButton(LastToolButton);
cbCommand.Text := '';
kedtIconFileName.Text := '';
kedtToolTip.Text := '';
LastToolButton := -1;
NewToolButton := -1;
ktbBar.RemoveButton(LastToolButton);
cbCommand.Text := '';
kedtIconFileName.Text := '';
kedtToolTip.Text := '';
LastToolButton := -1;
NewToolButton := -1;
end;
end;

27
fmain.lfm
View file

@ -4,11 +4,11 @@ object frmMain: TfrmMain
Top = 278
Width = 540
HorzScrollBar.Page = 539
VertScrollBar.Page = 316
VertScrollBar.Page = 315
VertScrollBar.Range = 79
ActiveControl = pnlNotebooks
Caption = 'Double Commander'
ClientHeight = 317
ClientHeight = 316
ClientWidth = 540
Font.Color = clBlack
Font.Height = 13
@ -79,34 +79,34 @@ object frmMain: TfrmMain
end
end
object pnlNotebooks: TPanel
Height = 241
Height = 240
Top = 49
Width = 540
Align = alClient
ClientHeight = 241
ClientHeight = 240
ClientWidth = 540
FullRepaint = False
TabOrder = 1
TabStop = True
object MainSplitter: TSplitter
Left = 171
Height = 201
Height = 200
Top = 1
Width = 4
ResizeStyle = rsLine
end
object pnlLeft: TPanel
Left = 1
Height = 201
Height = 200
Top = 1
Width = 170
Align = alLeft
BevelOuter = bvNone
ClientHeight = 201
ClientHeight = 200
ClientWidth = 170
TabOrder = 0
object nbLeft: TNotebook
Height = 177
Height = 176
Hint = 'Left'
Top = 24
Width = 170
@ -175,16 +175,16 @@ object frmMain: TfrmMain
end
object pnlRight: TPanel
Left = 175
Height = 201
Height = 200
Top = 1
Width = 364
Align = alClient
BevelOuter = bvNone
ClientHeight = 201
ClientHeight = 200
ClientWidth = 364
TabOrder = 1
object nbRight: TNotebook
Height = 177
Height = 176
Hint = 'Right'
Top = 24
Width = 364
@ -254,7 +254,7 @@ object frmMain: TfrmMain
object pnlCommand: TPanel
Left = 1
Height = 38
Top = 202
Top = 201
Width = 538
Align = alBottom
Anchors = [akLeft, akRight]
@ -297,12 +297,13 @@ object frmMain: TfrmMain
TabOrder = 2
OnMouseDown = MainToolBarMouseDown
OnToolButtonClick = MainToolBarToolButtonClick
OnLoadButtonGlyph = MainToolBarLoadButtonGlyph
FlatButtons = True
EnvVar = '%commander_path%'
end
object pnlKeys: TPanel
Height = 27
Top = 290
Top = 289
Width = 540
Align = alBottom
Anchors = [akLeft, akRight]

5733
fmain.pas
View file

File diff suppressed because it is too large Load diff

4
uglobs.pas
View file

@ -49,6 +49,8 @@ var
gKeyButtons,
gInterfaceFlat : Boolean;
gToolBarIconSize : Integer;
gDirSortFirst:Boolean=True; // want to show dir first in panels
gDirHistoryCount:Integer=30; // how many history we remember
gShowSystemFiles:Boolean=True;
@ -214,6 +216,7 @@ begin
gButtonBar := gIni.ReadBool('Layout', 'ButtonBar', True);
gToolBarFlat := gIni.ReadBool('ButtonBar', 'FlatIcons', True);
gToolBarIconSize := gIni.ReadInteger('ButtonBar', 'ButtonHeight', 16);
gDriveBar1 := gIni.ReadBool('Layout', 'DriveBar1', True);
gDriveBar2 := gIni.ReadBool('Layout', 'DriveBar2', True);
gDriveBarFlat := gIni.ReadBool('Layout', 'DriveBarFlat', True);
@ -328,6 +331,7 @@ begin
gIni.WriteBool('Layout', 'ButtonBar', gButtonBar);
gIni.WriteBool('ButtonBar', 'FlatIcons', gToolBarFlat);
gIni.WriteInteger('ButtonBar', 'ButtonHeight', gToolBarIconSize);
gIni.WriteBool('Layout', 'DriveBar1', gDriveBar1);
gIni.WriteBool('Layout', 'DriveBar2', gDriveBar2);
gIni.WriteBool('Layout', 'DriveBarFlat', gDriveBarFlat);

880
uosforms.pas
View file

@ -1,440 +1,440 @@
{
Double Commander
-------------------------------------------------------------------------
This unit contains platform depended functions.
Copyright (C) 2006-2007 Koblov Alexander (Alexx2000@mail.ru)
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
unit uOSForms;
{$mode delphi}{$H+}
interface
uses
Classes, SysUtils, uTypes, uFileList, Menus, Controls, Graphics, ExtDlgs,
{$IFDEF UNIX}
fFileProperties;
{$ELSE}
FileUtil, Windows, Messages, ShellApi, ShlObj, ActiveX, uShlObjAdditional, JwaShlGuid, JwaDbt;
{$ENDIF}
const
sCmdVerbOpen = 'open';
sCmdVerbRename = 'rename';
sCmdVerbDelete = 'delete';
sCmdVerbPaste = 'paste';
type
TContextMenu = class(TPopupMenu)
procedure ContextMenuSelect(Sender:TObject);
end;
procedure SetMyWndProc(Handle : THandle);
procedure ShowFilePropertiesDialog(FileList:TFileList; const aPath:String);
procedure ShowContextMenu(Handle : THandle; pfri : PFileRecItem; X, Y : Integer);
function ShowOpenIconDialog(Owner: TCustomControl; var sFileName : String) : Boolean;
implementation
uses
fMain, uVFSutil, uOSUtils, uExts, uGlobs;
var
{$IFDEF MSWINDOWS}
OldWProc: WNDPROC;
ICM2: IContextMenu2 = nil;
{$ELSE}
CM : TContextMenu = nil;
{$ENDIF}
{$IFDEF MSWINDOWS}
function MyWndProc(hwnd: HWND; Msg, wParam, lParam: Cardinal): Cardinal; stdcall;
begin
case Msg of
(* For working wuth submenu of contex menu *)
WM_INITMENUPOPUP,
WM_DRAWITEM,
WM_MENUCHAR,
WM_MEASUREITEM:
if Assigned(ICM2) then
begin
ICM2.HandleMenuMsg(Msg, wParam, lParam);
Result := 0;
end
else
Result := CallWindowProc(OldWProc, hwnd, Msg, wParam, lParam);
WM_DEVICECHANGE:
if (wParam = DBT_DEVICEARRIVAL) or (wParam = DBT_DEVICEREMOVECOMPLETE) then
frmMain.UpdateDiskCount;
else
Result := CallWindowProc(OldWProc, hwnd, Msg, wParam, lParam);
end; // case
end;
{$ENDIF}
procedure SetMyWndProc(Handle : THandle);
{$IFDEF MSWINDOWS}
begin
OldWProc := WNDPROC(SetWindowLong(Handle, GWL_WNDPROC, Integer(@MyWndProc)));
end;
{$ELSE}
begin
end;
{$ENDIF}
(* handling user commands from context menu *)
procedure TContextMenu.ContextMenuSelect(Sender:TObject);
var
sCmd:String;
begin
// ShowMessage((Sender as TMenuItem).Hint);
sCmd:=(Sender as TMenuItem).Hint;
with frmMain.ActiveFrame do
begin
if Pos('{!VFS}',sCmd)>0 then
begin
pnlFile.LoadPanelVFS(PFileRecItem((Sender as TMenuItem).Tag));
Exit;
end;
if not pnlFile.ProcessExtCommand(sCmd) then
frmMain.ExecCmd(sCmd);
end;
end;
procedure ShowContextMenu(Handle : THandle; pfri : PFileRecItem; X, Y : Integer);
var
fri : TFileRecItem;
{$IFDEF MSWINDOWS}
desktop: IShellFolder;
mycomputer: IShellFolder;
folder: IShellFolder;
pidl: PItemIDList;
malloc: IMalloc;
chEaten: ULONG;
dwAttributes: ULONG;
contMenu: IContextMenu;
menu: HMENU;
cmd: UINT;
iCmd: Integer;
HR: HResult;
cmici: CMINVOKECOMMANDINFO;
pwPath,
pwFileName : PWideChar;
bHandled : Boolean;
ZVerb: array[0..255] of char;
sVerb : String;
{$ELSE}
mi, miActions : TMenuItem;
i:Integer;
sCmd:String;
sl: TStringList;
{$ENDIF}
begin
fri := pfri^;
if fri.sName = '..' then
begin
fri.sName := ExtractFileName(ExcludeTrailingPathDelimiter(fri.sPath));
fri.sPath := LowDirLevel(fri.sPath);
end;
{$IFDEF MSWINDOWS}
OleCheck( SHGetMalloc(malloc) );
OleCheck( SHGetDesktopFolder(desktop) );
OleCheck( SHGetSpecialFolderLocation(Handle, CSIDL_DRIVES, pidl) );
try
OleCheck( desktop.BindToObject(pidl, nil, IShellFolder, mycomputer) );
finally
malloc.Free(pidl);
end;
dwAttributes := 0;
pwPath := StringToOleStr(fri.sPath);
OleCheck( mycomputer.ParseDisplayName(Handle, nil, pwPath, chEaten, pidl, dwAttributes) );
try
OleCheck( mycomputer.BindToObject(pidl, nil, IShellFolder, folder) );
finally
malloc.Free(pidl);
end;
dwAttributes := 0;
pwFileName := StringToOleStr(fri.sName);
OleCheck( folder.ParseDisplayName(Handle, nil, pwFileName, chEaten, pidl, dwAttributes) );
try
OleCheck( folder.GetUIObjectOf(Handle, 1, pidl, IID_IContextMenu, nil, contMenu) );
finally
malloc.Free(pidl);
end;
menu := CreatePopupMenu;
try
OleCheck( contMenu.QueryContextMenu(menu, 0, 1, $7FFF, CMF_EXPLORE or CMF_CANRENAME) );
AppendMenu(menu,0,0,'Test');
contMenu.QueryInterface(IID_IContextMenu2, ICM2); //To handle submenus.
cmd := UINT(TrackPopupMenu(menu, TPM_LEFTALIGN or TPM_LEFTBUTTON or TPM_RIGHTBUTTON or TPM_RETURNCMD, X, Y, 0, Handle, nil));
finally
DestroyMenu(menu);
ICM2 := nil;
end;
if cmd > 0 then
begin
iCmd := LongInt(Cmd) - 1;
HR := contMenu.GetCommandString(iCmd, GCS_VERBA, nil, ZVerb, SizeOf(ZVerb));
sVerb := StrPas(ZVerb);
bHandled := False;
if SameText(sVerb, sCmdVerbRename) then
begin
frmMain.RenameFile('');
bHandled := True;
end
else if SameText(sVerb, sCmdVerbOpen) then
begin
if FPS_ISDIR(fri.iMode) or (fri.bLinkIsDir) then
begin
if pfri^.sName = '..' then
frmMain.ActiveFrame.pnlFile.cdUpLevel
else
frmMain.ActiveFrame.pnlFile.cdDownLevel(@fri);
bHandled := True;
end;
end;
if not bHandled then
begin
FillChar(cmici, SizeOf(cmici), #0);
with cmici do
begin
cbSize := sizeof(cmici);
hwnd := Handle;
lpVerb := PChar(cmd - 1);
nShow := SW_NORMAL;
end;
OleCheck( contMenu.InvokeCommand(cmici) );
end;
if SameText(sVerb, sCmdVerbDelete) or SameText(sVerb, sCmdVerbPaste) then
frmMain.ActiveFrame.RefreshPanel;
end; // if cmd > 0
end;
{$ELSE}
if not Assigned(CM) then
CM := TContextMenu.Create(nil)
else
CM.Items.Clear;
mi:=TMenuItem.Create(CM);
mi.Caption:='Open...';
mi.Hint := 'open';
CM.Items.Add(mi);
mi:=TMenuItem.Create(CM);
mi.Caption:='-';
CM.Items.Add(mi);
miActions:=TMenuItem.Create(CM);
miActions.Caption:='Actions';
CM.Items.Add(miActions);
{ Actions submenu }
// Read actions from doublecmd.ext
sl:=TStringList.Create;
try
if FPS_ISDIR(fri.iMode) or (fri.bIsLink) then Exit;
if gExts.GetExtCommands(lowercase(ExtractFileExt(fri.sName)),sl) then
begin
//founded any commands
for i:=0 to sl.Count-1 do
begin
sCmd:=sl.Strings[i];
if pos('VIEW=',sCmd)>0 then Continue; // view command is only for viewer
frmMain.ActiveFrame.pnlFile.ReplaceExtCommand(sCmd, @fri);
mi:=TMenuItem.Create(miActions);
mi.Caption:=sCmd;
mi.Hint:=Copy(sCmd, pos('=',sCmd)+1, length(sCmd));
// length is bad, but in Copy is corrected
mi.OnClick:=TContextMenu.ContextMenuSelect; // handler
mi.Tag:=Integer(@fri);
miActions.Add(mi);
end;
end;
// now add delimiter
mi:=TMenuItem.Create(miActions);
mi.Caption:='-';
miActions.Add(mi);
// now add VIEW item
mi:=TMenuItem.Create(miActions);
mi.Caption:='{!VIEWER}' + fri.sPath + fri.sName;
mi.Hint:=mi.Caption;
mi.OnClick:=TContextMenu.ContextMenuSelect; // handler
miActions.Add(mi);
// now add EDITconfigure item
mi:=TMenuItem.Create(miActions);
mi.Caption:='{!EDITOR}' + fri.sPath + fri.sName;
mi.Hint:=mi.Caption;
mi.OnClick:=TContextMenu.ContextMenuSelect; // handler
miActions.Add(mi);
finally
FreeAndNil(sl);
end;
{ /Actions submenu }
mi:=TMenuItem.Create(CM);
mi.Caption:='-';
CM.Items.Add(mi);
mi:=TMenuItem.Create(CM);
mi.Caption:='Cut';
CM.Items.Add(mi);
mi:=TMenuItem.Create(CM);
mi.Caption:='Copy';
CM.Items.Add(mi);
mi:=TMenuItem.Create(CM);
mi.Caption:='Delete';
mi.Hint := 'actDelete';
mi.OnClick:=TContextMenu.ContextMenuSelect;
CM.Items.Add(mi);
mi:=TMenuItem.Create(CM);
mi.Caption:='Rename';
mi.Hint := 'actShiftF6';
mi.OnClick:=TContextMenu.ContextMenuSelect;
CM.Items.Add(mi);
mi:=TMenuItem.Create(CM);
mi.Caption:='-';
CM.Items.Add(mi);
mi:=TMenuItem.Create(CM);
mi.Caption:='Properties';
mi.Hint := 'actFileProperties';
mi.OnClick:=TContextMenu.ContextMenuSelect;
CM.Items.Add(mi);
CM.PopUp(X, Y);
end;
{$ENDIF}
(* Show file properties dialog *)
procedure ShowFilePropertiesDialog(FileList:TFileList; const aPath:String);
{$IFDEF UNIX}
begin
ShowFileProperties(FileList, aPath);
end;
{$ELSE}
var
SExInfo: TSHELLEXECUTEINFO;
Error: LongInt;
iCurrent : Integer;
FName : String;
(* Find first selected file *)
function FindNextSelected:Boolean;
var
i:Integer;
begin
for i:=iCurrent to FileList.Count-1 do
begin
if FileList.GetItem(i)^.bSelected then
begin
iCurrent:=i;
Result:=True;
Exit;
end;
end;
Result:=False;
end;
begin
iCurrent := 0;
if FindNextSelected then
begin
FName := aPath + FileList.GetItem(iCurrent)^.sName;
//DebugLN(FName);
ZeroMemory(Addr(SExInfo),SizeOf(SExInfo));
SExInfo.cbSize := SizeOf(SExInfo);
SExInfo.lpFile := PChar(FName);
SExInfo.lpVerb := 'properties';
SExInfo.fMask := SEE_MASK_INVOKEIDLIST;
ShellExecuteExA(Addr(SExInfo));
end;
end;
{$ENDIF}
function ShowOpenIconDialog(Owner: TCustomControl; var sFileName : String) : Boolean;
var
opdDialog : TOpenPictureDialog;
{$IFDEF MSWINDOWS}
sFilter : String;
iPos,
iIconIndex: Integer;
bAlreadyOpen : Boolean;
{$ENDIF}
begin
opdDialog := nil;
{$IFDEF MSWINDOWS}
sFilter := GraphicFilter(TGraphic)+'|'+ 'Binary with icons(*.exe;*.dll)|*.exe;*.dll'+'|'+
Format('All files (%s)',[GetAllFilesMask]);
bAlreadyOpen := False;
iPos :=Pos(',', sFileName);
if iPos <> 0 then
begin
iIconIndex := StrToIntDef(Copy(sFileName, iPos + 1, Length(sFileName) - iPos), 0);
sFileName := Copy(sFileName, 1, iPos - 1);
end
else
begin
opdDialog := TOpenPictureDialog.Create(Owner);
opdDialog.Filter:= sFilter;;
Result:= opdDialog.Execute;
sFileName := opdDialog.FileName;
bAlreadyOpen := True;
end;
if FileIsExeLib(sFileName) then
begin
Result := SHChangeIconDialog(Owner.Handle, sFileName, iIconIndex);
if Result then
sFileName := sFileName + ',' + IntToStr(iIconIndex);
end
else if not bAlreadyOpen then
{$ENDIF}
begin
opdDialog := TOpenPictureDialog.Create(Owner);
{$IFDEF MSWINDOWS}
opdDialog.Filter:= sFilter;
{$ENDIF}
Result:= opdDialog.Execute;
sFileName := opdDialog.FileName;
{$IFDEF MSWINDOWS}
bAlreadyOpen := True;
{$ENDIF}
end;
if Assigned(opdDialog) then
FreeAndNil(opdDialog);
end;
end.
{
Double Commander
-------------------------------------------------------------------------
This unit contains platform depended functions.
Copyright (C) 2006-2007 Koblov Alexander (Alexx2000@mail.ru)
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
unit uOSForms;
{$mode delphi}{$H+}
interface
uses
Classes, SysUtils, uTypes, uFileList, Menus, Controls, Graphics, ExtDlgs,
{$IFDEF UNIX}
fFileProperties;
{$ELSE}
FileUtil, Windows, Messages, ShellApi, ShlObj, ActiveX, uShlObjAdditional, JwaShlGuid, JwaDbt;
{$ENDIF}
const
sCmdVerbOpen = 'open';
sCmdVerbRename = 'rename';
sCmdVerbDelete = 'delete';
sCmdVerbPaste = 'paste';
type
TContextMenu = class(TPopupMenu)
procedure ContextMenuSelect(Sender:TObject);
end;
procedure SetMyWndProc(Handle : THandle);
procedure ShowFilePropertiesDialog(FileList:TFileList; const aPath:String);
procedure ShowContextMenu(Handle : THandle; pfri : PFileRecItem; X, Y : Integer);
function ShowOpenIconDialog(Owner: TCustomControl; var sFileName : String) : Boolean;
implementation
uses
fMain, uVFSutil, uOSUtils, uExts, uGlobs;
var
{$IFDEF MSWINDOWS}
OldWProc: WNDPROC;
ICM2: IContextMenu2 = nil;
{$ELSE}
CM : TContextMenu = nil;
{$ENDIF}
{$IFDEF MSWINDOWS}
function MyWndProc(hwnd: HWND; Msg, wParam, lParam: Cardinal): Cardinal; stdcall;
begin
case Msg of
(* For working wuth submenu of contex menu *)
WM_INITMENUPOPUP,
WM_DRAWITEM,
WM_MENUCHAR,
WM_MEASUREITEM:
if Assigned(ICM2) then
begin
ICM2.HandleMenuMsg(Msg, wParam, lParam);
Result := 0;
end
else
Result := CallWindowProc(OldWProc, hwnd, Msg, wParam, lParam);
WM_DEVICECHANGE:
if (wParam = DBT_DEVICEARRIVAL) or (wParam = DBT_DEVICEREMOVECOMPLETE) then
frmMain.UpdateDiskCount;
else
Result := CallWindowProc(OldWProc, hwnd, Msg, wParam, lParam);
end; // case
end;
{$ENDIF}
procedure SetMyWndProc(Handle : THandle);
{$IFDEF MSWINDOWS}
begin
OldWProc := WNDPROC(SetWindowLong(Handle, GWL_WNDPROC, Integer(@MyWndProc)));
end;
{$ELSE}
begin
end;
{$ENDIF}
(* handling user commands from context menu *)
procedure TContextMenu.ContextMenuSelect(Sender:TObject);
var
sCmd:String;
begin
// ShowMessage((Sender as TMenuItem).Hint);
sCmd:=(Sender as TMenuItem).Hint;
with frmMain.ActiveFrame do
begin
if Pos('{!VFS}',sCmd)>0 then
begin
pnlFile.LoadPanelVFS(PFileRecItem((Sender as TMenuItem).Tag));
Exit;
end;
if not pnlFile.ProcessExtCommand(sCmd) then
frmMain.ExecCmd(sCmd);
end;
end;
procedure ShowContextMenu(Handle : THandle; pfri : PFileRecItem; X, Y : Integer);
var
fri : TFileRecItem;
{$IFDEF MSWINDOWS}
desktop: IShellFolder;
mycomputer: IShellFolder;
folder: IShellFolder;
pidl: PItemIDList;
malloc: IMalloc;
chEaten: ULONG;
dwAttributes: ULONG;
contMenu: IContextMenu;
menu: HMENU;
cmd: UINT;
iCmd: Integer;
HR: HResult;
cmici: CMINVOKECOMMANDINFO;
pwPath,
pwFileName : PWideChar;
bHandled : Boolean;
ZVerb: array[0..255] of char;
sVerb : String;
{$ELSE}
mi, miActions : TMenuItem;
i:Integer;
sCmd:String;
sl: TStringList;
{$ENDIF}
begin
fri := pfri^;
if fri.sName = '..' then
begin
fri.sName := ExtractFileName(ExcludeTrailingPathDelimiter(fri.sPath));
fri.sPath := LowDirLevel(fri.sPath);
end;
{$IFDEF MSWINDOWS}
OleCheck( SHGetMalloc(malloc) );
OleCheck( SHGetDesktopFolder(desktop) );
OleCheck( SHGetSpecialFolderLocation(Handle, CSIDL_DRIVES, pidl) );
try
OleCheck( desktop.BindToObject(pidl, nil, IShellFolder, mycomputer) );
finally
malloc.Free(pidl);
end;
dwAttributes := 0;
pwPath := StringToOleStr(fri.sPath);
OleCheck( mycomputer.ParseDisplayName(Handle, nil, pwPath, chEaten, pidl, dwAttributes) );
try
OleCheck( mycomputer.BindToObject(pidl, nil, IShellFolder, folder) );
finally
malloc.Free(pidl);
end;
dwAttributes := 0;
pwFileName := StringToOleStr(fri.sName);
OleCheck( folder.ParseDisplayName(Handle, nil, pwFileName, chEaten, pidl, dwAttributes) );
try
OleCheck( folder.GetUIObjectOf(Handle, 1, pidl, IID_IContextMenu, nil, contMenu) );
finally
malloc.Free(pidl);
end;
menu := CreatePopupMenu;
try
OleCheck( contMenu.QueryContextMenu(menu, 0, 1, $7FFF, CMF_EXPLORE or CMF_CANRENAME) );
AppendMenu(menu,0,0,'Test');
contMenu.QueryInterface(IID_IContextMenu2, ICM2); //To handle submenus.
cmd := UINT(TrackPopupMenu(menu, TPM_LEFTALIGN or TPM_LEFTBUTTON or TPM_RIGHTBUTTON or TPM_RETURNCMD, X, Y, 0, Handle, nil));
finally
DestroyMenu(menu);
ICM2 := nil;
end;
if cmd > 0 then
begin
iCmd := LongInt(Cmd) - 1;
HR := contMenu.GetCommandString(iCmd, GCS_VERBA, nil, ZVerb, SizeOf(ZVerb));
sVerb := StrPas(ZVerb);
bHandled := False;
if SameText(sVerb, sCmdVerbRename) then
begin
frmMain.RenameFile('');
bHandled := True;
end
else if SameText(sVerb, sCmdVerbOpen) then
begin
if FPS_ISDIR(fri.iMode) or (fri.bLinkIsDir) then
begin
if pfri^.sName = '..' then
frmMain.ActiveFrame.pnlFile.cdUpLevel
else
frmMain.ActiveFrame.pnlFile.cdDownLevel(@fri);
bHandled := True;
end;
end;
if not bHandled then
begin
FillChar(cmici, SizeOf(cmici), #0);
with cmici do
begin
cbSize := sizeof(cmici);
hwnd := Handle;
lpVerb := PChar(cmd - 1);
nShow := SW_NORMAL;
end;
OleCheck( contMenu.InvokeCommand(cmici) );
end;
if SameText(sVerb, sCmdVerbDelete) or SameText(sVerb, sCmdVerbPaste) then
frmMain.ActiveFrame.RefreshPanel;
end; // if cmd > 0
end;
{$ELSE}
if not Assigned(CM) then
CM := TContextMenu.Create(nil)
else
CM.Items.Clear;
mi:=TMenuItem.Create(CM);
mi.Caption:='Open...';
mi.Hint := 'open';
CM.Items.Add(mi);
mi:=TMenuItem.Create(CM);
mi.Caption:='-';
CM.Items.Add(mi);
miActions:=TMenuItem.Create(CM);
miActions.Caption:='Actions';
CM.Items.Add(miActions);
{ Actions submenu }
// Read actions from doublecmd.ext
sl:=TStringList.Create;
try
if FPS_ISDIR(fri.iMode) or (fri.bIsLink) then Exit;
if gExts.GetExtCommands(lowercase(ExtractFileExt(fri.sName)),sl) then
begin
//founded any commands
for i:=0 to sl.Count-1 do
begin
sCmd:=sl.Strings[i];
if pos('VIEW=',sCmd)>0 then Continue; // view command is only for viewer
frmMain.ActiveFrame.pnlFile.ReplaceExtCommand(sCmd, @fri);
mi:=TMenuItem.Create(miActions);
mi.Caption:=sCmd;
mi.Hint:=Copy(sCmd, pos('=',sCmd)+1, length(sCmd));
// length is bad, but in Copy is corrected
mi.OnClick:=TContextMenu.ContextMenuSelect; // handler
mi.Tag:=Integer(@fri);
miActions.Add(mi);
end;
end;
// now add delimiter
mi:=TMenuItem.Create(miActions);
mi.Caption:='-';
miActions.Add(mi);
// now add VIEW item
mi:=TMenuItem.Create(miActions);
mi.Caption:='{!VIEWER}' + fri.sPath + fri.sName;
mi.Hint:=mi.Caption;
mi.OnClick:=TContextMenu.ContextMenuSelect; // handler
miActions.Add(mi);
// now add EDITconfigure item
mi:=TMenuItem.Create(miActions);
mi.Caption:='{!EDITOR}' + fri.sPath + fri.sName;
mi.Hint:=mi.Caption;
mi.OnClick:=TContextMenu.ContextMenuSelect; // handler
miActions.Add(mi);
finally
FreeAndNil(sl);
end;
{ /Actions submenu }
mi:=TMenuItem.Create(CM);
mi.Caption:='-';
CM.Items.Add(mi);
mi:=TMenuItem.Create(CM);
mi.Caption:='Cut';
CM.Items.Add(mi);
mi:=TMenuItem.Create(CM);
mi.Caption:='Copy';
CM.Items.Add(mi);
mi:=TMenuItem.Create(CM);
mi.Caption:='Delete';
mi.Hint := 'actDelete';
mi.OnClick:=TContextMenu.ContextMenuSelect;
CM.Items.Add(mi);
mi:=TMenuItem.Create(CM);
mi.Caption:='Rename';
mi.Hint := 'actShiftF6';
mi.OnClick:=TContextMenu.ContextMenuSelect;
CM.Items.Add(mi);
mi:=TMenuItem.Create(CM);
mi.Caption:='-';
CM.Items.Add(mi);
mi:=TMenuItem.Create(CM);
mi.Caption:='Properties';
mi.Hint := 'actFileProperties';
mi.OnClick:=TContextMenu.ContextMenuSelect;
CM.Items.Add(mi);
CM.PopUp(X, Y);
end;
{$ENDIF}
(* Show file properties dialog *)
procedure ShowFilePropertiesDialog(FileList:TFileList; const aPath:String);
{$IFDEF UNIX}
begin
ShowFileProperties(FileList, aPath);
end;
{$ELSE}
var
SExInfo: TSHELLEXECUTEINFO;
Error: LongInt;
iCurrent : Integer;
FName : String;
(* Find first selected file *)
function FindNextSelected:Boolean;
var
i:Integer;
begin
for i:=iCurrent to FileList.Count-1 do
begin
if FileList.GetItem(i)^.bSelected then
begin
iCurrent:=i;
Result:=True;
Exit;
end;
end;
Result:=False;
end;
begin
iCurrent := 0;
if FindNextSelected then
begin
FName := aPath + FileList.GetItem(iCurrent)^.sName;
//DebugLN(FName);
ZeroMemory(Addr(SExInfo),SizeOf(SExInfo));
SExInfo.cbSize := SizeOf(SExInfo);
SExInfo.lpFile := PChar(FName);
SExInfo.lpVerb := 'properties';
SExInfo.fMask := SEE_MASK_INVOKEIDLIST;
ShellExecuteExA(Addr(SExInfo));
end;
end;
{$ENDIF}
function ShowOpenIconDialog(Owner: TCustomControl; var sFileName : String) : Boolean;
var
opdDialog : TOpenPictureDialog;
{$IFDEF MSWINDOWS}
sFilter : String;
iPos,
iIconIndex: Integer;
bAlreadyOpen : Boolean;
{$ENDIF}
begin
opdDialog := nil;
{$IFDEF MSWINDOWS}
sFilter := GraphicFilter(TGraphic)+'|'+ 'Programs and Libraries(*.exe;*.dll)|*.exe;*.dll'+'|'+
Format('All files (%s)',[GetAllFilesMask]);
bAlreadyOpen := False;
iPos :=Pos(',', sFileName);
if iPos <> 0 then
begin
iIconIndex := StrToIntDef(Copy(sFileName, iPos + 1, Length(sFileName) - iPos), 0);
sFileName := Copy(sFileName, 1, iPos - 1);
end
else
begin
opdDialog := TOpenPictureDialog.Create(Owner);
opdDialog.Filter:= sFilter;;
Result:= opdDialog.Execute;
sFileName := opdDialog.FileName;
bAlreadyOpen := True;
end;
if FileIsExeLib(sFileName) then
begin
Result := SHChangeIconDialog(Owner.Handle, sFileName, iIconIndex);
if Result then
sFileName := sFileName + ',' + IntToStr(iIconIndex);
end
else if not bAlreadyOpen then
{$ENDIF}
begin
opdDialog := TOpenPictureDialog.Create(Owner);
{$IFDEF MSWINDOWS}
opdDialog.Filter:= sFilter;
{$ENDIF}
Result:= opdDialog.Execute;
sFileName := opdDialog.FileName;
{$IFDEF MSWINDOWS}
bAlreadyOpen := True;
{$ENDIF}
end;
if Assigned(opdDialog) then
FreeAndNil(opdDialog);
end;
end.