You've already forked lazarus-ccr
7b27af735d
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6864 8e941d3f-bd1b-0410-a28a-d453659cc2b4
164 lines
4.2 KiB
ObjectPascal
164 lines
4.2 KiB
ObjectPascal
{******************************************************************
|
|
|
|
JEDI-VCL Demo
|
|
|
|
Copyright (C) 2002 Project JEDI
|
|
|
|
Original author:
|
|
|
|
Contributor(s):
|
|
|
|
You may retrieve the latest version of this file at the JEDI-JVCL
|
|
home page, located at http://jvcl.delphi-jedi.org
|
|
|
|
The contents of this file are used with permission, subject to
|
|
the Mozilla Public License Version 1.1 (the "License"); you may
|
|
not use this file except in compliance with the License. You may
|
|
obtain a copy of the License at
|
|
http://www.mozilla.org/MPL/MPL-1_1Final.html
|
|
|
|
Software distributed under the License is distributed on an
|
|
"AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
|
|
implied. See the License for the specific language governing
|
|
rights and limitations under the License.
|
|
|
|
******************************************************************}
|
|
|
|
unit DropFrm;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
LCLIntf, LCLType, //LMessages, Types,
|
|
SysUtils, Classes, Graphics, Controls, Forms,
|
|
Dialogs, StdCtrls, ComCtrls, ImgList, ShellCtrls;
|
|
|
|
type
|
|
TDropFrmAcceptEvent = procedure(Sender: TObject; Index: integer; const Value: string) of object;
|
|
|
|
{ TfrmDrop }
|
|
|
|
TfrmDrop = class(TForm)
|
|
Label1: TLabel;
|
|
btnCancel: TButton;
|
|
tvFolders: TShellTreeView;
|
|
ilSmallIcons: TImageList;
|
|
btnOK: TButton;
|
|
PathLabel: TLabel;
|
|
procedure tvFoldersDblClick(Sender: TObject);
|
|
procedure tvFoldersGetImageIndex(Sender: TObject; Node: TTreeNode);
|
|
{
|
|
procedure tvFolders_1Expanding(Sender: TObject; Node: TTreeNode;
|
|
var AllowExpansion: Boolean);
|
|
}
|
|
procedure FormClose(Sender: TObject; var TheAction: TCloseAction);
|
|
procedure btnCancelClick(Sender: TObject);
|
|
procedure btnOKClick(Sender: TObject);
|
|
procedure FormShow(Sender: TObject);
|
|
procedure tvFoldersChange(Sender: TObject; Node: TTreeNode);
|
|
procedure tvFoldersGetSelectedIndex(Sender: TObject; Node: TTreeNode);
|
|
private
|
|
FOnAccept: TDropFrmAcceptEvent;
|
|
FIncludeFiles: boolean;
|
|
procedure SetIncludeFiles(AValue: Boolean);
|
|
protected
|
|
procedure CreateParams(var Params: TCreateParams); override;
|
|
// procedure WMActivate(var Message: TLMActivate); message LM_ACTIVATE;
|
|
public
|
|
property IncludeFiles: boolean read FIncludeFiles write SetIncludeFiles;
|
|
property OnAccept: TDropFrmAcceptEvent read FOnAccept write FOnAccept;
|
|
|
|
end;
|
|
|
|
var
|
|
frmDrop: TfrmDrop = nil;
|
|
|
|
|
|
|
|
implementation
|
|
|
|
uses
|
|
JvJCLUtils;
|
|
|
|
{$R *.lfm}
|
|
|
|
|
|
{ TfrmDrop }
|
|
|
|
procedure TfrmDrop.btnCancelClick(Sender: TObject);
|
|
begin
|
|
if not (fsModal in FormState) then
|
|
Close;
|
|
end;
|
|
|
|
procedure TfrmDrop.btnOKClick(Sender: TObject);
|
|
begin
|
|
if not (fsModal in FormState) then
|
|
Close;
|
|
end;
|
|
|
|
procedure TfrmDrop.CreateParams(var Params: TCreateParams);
|
|
begin
|
|
inherited;
|
|
if BorderStyle = bsDialog then
|
|
Params.Style := Params.Style and not WS_BORDER;
|
|
end;
|
|
|
|
procedure TfrmDrop.FormClose(Sender: TObject; var TheAction: TCloseAction);
|
|
begin
|
|
if (ModalResult = mrOK) and Assigned(FOnAccept) then
|
|
FOnAccept(self, -1, (tvFolders.Selected as TShellTreeNode).FullFilename);
|
|
end;
|
|
|
|
procedure TfrmDrop.FormShow(Sender: TObject);
|
|
begin
|
|
if tvFolders.CanFocus then tvFolders.SetFocus;
|
|
end;
|
|
|
|
procedure TfrmDrop.SetIncludeFiles(AValue: Boolean);
|
|
begin
|
|
if AValue then
|
|
tvFolders.ObjectTypes := tvFolders.ObjectTypes + [otNonFolders]
|
|
else
|
|
tvFolders.ObjectTypes := tvFolders.ObjectTypes - [otNonFolders];
|
|
end;
|
|
|
|
procedure TfrmDrop.tvFoldersChange(Sender: TObject; Node: TTreeNode);
|
|
begin
|
|
PathLabel.Caption := MinimizeFileName((Node as TShellTreeNode).FullFileName, Canvas, PathLabel.Width);
|
|
end;
|
|
|
|
procedure TfrmDrop.tvFoldersDblClick(Sender: TObject);
|
|
begin
|
|
if (tvFolders.Selected <> nil) and (not tvFolders.Selected.HasChildren) then
|
|
btnOK.Click;
|
|
end;
|
|
|
|
procedure TfrmDrop.tvFoldersGetImageIndex(Sender: TObject;
|
|
Node: TTreeNode);
|
|
begin
|
|
if not (Node as TShellTreeNode).IsDirectory then
|
|
Node.ImageIndex := -1
|
|
else
|
|
if Node = tvFolders.Selected then
|
|
Node.ImageIndex := 1
|
|
else
|
|
Node.ImageIndex := 0;
|
|
end;
|
|
|
|
procedure TfrmDrop.tvFoldersGetSelectedIndex(Sender: TObject;
|
|
Node: TTreeNode);
|
|
begin
|
|
if not (Node as TShellTreeNode).IsDirectory then
|
|
Node.SelectedIndex := -1
|
|
else
|
|
if Node = tvFolders.Selected then
|
|
Node.SelectedIndex := 1
|
|
else
|
|
Node.SelectedIndex := 0;
|
|
end;
|
|
|
|
end.
|