1{ 2 /*************************************************************************** 3 filectrl.pp 4 ----------- 5 Component Library File Controls 6 Initial Revision : Sun Apr 23 18:30:00 PDT 2000 7 8 9 ***************************************************************************/ 10 11 ***************************************************************************** 12 This file is part of the Lazarus Component Library (LCL) 13 14 See the file COPYING.modifiedLGPL.txt, included in this distribution, 15 for details about the license. 16 ***************************************************************************** 17 18This unit contains file and directory controls and supporting handling functions. 19} 20 21unit FileCtrl; 22 23{$mode objfpc}{$H+} 24 25interface 26 27{$ifdef Trace} 28 {$ASSERTIONS ON} 29{$endif} 30 31uses 32 Classes, SysUtils, StdCtrls, FileUtil, LazFileUtils, Masks, Graphics, 33 ShellCtrls; 34 35Type 36 37 { TCustomFileListBox } 38 39 TFileAttr = (ftReadOnly, ftHidden, ftSystem, ftVolumeID, ftDirectory, 40 ftArchive, ftNormal); 41 42 TFileType = set of TFileAttr; 43 44 TCustomFileListBox = class(TCustomListBox) 45 private 46 FDrive: Char; 47 FDirectory: String; 48 FFileName: String; 49 FFileType: TFileType; 50 FMask: String; 51 FOnChange: TNotifyEvent; 52 FLastChangeFileName: string; 53 function MaskIsStored: boolean; 54 procedure SetDirectory(const AValue: String); 55 procedure SetDrive(const AValue: Char); 56 procedure SetFileName(const AValue: String); 57 procedure SetFileType(const AValue: TFileType); 58 procedure SetMask(const AValue: String); 59 procedure UpdateSelectedFileName; 60 protected 61 procedure DoChangeFile; virtual; 62 procedure Loaded; override; 63 function IndexOfFile(const AFilename: string): integer; 64 procedure KeyUp(var Key: Word; Shift: TShiftState); override; 65 procedure SetItemIndex(AIndex: Integer); override; 66 public 67 constructor Create(TheOwner: TComponent); override; 68 destructor Destroy; override; 69 procedure Click; override; 70 procedure UpdateFileList; virtual; 71 public 72 property Drive: Char Read FDrive Write SetDrive default ' '; 73 property Directory: String Read FDirectory Write SetDirectory; 74 property FileName: String Read FFileName Write SetFileName; 75 property FileType: TFileType Read FFileType Write SetFileType default [ftNormal]; 76 property Mask: String Read FMask Write SetMask stored MaskIsStored; 77 property OnChange: TNotifyEvent Read FOnChange Write FOnChange; 78 property Sorted default true; 79 end; 80 81 82 { TFileListBox } 83 84 TFileListBox = class(TCustomFileListBox) 85 published 86 property Align; 87 property Anchors; 88 property BiDiMode; 89 property BorderSpacing; 90 property BorderStyle; 91 property Color; 92 property Constraints; 93 property Directory; 94 property DragCursor; 95 property DragMode; 96 property Enabled; 97 property ExtendedSelect; 98 property FileType; 99 property Font; 100 property IntegralHeight; 101 property ItemHeight; 102 property Mask; 103 property MultiSelect; 104 property OnChange; 105 property OnChangeBounds; 106 property OnClick; 107 property OnDblClick; 108 property OnDragDrop; 109 property OnDragOver; 110 property OnDrawItem; 111 property OnEndDrag; 112 property OnEnter; 113 property OnExit; 114 property OnKeyPress; 115 property OnKeyDown; 116 property OnKeyUp; 117 property OnMouseDown; 118 property OnMouseEnter; 119 property OnMouseLeave; 120 property OnMouseMove; 121 property OnMouseUp; 122 property OnMouseWheel; 123 property OnMouseWheelDown; 124 property OnMouseWheelUp; 125 property OnResize; 126 property OnSelectionChange; 127 property OnStartDrag; 128 property OnUTF8KeyPress; 129 property ParentBiDiMode; 130 property ParentColor; 131 property ParentShowHint; 132 property ParentFont; 133 property PopupMenu; 134 property ShowHint; 135 property Sorted; 136 property Style; 137 property TabOrder; 138 property TabStop; 139 property TopIndex; 140 property Visible; 141 end; 142 143 { TCustomFilterComboBox } 144 145 TCustomFilterComboBox = class(TCustomComboBox) 146 private 147 FFilter: string; 148 FShellListView: TShellListView; 149 function GetMask: string; 150 procedure SetFilter(const AValue: string); 151 procedure SetShellListView(const AValue: TShellListView); 152 protected 153 procedure Select; override; 154 procedure Notification(AComponent: TComponent; Operation: TOperation); 155 override; 156 public 157 { Base methods } 158 constructor Create(TheOwner: TComponent); override; 159 destructor Destroy; override; 160 { Externally available methods } 161 class procedure ConvertFilterToStrings(AFilter: string; 162 AStrings: TStrings; AClearStrings, AAddDescription, AAddFilter: Boolean); 163 { properties } 164 property Mask: string read GetMask; // Can be used to conect to other controls 165 property ShellListView: TShellListView read FShellListView write SetShellListView; 166 end; 167 168 TFilterComboBox = class(TCustomFilterComboBox) 169 published 170 { properties } 171 property Align; 172 property Anchors; 173 property AutoComplete; 174 property AutoDropDown; 175 property AutoSize;// Note: windows has a fixed height in some styles 176 property BidiMode; 177 property BorderSpacing; 178 property Color; 179 property Constraints; 180 property DragCursor; 181 property DragKind; 182 property DragMode; 183 property Enabled; 184 // property FileList: TFileList 185 property Filter: string read FFilter write SetFilter; 186 property Font; 187 property ItemIndex; 188 property ParentBidiMode; 189 property ParentColor; 190 property ParentFont; 191 property ParentShowHint; 192 property PopupMenu; 193 property ShellListView; 194 property ShowHint; 195 property TabOrder; 196 property TabStop; 197 property Visible; 198 { events } 199 property OnChange; 200 property OnClick; 201 property OnCloseUp; 202 property OnContextPopup; 203 property OnDblClick; 204 property OnDragDrop; 205 property OnDragOver; 206 property OnEndDrag; 207 property OnDropDown; 208 property OnEnter; 209 property OnExit; 210 property OnKeyDown; 211 property OnKeyPress; 212 property OnKeyUp; 213 property OnMouseDown; 214 property OnMouseEnter; 215 property OnMouseLeave; 216 property OnMouseMove; 217 property OnMouseUp; 218 property OnMouseWheel; 219 property OnMouseWheelDown; 220 property OnMouseWheelUp; 221 property OnStartDrag; 222 property OnSelect; 223 property OnUTF8KeyPress; 224 end; 225 226function MiniMizeName(FileName: String; Canvas: TCanvas; MaxWidth: Integer): String; 227 228procedure Register; 229 230implementation 231 232 233function MiniMizeName(FileName: String; Canvas: TCanvas; MaxWidth: Integer): String; 234{ 235 This function will return a shortened version of FileName, so that it fits 236 on the given Canvas, with a given MaxWidth. 237 eg. C:\Documents and Settings\User\Application Data\Microsoft\Word\custom.dic 238 would become something like: C:\...\Word\custom.dic 239} 240 procedure RemoveFirstDir(var Dir: String); 241 { 242 This procedure will remove the first directory from Dir 243 and will set ADelim to the Delimiter that separated the first Dir 244 eg. In: Dir: 'Dir1\Dir2\Dir3' 245 } 246 var p: Integer; 247 begin 248 p:= Pos(PathDelim,Dir); 249 if (p > 0) then 250 begin 251 Dir := Copy(Dir,p+1,Length(Dir)-p); 252 end; 253 end; 254var Drive, Dir, Fn: String; 255 ComposedName: String; 256 TWidth: Integer; 257begin 258 Result := FileName; 259 //if FileName does not contain any (sub)dir then return FileName 260 if Pos(PathDelim, FileName) = 0 then Exit; 261 //if FileName fits, no need to do anyhing 262 if Canvas.TextWidth(FileName) <= MaxWidth then Exit; 263 Drive := ExtractFileDrive(FileName); 264 Fn := ExtractFileName(FileName); 265 Dir := ExtractFilePath(FileName); 266 //Remove Drive from Dir 267 if (Length(Drive) > 0) then System.Delete(Dir, 1, Length(Drive)); 268 //Transfer all PathDelimiters at the start of Dir to Drive 269 While (Length(Dir) > 0) and (Dir[1] in ['/','\']) do 270 begin 271 Drive := Drive + Dir[1]; 272 System.Delete(Dir,1,1); 273 end; 274 //if Dir is empty then we cannot shorten it, 275 //and we know at this point that Drive+FileName is too long, so we return only filename 276 if (Length(Dir) = 0) then 277 begin 278 Result := Fn; 279 Exit; 280 end; 281 repeat 282 //at this point we know that Dir ends with PathDelim (otherwise we exited before this point, 283 //so RemoveFirstDir will return a truncated Dir or an empty string 284 RemoveFirstDir(Dir); 285 ComposedName := Drive+'...'+PathDelim+Dir+Fn; 286 TWidth := Canvas.TextWidth(ComposedName); 287 until (Length(Dir) = 0) or (TWidth <= MaxWidth); 288 if (TWidth <= MaxWidth) then Result := ComposedName else Result := Fn; 289end; 290 291 292 293 294{ TCustomFileListBox } 295 296procedure TCustomFileListBox.UpdateFileList; 297const 298 FileTypeFilesOnly = [ftReadOnly, ftHidden, ftSystem, ftArchive, ftNormal]; 299 {AttrNotNormal = faReadOnly or 300 faHidden or 301 faSysFile or 302 faVolumeID or 303 faDirectory or 304 faArchive } 305var 306 Info: TSearchRec; 307 FileAttr: LongInt; 308 309 function FileTypeToFileAttribute(FileType: TFileType): LongInt; 310 const 311 FileTypeToAttrMap: array[TFileAttr] of LongInt = 312 ( 313 { ftReadOnly } faReadOnly, 314 { ftHidden } faHidden{%H-}, 315 { ftSystem } faSysFile{%H-}, 316 { ftVolumeID } faVolumeId{%H-}, 317 { ftDirectory } faDirectory, 318 { ftArchive } faArchive, 319 { ftNormal } 0 320 ); 321 var 322 Iter: TFileAttr; 323 begin 324 Result := 0; 325 for Iter := Low(TFileAttr) to High(TFileAttr) do 326 if Iter in FileType then 327 Result := Result or FileTypeToAttrMap[Iter]; 328 end; 329 330begin 331 if [csloading, csdestroying] * ComponentState <> [] then 332 Exit; 333 Clear; 334 if FileType <> [] then 335 begin 336 FileAttr := FileTypeToFileAttribute(FileType); 337 if FindFirstUTF8( 338 IncludeTrailingPathDelimiter(FDirectory)+AllDirectoryEntriesMask, 339 FileAttr, Info) = 0 340 then 341 repeat 342 if MatchesMaskList(Info.Name,Mask) then 343 begin 344 if (ftNormal in FileType) or ((Info.Attr and FileAttr {AttrNotNormal}) > 0) then 345 begin 346 if (Info.Attr and faDirectory) > 0 then 347 Items.Add('['+Info.Name+']') 348 else 349 begin 350 if (FileType * FileTypeFilesOnly <> []) then //don't add files if no file attribute is specified 351 Items.Add(Info.Name); 352 end; 353 end; 354 end; 355 until FindNextUTF8(Info) <> 0; 356 FindCloseUTF8(Info); 357 end; 358 359 UpdateSelectedFileName; 360end; 361 362procedure TCustomFileListBox.Click; 363begin 364 UpdateSelectedFileName; 365 inherited Click; 366end; 367 368procedure TCustomFileListBox.Loaded; 369begin 370 inherited Loaded; 371 UpdateFileList; 372end; 373 374function TCustomFileListBox.IndexOfFile(const AFilename: string): integer; 375var 376 CurItem: string; 377begin 378 Result:=0; 379 while (Result<Items.Count) do begin 380 CurItem:=Items[Result]; 381 if (CompareFilenames(AFilename,CurItem)=0) 382 or ((CurItem<>'') and (CurItem[1]='[') and (CurItem[length(CurItem)]=']') 383 and (CompareFilenames('['+AFilename+']',CurItem)=0)) 384 then 385 exit; 386 inc(Result); 387 end; 388 Result:=-1; 389end; 390 391procedure TCustomFileListBox.KeyUp(var Key: Word; Shift: TShiftState); 392begin 393 UpdateSelectedFileName; 394 inherited KeyUp(Key, Shift); 395end; 396 397procedure TCustomFileListBox.SetFileType(const AValue: TFileType); 398begin 399 if FFileType=AValue then exit; 400 FFileType := AValue; 401 UpdateFileList; 402end; 403 404procedure TCustomFileListBox.SetDirectory(const AValue: String); 405begin 406 if FDirectory=AValue then exit; 407 FDirectory := AValue; 408 UpdateFileList; 409end; 410 411function TCustomFileListBox.MaskIsStored: boolean; 412begin 413 Result:=(FMask<>AllDirectoryEntriesMask); 414end; 415 416procedure TCustomFileListBox.SetDrive(const AValue: Char); 417begin 418 if FDrive=AValue then exit; 419 FDrive := AValue; 420 // ToDo: change to current directory of drive 421 UpdateFileList; 422end; 423 424procedure TCustomFileListbox.SetItemIndex(AIndex: Integer); 425begin 426 inherited; 427 UpdateSelectedFileName; 428end; 429 430procedure TCustomFileListBox.SetFileName(const AValue: String); 431var 432 i: Integer; 433begin 434 i:=IndexOfFile(AValue); 435 if i<>ItemIndex then begin 436 ItemIndex:=i; 437 UpdateSelectedFileName; 438 end; 439end; 440 441procedure TCustomFileListBox.SetMask(const AValue: String); 442begin 443 if FMask = AValue then exit; 444 FMask := AValue; 445 UpdateFileList; 446end; 447 448procedure TCustomFileListBox.UpdateSelectedFileName; 449var 450 i: Integer; 451begin 452 i:=ItemIndex; 453 // in a multiselect listbox, the itemindex can be 0 in an empty list 454 if (i<0) or (i>=Items.Count) then 455 FFileName := '' 456 else begin 457 FFileName := Items[i]; 458 if (FFileName<>'') 459 and (FFileName[1]='[') and (FFileName[length(FFileName)]=']') then 460 FFileName:=copy(FFileName,2,length(FFileName)-2); 461 FFileName:= FDirectory+DirectorySeparator+FFileName; 462 end; 463 DoChangeFile; 464end; 465 466procedure TCustomFileListBox.DoChangeFile; 467begin 468 if FFilename=FLastChangeFileName then exit; 469 FLastChangeFileName:=FFilename; 470 If Assigned(FOnChange) then FOnChange(Self); 471end; 472 473constructor TCustomFileListBox.Create(TheOwner: TComponent); 474var 475 FileDrive: string; 476 CurrentDir: string; 477begin 478 inherited Create(TheOwner); 479 //Initializes the Mask property. 480 FMask := AllDirectoryEntriesMask; 481 //Initializes the FileType property. 482 FFileType := [ftNormal]; 483 //Initializes the Directory and Drive properties to the current directory. 484 CurrentDir := GetCurrentDirUTF8; 485 FDirectory := CurrentDir; 486 FileDrive := ExtractFileDrive(CurrentDir); 487 if FileDrive<>'' then 488 FDrive:=FileDrive[1] 489 else 490 FDrive:=' '; 491 //Initializes the MultiSelect property. 492 MultiSelect := False; 493 //Fills the list box with all the files in the directory. 494 UpdateFileList; 495 //Initializes the Sorted property. 496 Sorted := True; 497end; 498 499destructor TCustomFileListBox.Destroy; 500begin 501 inherited Destroy; 502end; 503 504{ TCustomFilterComboBox } 505 506function TCustomFilterComboBox.GetMask: string; 507var 508 FilterList: TStrings; 509begin 510 Result := ''; 511 512 FilterList := TStringList.Create; 513 try 514 TCustomFilterComboBox.ConvertFilterToStrings(FFilter, FilterList, True, False, True); 515 516 if (ItemIndex >= 0) and (ItemIndex < FilterList.Count) then 517 begin 518 Result := FilterList[ItemIndex]; 519 end; 520 finally 521 FilterList.Free; 522 end; 523end; 524 525procedure TCustomFilterComboBox.SetFilter(const AValue: string); 526begin 527 if AValue = FFilter then Exit; 528 529 FFilter := AValue; 530 531 TFilterComboBox.ConvertFilterToStrings(AValue, Items, True, True, False); 532 533 ItemIndex := 0; 534end; 535 536procedure TCustomFilterComboBox.SetShellListView(const AValue: TShellListView); 537begin 538 if FShellListView=AValue then exit; 539 540 FShellListView:=AValue; 541 542 if FShellListView <> nil then begin 543 FShellListView.Mask := Mask; 544 FreeNotification(FShellListView); 545 end; 546end; 547 548procedure TCustomFilterComboBox.Select; 549begin 550 if FShellListView <> nil then 551 FShellListView.Mask := Mask; 552 553 inherited Select; 554end; 555 556procedure TCustomFilterComboBox.Notification(AComponent: TComponent; 557 Operation: TOperation); 558begin 559 inherited Notification(AComponent, Operation); 560 if Operation=opRemove then 561 begin 562 if FShellListView=AComponent then 563 FShellListView:=nil; 564 end; 565end; 566 567{------------------------------------------------------------------------------ 568This is a parser that converts LCL filter strings to a TStringList 569 570The parses states are: 571 5720 - Initial state, is reading a string to be displayed on the filter 5731 - Is reading the extensions 574 575A LCL filter string looks like this: 576 577Text files (*.txt *.pas)|*.txt;*.pas|Binaries (*.exe)|*.exe 578or 579Text files (*.txt *.pas)|*.txt;*.pas|Binaries (*.exe)|*.exe| 580 581The TStrings will contain the following strings if 582AAddDescription = True, AAddFilter = False 583 584Text files (*.txt *.pas) 585Binaries (*.exe) 586 587Adapted from the converter initially created for QtWSDialogs.pas 588------------------------------------------------------------------------------} 589class procedure TCustomFilterComboBox.ConvertFilterToStrings(AFilter: string; 590 AStrings: TStrings; AClearStrings, AAddDescription, AAddFilter: Boolean); 591var 592 ParserState, Position, i: Integer; 593begin 594 if AStrings = nil then Exit; 595 596 if AClearStrings then AStrings.Clear; 597 598 ParserState := 0; 599 Position := 1; 600 AFilter := AFilter + '|'; // to prevent ignoring of last filter 601 602 for i := 1 to Length(AFilter) do 603 begin 604 if AFilter[i] = '|' then 605 begin 606 case ParserState of 607 0: 608 begin 609 if AAddDescription then 610 AStrings.Add(Copy(AFilter, Position, i - Position)); 611 ParserState := 1; 612 end; 613 1: 614 begin 615 if AAddFilter then 616 AStrings.Add(Copy(AFilter, Position, i - Position)); 617 ParserState := 0; 618 end; 619 end;// case 620 621 Position := i + 1; 622 end; 623 end; 624end; 625 626constructor TCustomFilterComboBox.Create(TheOwner: TComponent); 627begin 628 inherited Create(TheOwner); 629 630 Text := ''; 631end; 632 633destructor TCustomFilterComboBox.Destroy; 634begin 635 636 inherited Destroy; 637end; 638 639procedure Register; 640begin 641 RegisterComponents('Misc',[TFileListBox, TFilterComboBox]); 642end; 643 644end. 645 646