mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-24 14:09:24 +02:00
546 lines
16 KiB
PHP
546 lines
16 KiB
PHP
{%MainUnit ../dialogs.pp}
|
|
|
|
{******************************************************************************
|
|
TFileDialog
|
|
******************************************************************************
|
|
|
|
*****************************************************************************
|
|
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.
|
|
*****************************************************************************
|
|
}
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ TFileDialog Create }
|
|
{------------------------------------------------------------------------------}
|
|
constructor TFileDialog.Create(TheOwner: TComponent);
|
|
begin
|
|
inherited Create(TheOwner);
|
|
fCompStyle := csFileDialog;
|
|
FFiles := TStringList.Create;
|
|
FHistoryList:=TStringList.Create;
|
|
FFilterIndex := 1;
|
|
FInternalFilterIndex := 1;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ TFileDialog Destroy }
|
|
{------------------------------------------------------------------------------}
|
|
destructor TFileDialog.Destroy;
|
|
begin
|
|
FHistoryList.Free;
|
|
FFiles.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TFileDialog.DoCanClose(var CanClose: Boolean);
|
|
begin
|
|
{$ifdef DebugCommonDialogEvents}
|
|
debugln(['TFileDialog.DoCanClose: FUserChoice = ',ModalResultStr[FUserChoice],' HandleAllocated=',HandleAllocated]);
|
|
{$endif}
|
|
//Only call OnCanClose if user did not cancel the dialog, see:
|
|
//http://docwiki.embarcadero.com/Libraries/Berlin/en/Vcl.Dialogs.TOpenDialog_Events
|
|
if (FUserChoice = mrOK) then
|
|
inherited DoCanClose(CanClose)
|
|
else
|
|
begin
|
|
FDoCanCloseCalled := True;
|
|
CanClose := True;
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ TFileDialog DoOnTypeChange }
|
|
{------------------------------------------------------------------------------}
|
|
procedure TFileDialog.DoTypeChange;
|
|
begin
|
|
if Assigned(FOnTypeChange) then
|
|
OnTypeChange(Self);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TFileDialog DoExecute
|
|
------------------------------------------------------------------------------}
|
|
procedure TFileDialog.SetHistoryList(const AValue: TStrings);
|
|
begin
|
|
FHistoryList.Assign(AValue);
|
|
end;
|
|
|
|
procedure TFileDialog.IntfFileTypeChanged(NewFilterIndex: Integer);
|
|
begin
|
|
if FilterIndex <> NewFilterIndex then
|
|
begin
|
|
FInternalFilterIndex := NewFilterIndex;
|
|
DoTypeChange;
|
|
end;
|
|
end;
|
|
|
|
class function TFileDialog.FindMaskInFilter(aFilter, aMask: string): integer;
|
|
{ The filter is a list of pairs of captions and masks separated by pipe |
|
|
The masks are separated by semicolon ;
|
|
For example:
|
|
Pascal Files|*.pas;*.pp|All files|*.*
|
|
}
|
|
var
|
|
p: PChar;
|
|
MaskStart: PChar;
|
|
begin
|
|
Result:=0;
|
|
if (aFilter='') or (aMask='') then exit;
|
|
p:=PChar(aFilter);
|
|
while p^<>#0 do
|
|
begin
|
|
// skip caption
|
|
while not (p^ in ['|',#0]) do inc(p);
|
|
if p^=#0 then break;
|
|
// parse masks
|
|
repeat
|
|
inc(p);
|
|
MaskStart:=p;
|
|
while not (p^ in [';','|',#0]) do inc(p);
|
|
//debugln(['TFileDialog.ExtractAllFilterMasks Mask=',copy(aFilter,MaskStart-PChar(aFilter)+1,p-MaskStart)]);
|
|
if (p>MaskStart)
|
|
and (CompareFilenames(MaskStart,p-MaskStart,PChar(aMask),length(aMask),false)=0)
|
|
then
|
|
exit(MaskStart-PChar(aFilter)+1);
|
|
if p^='|' then break;
|
|
if p^=#0 then exit;
|
|
until false;
|
|
inc(p);
|
|
end;
|
|
end;
|
|
|
|
class function TFileDialog.ExtractAllFilterMasks(aFilter: string;
|
|
SkipAllFilesMask: boolean): string;
|
|
{ The filter is a list of pairs of captions and masks separated by pipe |
|
|
The masks are separated by semicolon ;
|
|
For example:
|
|
Pascal Files|*.pas;*.pp|Include Files|*.inc|All files|*.*
|
|
Result: *.pas;*.pp;*.inc
|
|
}
|
|
var
|
|
AllFilesMask: string;
|
|
|
|
procedure AddMask(MaskStart: PChar; MaskLen: integer; var Masks: string);
|
|
var
|
|
p: PChar;
|
|
NewMask: string;
|
|
Start: PChar;
|
|
begin
|
|
if (AllFilesMask<>'')
|
|
and (CompareFilenames(@AllFilesMask[1],length(AllFilesMask),MaskStart,MaskLen,false)=0)
|
|
then exit; // skip all files mask
|
|
|
|
if Masks<>'' then
|
|
begin
|
|
p:=PChar(Masks);
|
|
repeat
|
|
Start:=p;
|
|
while not (p^ in [#0,';']) do inc(p);
|
|
if (CompareFilenames(Start,p-Start,MaskStart,MaskLen,false)=0) then
|
|
exit;
|
|
if p^=#0 then break;
|
|
inc(p);
|
|
until false;
|
|
end;
|
|
if Masks<>'' then
|
|
Masks:=Masks+';';
|
|
SetLength(NewMask,MaskLen);
|
|
System.Move(MaskStart^,NewMask[1],length(NewMask));
|
|
Masks:=Masks+NewMask;
|
|
end;
|
|
|
|
var
|
|
p: PChar;
|
|
MaskStart: PChar;
|
|
begin
|
|
Result:='';
|
|
if aFilter='' then exit;
|
|
if SkipAllFilesMask then
|
|
AllFilesMask:=GetAllFilesMask
|
|
else
|
|
AllFilesMask:='';
|
|
//debugln(['TFileDialog.ExtractAllFilterMasks Filter=',aFilter]);
|
|
p:=PChar(aFilter);
|
|
while p^<>#0 do
|
|
begin
|
|
// skip caption
|
|
while not (p^ in ['|',#0]) do inc(p);
|
|
if p^=#0 then break;
|
|
// parse masks
|
|
repeat
|
|
inc(p);
|
|
MaskStart:=p;
|
|
while not (p^ in [';','|',#0]) do inc(p);
|
|
//debugln(['TFileDialog.ExtractAllFilterMasks Mask=',copy(aFilter,MaskStart-PChar(aFilter)+1,p-MaskStart)]);
|
|
if p>MaskStart then
|
|
AddMask(MaskStart,p-MaskStart,Result);
|
|
if p^='|' then break;
|
|
until p^=#0;
|
|
inc(p);
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TFileDialog.SetDefaultExt(const AValue: string);
|
|
------------------------------------------------------------------------------}
|
|
procedure TFileDialog.SetDefaultExt(const AValue: string);
|
|
begin
|
|
FDefaultExt:=AValue;
|
|
if (FDefaultExt<>'') and (FDefaultExt[1]<>'.') then
|
|
FDefaultExt:='.'+FDefaultExt;
|
|
end;
|
|
|
|
procedure TFileDialog.SetFilterIndex(const AValue: Integer);
|
|
begin
|
|
FFilterIndex := AValue;
|
|
if FHandle = 0 then
|
|
FInternalFilterIndex := AValue;
|
|
end;
|
|
|
|
class procedure TFileDialog.WSRegisterClass;
|
|
begin
|
|
inherited WSRegisterClass;
|
|
RegisterFileDialog;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TFileDialog GetFilterIndex
|
|
------------------------------------------------------------------------------}
|
|
function TFileDialog.GetFilterIndex: Integer;
|
|
begin
|
|
Result := FInternalFilterIndex;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ TFileDialog SetFilter }
|
|
{------------------------------------------------------------------------------}
|
|
procedure TFileDialog.SetFilter(const value : string);
|
|
begin
|
|
FFilter := Value; // make sure this is defined first before the CNSendMessage
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ TFileDialog SetFileName }
|
|
{------------------------------------------------------------------------------}
|
|
procedure TFileDialog.SetFileName(const value : string);
|
|
begin
|
|
if FFilename=Value then exit;
|
|
FFileName := Value; // make sure this is defined first before the CNSendMessage
|
|
end;
|
|
|
|
{******************************************************************************
|
|
TOpenDialog
|
|
******************************************************************************}
|
|
|
|
class procedure TOpenDialog.WSRegisterClass;
|
|
begin
|
|
inherited WSRegisterClass;
|
|
RegisterOpenDialog;
|
|
end;
|
|
|
|
procedure TOpenDialog.ResolveLinks;
|
|
var i: integer;
|
|
begin
|
|
if Filename<>'' then
|
|
Filename:=GetPhysicalFilename(FileName,pfeOriginal);
|
|
if Files<>nil then begin
|
|
for i:=0 to Files.Count-1 do begin
|
|
if Files[i]<>'' then
|
|
Files[i]:=GetPhysicalFilename(Files[i],pfeOriginal);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TOpenDialog.DereferenceLinks;
|
|
begin
|
|
ResolveLinks;
|
|
end;
|
|
|
|
|
|
//Helper function
|
|
function GetExtensionFromFilterAtIndex(Filter: String; Index: Integer): String;
|
|
{
|
|
Returns a file extension from a filter as used in TOpen/TSaveDialog
|
|
- it will return the extension (including the leading period) that matches the index (index starts at 1)
|
|
- it will return an empty string if the extension contains a wildcard, or on any failure
|
|
- filters have the format of:
|
|
'Text files (*.txt)|*.txt|'+
|
|
'Pascal files (*.pp;*.pas)|*.pp;*.pas|'+
|
|
'All files (*.*)|*.*'
|
|
- if a given extension is a composite (like '*.pp;*.pas') it will return the first one from the list
|
|
}
|
|
var
|
|
p, pipe: Integer;
|
|
begin
|
|
Result := '';
|
|
if Index < 1 then Exit;
|
|
p := 0;
|
|
pipe := 0;
|
|
//Find where the filter for the given index starts
|
|
while (p < Length(Filter)) do
|
|
begin
|
|
Inc(p);
|
|
//Debugln('p = ',dbgs(p),' Filter[',dbgs(p),'] = ',Filter[p]);
|
|
if Filter[p] = '|' then Inc(pipe);
|
|
if (pipe = 2 * (Index - 1)) then break;
|
|
end;
|
|
//debugln('p = ',dbgs(p),' pipe = ',dbgs(pipe));
|
|
if (p = length(Filter)) then exit;
|
|
System.Delete(Filter,1,p);
|
|
//Find the | that splits the filter name and the filter extension
|
|
p := Pos('|',Filter);
|
|
if (p = 0) then exit;
|
|
System.Delete(Filter,1,p);
|
|
Filter := Copy(Filter,1,MaxInt);
|
|
//debugln('Filter now = ',filter);
|
|
|
|
//The associated extension ends at the first ; or |, or at the end of the string
|
|
p := Pos(';',Filter);
|
|
pipe := Pos('|',Filter);
|
|
//Debugln('Pos(;/|,Filter) = ',dbgs(p),' ',dbgs(pipe));
|
|
if (pipe < p) or (p = 0) then p := pipe;
|
|
if (p > 0) then System.Delete(Filter,p,Length(Filter) - p + 1);
|
|
//debugln('Filter now = ',filter);
|
|
|
|
//Get the associated extension
|
|
Filter := ExtractFileExt(Filter);
|
|
//debugln('Filter now = ',filter);
|
|
//if an extension at this point contains a wildcard, reject it
|
|
if (Pos('?',Filter) > 0) or (Pos('*',Filter) > 0) then exit;
|
|
Result := Filter;
|
|
end;
|
|
|
|
function TOpenDialog.CheckFile(var AFilename: string): boolean;
|
|
var
|
|
Dir, Ext: string;
|
|
begin
|
|
Result:=true;
|
|
if (DefaultExt<>'') and (ExtractFileExt(AFilename)='')
|
|
and (not FileExistsUTF8(AFilename)) then begin
|
|
Ext := GetExtensionFromFilterAtIndex(Filter, FilterIndex);
|
|
if (Length(Ext) > 0) then
|
|
AFileName := AFileName + Ext
|
|
else
|
|
AFilename:=AFilename+DefaultExt;
|
|
end;
|
|
//ofOverwritePrompt -> is done in the interface
|
|
if (ofPathMustExist in Options)
|
|
and (not DirPathExists(ExtractFileDir(AFilename))) then begin
|
|
Result:=false;
|
|
MessageDlg(rsfdPathMustExist,
|
|
Format(rsfdPathNoExist,[ExtractFileDir(AFilename)]),
|
|
mtError,[mbCancel],0);
|
|
exit;
|
|
end;
|
|
if (ofFileMustExist in Options)
|
|
and (not CheckFileMustExist(AFileName)) then begin
|
|
// CheckFileMustExists shows message dialog
|
|
Result:=false;
|
|
exit;
|
|
end;
|
|
if ofNoReadOnlyReturn in Options then begin
|
|
if FileExistsUTF8(AFilename) then
|
|
Result := FileIsWritable(AFilename)
|
|
else begin { File does not exist - check directory }
|
|
Dir := ExtractFileDir(AFilename);
|
|
if Dir = '' then
|
|
Dir := '.';
|
|
Result := DirectoryIsWritable(Dir);
|
|
end;
|
|
if not Result then begin
|
|
MessageDlg(rsfdFileReadOnlyTitle,
|
|
Format(rsfdFileReadOnly,[AFileName]),
|
|
mtError,[mbCancel],0);
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TOpenDialog.CheckFileMustExist(const AFileName: string): boolean;
|
|
begin
|
|
if not FileExistsUTF8(AFilename) then begin
|
|
Result:=false;
|
|
MessageDlg(rsfdFileMustExist,
|
|
Format(rsfdFileNotExist,[AFileName]),mtError,
|
|
[mbCancel],0);
|
|
end else
|
|
Result:=true;
|
|
end;
|
|
|
|
function TOpenDialog.CheckAllFiles: boolean;
|
|
var
|
|
AFilename: String;
|
|
i: Integer;
|
|
begin
|
|
Result:=true;
|
|
|
|
AFilename:=Filename;
|
|
if (AFilename<>'')
|
|
or (not (ofAllowMultiSelect in Options)) then begin
|
|
Result:=CheckFile(AFilename);
|
|
Filename:=AFilename;
|
|
if not Result then exit;
|
|
end;
|
|
|
|
if ofAllowMultiSelect in Options then begin
|
|
for i:=0 to Files.Count-1 do begin
|
|
AFilename:=Files[i];
|
|
Result:=CheckFile(AFilename);
|
|
Files[i]:=AFilename;
|
|
if not Result then exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TOpenDialog.DoExecute
|
|
Params: none
|
|
Returns: true if valid was selected
|
|
|
|
Starts dialogs and lets user choose a filename.
|
|
------------------------------------------------------------------------------}
|
|
function TOpenDialog.DoExecute: boolean;
|
|
begin
|
|
Result:=inherited DoExecute;
|
|
if (not (ofNoResolveLinks in Options)) then begin
|
|
if TMethod(@Self.DereferenceLinks).Code <> Pointer(@TOpenDialog.DereferenceLinks)
|
|
then begin
|
|
DereferenceLinks{%H-}; // call for compatibility
|
|
end else
|
|
ResolveLinks;
|
|
end;
|
|
if (not (ofNoChangeDir in Options)) then begin
|
|
if (ExtractFilePath(Filename)<>'') then
|
|
InitialDir:=ExtractFilePath(Filename)
|
|
else if (Files.Count>0) and (ExtractFilePath(Files[0])<>'') then
|
|
InitialDir:=ExtractFilePath(Files[0]);
|
|
end;
|
|
if not Result then exit;
|
|
Result:=CheckAllFiles;
|
|
end;
|
|
|
|
function TOpenDialog.DefaultTitle: string;
|
|
begin
|
|
Result:= rsfdOpenFile;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TOpenDialog.Create
|
|
Params: AOwner: the owner of the class
|
|
Returns: Nothing
|
|
|
|
Constructor for the class.
|
|
------------------------------------------------------------------------------}
|
|
constructor TOpenDialog.Create(TheOwner: TComponent);
|
|
begin
|
|
inherited Create(TheOwner);
|
|
fCompStyle:=csOpenFileDialog;
|
|
FOptions := DefaultOpenDialogOptions;
|
|
end;
|
|
|
|
procedure TOpenDialog.DoCanClose(var CanClose: Boolean);
|
|
begin
|
|
//Delphi never calls OnCanClose in this case
|
|
if not (ofOldStyleDialog in Options) then
|
|
inherited DoCanClose(CanClose)
|
|
else
|
|
begin
|
|
FDoCanCloseCalled := True;
|
|
CanClose := True;
|
|
end;
|
|
end;
|
|
|
|
procedure TOpenDialog.DoFolderChange;
|
|
begin
|
|
if Assigned(OnFolderChange) then OnFolderChange(Self);
|
|
end;
|
|
|
|
procedure TOpenDialog.DoSelectionChange;
|
|
var
|
|
CurFilename: String;
|
|
begin
|
|
CurFilename:=Filename;
|
|
if FLastSelectionChangeFilename=CurFilename then exit;
|
|
FLastSelectionChangeFilename:=CurFilename;
|
|
if Assigned(OnSelectionChange) then OnSelectionChange(Self);
|
|
end;
|
|
|
|
procedure TOpenDialog.IntfSetOption(const AOption: TOpenOption;
|
|
const AValue: Boolean);
|
|
begin
|
|
if AValue then
|
|
Include(FOptions, AOption)
|
|
else
|
|
Exclude(FOptions, AOption);
|
|
end;
|
|
|
|
|
|
|
|
class procedure TSaveDialog.WSRegisterClass;
|
|
begin
|
|
inherited WSRegisterClass;
|
|
RegisterSaveDialog;
|
|
end;
|
|
|
|
function TSaveDialog.DefaultTitle: string;
|
|
begin
|
|
Result:=rsfdFileSaveAs;
|
|
end;
|
|
|
|
{******************************************************************************
|
|
TSaveDialog
|
|
******************************************************************************}
|
|
{------------------------------------------------------------------------------
|
|
Method: TSaveDialog.Create
|
|
Params: AOwner: the owner of the class
|
|
Returns: Nothing
|
|
|
|
Constructor for the class.
|
|
------------------------------------------------------------------------------}
|
|
constructor TSaveDialog.Create (AOwner : TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
fCompStyle:=csSaveFileDialog;
|
|
end;
|
|
|
|
{******************************************************************************
|
|
TSelectDirectoryDialog
|
|
******************************************************************************}
|
|
|
|
{ TSelectDirectoryDialog }
|
|
|
|
constructor TSelectDirectoryDialog.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
fCompStyle:=csSelectDirectoryDialog;
|
|
end;
|
|
|
|
class procedure TSelectDirectoryDialog.WSRegisterClass;
|
|
begin
|
|
inherited WSRegisterClass;
|
|
RegisterSelectDirectoryDialog;
|
|
end;
|
|
|
|
function TSelectDirectoryDialog.CheckFileMustExist(const AFilename: string): boolean;
|
|
begin
|
|
if not DirPathExists(AFilename) then begin
|
|
Result:=false;
|
|
MessageDlg(rsfdDirectoryMustExist,
|
|
Format(rsfdDirectoryNotExist,[AFileName]),mtError,
|
|
[mbCancel],0);
|
|
end else
|
|
Result:=true;
|
|
end;
|
|
|
|
function TSelectDirectoryDialog.DefaultTitle: string;
|
|
begin
|
|
Result:=rsfdSelectDirectory;
|
|
end;
|
|
|
|
|