source: branches/2.19_branch/Components/CustomFileControls.pas@ 350

Last change on this file since 350 was 15, checked in by RBRi, 19 years ago

+ components stuff
  • Property svn:eol-style set to native
File size: 39.0 KB
Line 
1Unit CustomFileControls;
2
3// 26/9/0
4// Fixed filter combo box for when filter is invalid and results in
5// no list entries: crashes because it tries to set item index to 0.
6Interface
7
8Uses
9 Dos, SysUtils, Classes, Forms, StdCtrls, CustomListBox, Graphics;
10
11
12Type
13 TCustomDirectoryListBox=Class;
14 TCustomDriveComboBox=Class;
15 TCustomFilterComboBox=Class;
16
17 {ftVolumnID has no effect, but exists For compatibility Of TFileAttr}
18 TFileAttr=(ftReadOnly,ftHidden,ftSystem,ftVolumeID,ftDirectory,ftArchive,
19 ftNormal);
20 TFileType=Set Of TFileAttr;
21
22 TCustomFilelistBox=Class(TCustomListBox)
23 Private
24 FMask: String;
25 FExcludeMask: string;
26 FOldMask: String;
27 FDirectory: String;
28 FOldDirectory: String;
29 FFileType: TFileType;
30 FOldFileType: TFileType;
31 FFileEdit: TEdit;
32 FFilterCombo: TCustomFilterComboBox;
33 FOnChange: TNotifyEvent;
34 FDirList: TCustomDirectoryListBox;
35 Function GetDrive:Char;
36 Procedure SetDrive(NewDrive:Char);
37 Procedure SetDirectory(NewDir:String);
38 Procedure SetFileName(NewFile:String);
39 Function GetFileName:String;
40 Procedure SetMask(NewMask:String);
41 Procedure SetExcludeMask(NewMask:String);
42 Procedure SetFileType(Attr:TFileType);
43 Procedure SetFileEdit(NewEdit:TEdit);
44 Procedure BuildList;
45 Protected
46 Procedure SetupComponent;Override;
47 Procedure Notification(AComponent:TComponent;Operation:TOperation);Override;
48 Procedure ItemFocus(Index:LongInt);Override;
49 Procedure Change;Virtual;
50 Property Duplicates;
51 Property Sorted;
52 Procedure SetupShow;Override;
53 Public
54 Function WriteSCUResource(Stream:TResourceStream):Boolean;Override;
55 Property FileName:String Read GetFileName Write SetFileName;
56 Property Directory:String Read FDirectory Write SetDirectory;
57 Property Drive:Char Read GetDrive Write SetDrive;
58 Procedure Reload;
59 Published
60 Property FileEdit:TEdit Read FFileEdit Write SetFileEdit;
61 Property FileType:TFileType Read FFileType Write SetFileType;
62 Property Mask:String Read fMask Write SetMask;
63 Property ExcludeMask:String Read fExcludeMask Write SetExcludeMask;
64 Property OnChange:TNotifyEvent Read FOnChange Write FOnChange;
65 End;
66
67 TCustomDirectoryListBox=Class(TListBox)
68 Private
69 FPictureOpen: TBitmap;
70 FPictureClosed: TBitmap;
71 FPictureOpenMask: TBitmap;
72 FPictureClosedMask: TBitmap;
73 FDirectory: String;
74 FDirLabel: TLabel;
75 FFileList: TCustomFileListBox;
76 FOnChange: TNotifyEvent;
77 FDriveCombo: TCustomDriveComboBox;
78 Procedure SetDirectory(NewDir:String);
79 Function GetDrive:Char;
80 Procedure SetDrive(NewDrive:Char);
81 Procedure SetDirLabel(ALabel:TLabel);
82 Procedure SetFilelistBox(AFileList:TCustomFileListBox);
83 Procedure BuildList;
84 Protected
85 Procedure SetupComponent;Override;
86 Procedure Notification(AComponent:TComponent;Operation:TOperation);Override;
87 Procedure ItemSelect(Index:LongInt);Override;
88 Procedure Change;Virtual;
89 Procedure DrawOpenFolder( Var X: longint; Y: LongInt );
90 Procedure DrawClosedFolder( Var X: longint; Y: LongInt );
91 Procedure MeasureItem(Index:LongInt;Var Width,Height:LongInt);Override;
92 Procedure DrawItem( Index: LongInt;
93 rec: TRect;
94 State: TOwnerDrawState );Override;
95 Procedure SetupShow;Override;
96
97 Procedure SetPictureOpen(NewBitmap:TBitmap);
98 Procedure SetPictureClosed(NewBitmap:TBitmap);
99
100 Property Duplicates;
101 Property ExtendedSelect;
102 Property MultiSelect;
103 Property Sorted;
104 Property Style;
105 Property OnDrawItem;
106 Property OnMeasureItem;
107 Property Items;
108
109 Public
110 Destructor Destroy; Override;
111 Function WriteSCUResource(Stream:TResourceStream):Boolean;Override;
112 Property Directory:String Read FDirectory Write SetDirectory;
113 Property Drive:Char Read GetDrive Write SetDrive;
114 Property XAlign;
115 Property XStretch;
116 Property YAlign;
117 Property YStretch;
118 Published
119 Property Align;
120 Property Color;
121 Property PenColor;
122 Property DirLabel:TLabel Read FDirLabel Write SetDirLabel;
123 Property DragCursor;
124 Property DragMode;
125 Property Enabled;
126 Property FileList:TCustomFileListBox Read FFileList Write SetFilelistBox;
127 Property Font;
128 Property HorzScroll;
129 Property IntegralHeight;
130 Property ItemHeight;
131 Property ParentColor;
132 Property ParentPenColor;
133 Property ParentFont;
134 Property ParentShowHint;
135 Property ShowDragRects;
136 Property ShowHint;
137 Property TabOrder;
138 Property TabStop;
139 Property Visible;
140 Property ZOrder;
141
142 Property PictureClosed:TBitmap Read FPictureClosed Write SetPictureClosed;
143 Property PictureOpen:TBitmap Read FPictureOpen Write SetPictureOpen;
144
145 Property OnCanDrag;
146 Property OnChange:TNotifyEvent Read FOnChange Write FOnChange;
147 Property OnDragDrop;
148 Property OnDragOver;
149 Property OnEndDrag;
150 Property OnEnter;
151 Property OnExit;
152 Property OnFontChange;
153 Property OnKeyPress;
154 Property OnMouseClick;
155 Property OnMouseDblClick;
156 Property OnMouseDown;
157 Property OnMouseMove;
158 Property OnMouseUp;
159 Property OnScan;
160 Property OnSetupShow;
161 Property OnStartDrag;
162 End;
163
164 {$HINTS OFF}
165 TCustomDriveComboBox=Class(TComboBox)
166 Private
167 FDirList:TCustomDirectoryListBox;
168 FOnChange:TNotifyEvent;
169 FLastIndex:longint;
170 Function GetDrive:Char;
171 Procedure SetDrive(NewDrive:Char);
172 Procedure SetDirListBox(ADirList:TCustomDirectoryListBox);
173 Protected
174 Procedure SetupComponent;Override;
175 Procedure Notification(AComponent:TComponent;Operation:TOperation);Override;
176 Procedure ItemSelect(Index:LongInt);Override;
177 Procedure Change;Virtual;
178 Property Duplicates;
179 Property MaxLength;
180 Property SelLength;
181 Property SelStart;
182 Property SelText;
183 Property Sorted;
184 Property Style;
185 Property TextExtension;
186 Procedure DrawItem( Canvas: TCanvas;
187 S: string;
188 Data: TObject;
189 rec: TRect;
190 State: TOwnerDrawState );
191 Public
192 Function WriteSCUResource(Stream:TResourceStream):Boolean;Override;
193 Property Drive:Char Read GetDrive Write SetDrive;
194 Property Items;
195 Property Text;
196 Property XAlign;
197 Property XStretch;
198 Property YAlign;
199 Property YStretch;
200 Published
201 Property Align;
202 Property Color;
203 Property PenColor;
204 Property DirList:TCustomDirectoryListBox Read FDirList Write SetDirListBox;
205 Property DragCursor;
206 Property DragMode;
207 Property DropDownCount;
208 Property Enabled;
209 Property Font;
210 Property ParentColor;
211 Property ParentPenColor;
212 Property ParentFont;
213 Property ParentShowHint;
214 Property ShowHint;
215 Property TabOrder;
216 Property TabStop;
217 Property Visible;
218 Property ZOrder;
219
220 Property OnCanDrag;
221 Property OnChange:TNotifyEvent Read FOnChange Write FOnChange;
222 Property OnDragDrop;
223 Property OnDragOver;
224 Property OnDropDown;
225 Property OnEndDrag;
226 Property OnEnter;
227 Property OnExit;
228 Property OnFontChange;
229 Property OnKeyPress;
230 Property OnMouseClick;
231 Property OnMouseDblClick;
232 Property OnMouseDown;
233 Property OnMouseMove;
234 Property OnMouseUp;
235 Property OnScan;
236 Property OnSetupShow;
237 Property OnStartDrag;
238 End;
239 {$HINTS ON}
240
241
242 {$HINTS OFF}
243 TCustomFilterComboBox=Class(TComboBox)
244 Private
245 FFilter:String;
246 FFileList:TCustomFilelistBox;
247 FMaskList:TStringList;
248 FOnChange:TNotifyEvent;
249 Procedure SetFilter(NewFilter:String);
250 Procedure SetFilelistBox(AFileList:TCustomFilelistBox);
251 Function GetMask:String;
252 Procedure BuildList;
253 Protected
254 Procedure SetupComponent;Override;
255 Procedure Notification(AComponent:TComponent;Operation:TOperation);Override;
256 Procedure SetupShow;Override;
257 Procedure ItemSelect(Index:LongInt);Override;
258 Procedure Change;Virtual;
259 Property Duplicates;
260 Property MaxLength;
261 Property SelLength;
262 Property SelStart;
263 Property SelText;
264 Property Sorted;
265 Property Style;
266 Property TextExtension;
267 Public
268 Destructor Destroy;Override;
269 Function WriteSCUResource(Stream:TResourceStream):Boolean;Override;
270 Property Mask:String Read GetMask;
271 Property Items;
272 Property Text;
273 Property XAlign;
274 Property XStretch;
275 Property YAlign;
276 Property YStretch;
277 Published
278 Property Align;
279 Property Color;
280 Property PenColor;
281 Property DragCursor;
282 Property DragMode;
283 Property DropDownCount;
284 Property Enabled;
285 Property FileList:TCustomFilelistBox Read FFileList Write SetFilelistBox;
286 Property Filter:String Read FFilter Write SetFilter;
287 Property Font;
288 Property ParentColor;
289 Property ParentPenColor;
290 Property ParentFont;
291 Property ParentShowHint;
292 Property ShowHint;
293 Property TabOrder;
294 Property TabStop;
295 Property Visible;
296 Property ZOrder;
297
298 Property OnCanDrag;
299 Property OnChange:TNotifyEvent Read FOnChange Write FOnChange;
300 Property OnDragDrop;
301 Property OnDragOver;
302 Property OnDropDown;
303 Property OnEndDrag;
304 Property OnEnter;
305 Property OnExit;
306 Property OnFontChange;
307 Property OnKeyPress;
308 Property OnMouseClick;
309 Property OnMouseDblClick;
310 Property OnMouseDown;
311 Property OnMouseMove;
312 Property OnMouseUp;
313 Property OnScan;
314 Property OnSetupShow;
315 Property OnStartDrag;
316 End;
317 {$HINTS ON}
318
319
320
321Function InsertCustomFilelistBox(parent:TControl;Left,Bottom,Width,Height:LongInt):TCustomFilelistBox;
322Function InsertCustomDirectoryListBox(parent:TControl;Left,Bottom,Width,Height:LongInt):TCustomDirectoryListBox;
323Function InsertCustomDriveComboBox(parent:TControl;Left,Bottom,Width,Height:LongInt):TCustomDriveComboBox;
324Function InsertFilterComboBox(parent:TControl;Left,Bottom,Width,Height:LongInt):TCustomFilterComboBox;
325
326Exports
327 TCustomFileListBox, 'User', 'CustomFileListBox.bmp',
328 TCustomDirectoryListBox, 'User', 'CustomDirectoryListBox.bmp';
329
330Exports
331 TCustomDriveComboBox, 'User', 'CustomDriveComboBox.bmp';
332
333Exports
334 TCustomFilterComboBox, 'User', 'CustomFilterComboBox.bmp';
335
336Implementation
337
338Uses
339{$IFDEF OS2}
340 BseDos, OS2Def, DriveInfoUnit,
341 BseDev, BseErr,
342{$ENDIF}
343
344{$IFDEF Win95}
345 WinBase,
346{$ENDIF}
347 Dialogs,
348 ACLStringUtility, ACLUtility, ACLFileUtility, BitmapUtility;
349
350var
351 DriveTypeBitmaps: array[ Low( TDriveType ).. High( TDriveType ) ] of TBitmap;
352 DriveTypeBitmapMasks: array[ Low( TDriveType ).. High( TDriveType ) ] of TBitmap;
353
354const
355 DriveTypeBitmapNames: array[ Low( TDriveType ).. High( TDriveType ) ] of string =
356 (
357 '',
358 'FloppyDrive',
359 'HardDrive',
360 'CDDrive',
361 'NetworkDrive',
362 'RemovableDrive'
363 );
364
365{$R FileImages}
366
367Function InsertCustomFilelistBox(parent:TControl;Left,Bottom,Width,Height:LongInt):TCustomFilelistBox;
368Begin
369 Result.Create(parent);
370 Result.SetWindowPos(Left,Bottom,Width,Height);
371 Result.parent := parent;
372End;
373
374
375Function InsertCustomDirectoryListBox(parent:TControl;Left,Bottom,Width,Height:LongInt):TCustomDirectoryListBox;
376Begin
377 Result.Create(parent);
378 Result.SetWindowPos(Left,Bottom,Width,Height);
379 Result.parent := parent;
380End;
381
382
383Function InsertCustomDriveComboBox(parent:TControl;Left,Bottom,Width,Height:LongInt):TCustomDriveComboBox;
384Begin
385 Result.Create(parent);
386 Result.SetWindowPos(Left,Bottom,Width,Height);
387 Result.parent := parent;
388End;
389
390
391Function InsertFilterComboBox(parent:TControl;Left,Bottom,Width,Height:LongInt):TCustomFilterComboBox;
392Begin
393 Result.Create(parent);
394 Result.SetWindowPos(Left,Bottom,Width,Height);
395 Result.parent := parent;
396End;
397
398// ---------------------------------------------------------------------
399// TCustomFilelistBox
400// ---------------------------------------------------------------------
401
402Procedure TCustomFilelistBox.SetupComponent;
403Begin
404 Inherited SetupComponent;
405
406 Name := 'FileListBox';
407 Sorted := True;
408 FFileType := [ftNormal];
409 Mask := '';
410 Directory := '';
411 ExcludeMask:='';
412End;
413
414
415Procedure TCustomFilelistBox.ItemFocus(Index:LongInt);
416Begin
417 Inherited ItemFocus(Index);
418
419 Change;
420End;
421
422Procedure TCustomFilelistBox.BuildList;
423{$IFDEF OS2}
424Const AttrSet:Array[TFileAttr] Of Word = (faReadOnly,faHidden,faSysFile,0,faDirectory,faArchive,0);
425{$ENDIF}
426{$IFDEF WIN32}
427Const AttrSet:Array[TFileAttr] Of Word = (faReadOnly,faHidden,faSysFile,0,faDirectory,faArchive,faArchive);
428{$ENDIF}
429Var Search:TSearchRec;
430 Status:Integer;
431 Attr:Word;
432 AttrIndex:TFileAttr;
433 S,s1:String;
434 ExcludeList:TStringList;
435 FindIndex:longint;
436 ThisFilter: string;
437 NextFilter: integer;
438Begin
439 FOldDirectory:=FDirectory;
440 FOldMask:=FMask;
441 FOldFileType:=FFileType;
442
443 BeginUpdate;
444 Clear;
445
446 DosErrorAPI( FERR_DISABLEHARDERR );
447
448 Attr := 0;
449 For AttrIndex := Low(TFileAttr) To High(TFileAttr) Do
450 Begin
451 If FFileType * [AttrIndex] <> []
452 Then Attr := Attr Or AttrSet[AttrIndex];
453 End;
454
455 // First make a list of files to exclude...
456 ExcludeList:= TStringList.Create;
457 ExcludeList.Sorted:= true;
458 S:=fExcludeMask;
459 While S<>'' Do
460 Begin
461 NextFilter:=Pos(';',S);
462 If NextFilter<>0 Then
463 Begin
464 ThisFilter:=Copy( S, 1, NextFilter-1 );
465 Delete( S, 1, NextFilter );
466 End
467 Else
468 Begin
469 ThisFilter:=S;
470 S:='';
471 End;
472
473 Status := SysUtils.FindFirst(FDirectory + '\' + ThisFilter, Attr,Search);
474 While Status = 0 Do
475 Begin
476 ExcludeList.Add( Search.Name );
477 Status := SysUtils.FindNext(Search);
478 End;
479 SysUtils.FindClose( Search );
480 End;
481
482 // Now search for files to include...
483 S:=fMask;
484 While S<>'' Do
485 Begin
486 If Pos(';',S)<>0 Then
487 Begin
488 s1:=S;
489 Delete(s1,1,Pos(';',S));
490 SetLength(S,Pos(';',S)-1);
491 End
492 Else s1:='';
493
494 Status := SysUtils.FindFirst(FDirectory + '\' + S, Attr,Search);
495 While Status = 0 Do
496 Begin
497 if not ExcludeList.Find( Search.Name,
498 FindIndex ) then
499 begin
500 If Search.Attr And faDirectory = faDirectory Then
501 Begin
502 Items.Add( '['+ Search.Name +']' );
503 End
504 Else
505 Begin
506 Items.Add( Search.Name );
507 End;
508 end;
509 Status := SysUtils.FindNext(Search);
510 End;
511 SysUtils.FindClose( Search );
512 S:=s1;
513 End;
514
515 DosErrorAPI( FERR_ENABLEHARDERR );
516
517 ExcludeList.Destroy;
518 EndUpdate;
519End;
520
521
522Function TCustomFilelistBox.GetDrive:Char;
523Begin
524 Result := FDirectory[1];
525End;
526
527
528Procedure TCustomFilelistBox.SetDrive(NewDrive:Char);
529Var NewDir:String;
530Begin
531 If UpCase(NewDrive) <> UpCase(Drive) Then
532 Begin
533 {Change To Current Directory At NewDrive}
534 {$I-}
535 GetDir(Ord(UpCase(NewDrive))-Ord('A')+1, NewDir);
536 {$I+}
537 If IOResult = 0 Then SetDirectory(NewDir);
538 End;
539End;
540
541Procedure TCustomFilelistBox.SetDirectory(NewDir:String);
542Var s:String;
543Begin
544 If NewDir = '' Then
545 Begin
546 {$I-}
547 GetDir(0,NewDir);
548 {$I+}
549 End;
550
551 If Pos(':',NewDir)<>2 Then
552 Begin
553 {$I-}
554 GetDir(Ord(UpCase(Drive))-Ord('A')+1,s);
555 {$I+}
556 If (s[length(s)])='\' Then dec(s[0]);
557 If not (NewDir[1] In ['/','\']) Then s:=s+'\';
558 NewDir:=s+NewDir;
559 End;
560
561 If NewDir[Length(NewDir)] = '\' Then SetLength(NewDir,Length(NewDir)-1);
562 If FDirectory=NewDir Then exit;
563 FDirectory := NewDir;
564
565 If Handle<>0 Then BuildList;
566 Change;
567 If FDirList <> Nil Then
568 Begin
569 If uppercase(FDirList.Directory) <> uppercase(Directory)
570 Then FDirList.Directory := Directory;
571 End;
572
573End;
574
575
576Procedure TCustomFilelistBox.SetFileName(NewFile:String);
577Var Dir,Name,Ext:String;
578Begin
579 If GetFileName <> NewFile Then
580 Begin
581 FSplit(NewFile,Dir,Name,Ext);
582 If Dir='' Then
583 Begin
584 ItemIndex := Items.IndexOf(NewFile);
585 Change;
586 End
587 Else
588 Begin
589 SetDirectory(Dir);
590 SetFileName(Name+Ext);
591 End;
592 End;
593End;
594
595
596Function TCustomFilelistBox.GetFileName:String;
597Var idx:LongInt;
598 s:String;
599Begin
600 idx := ItemIndex;
601 If (idx < 0) Or (idx >= Items.Count) Then Result := ''
602 Else Result := Items[ idx ];
603 s:=Directory;
604 If s[Length(s)] In ['\','/'] Then dec(s[0]);
605 If s<>'' Then If Result<>'' Then Result:=s+'\'+Result;
606End;
607
608
609Procedure TCustomFilelistBox.SetMask(NewMask:String);
610Begin
611 If NewMask <> '' Then
612 Begin
613 If FMask=NewMask Then exit;
614 FMask := NewMask
615 End
616 Else
617 Begin
618 If FMask='*' Then exit;
619 FMask := '*';
620 End;
621
622 If Handle<>0 Then BuildList;
623 Change;
624End;
625
626Procedure TCustomFilelistBox.SetExcludeMask(NewMask:String);
627Begin
628 If FExcludeMask=NewMask Then
629 exit;
630 FExcludeMask := NewMask;
631 If Handle<>0 Then BuildList;
632 Change;
633End;
634
635Procedure TCustomFilelistBox.SetFileEdit(NewEdit:TEdit);
636Begin
637 FFileEdit := NewEdit;
638 If FFileEdit <> Nil Then
639 Begin
640 FFileEdit.FreeNotification(Self);
641 If FileName <> '' Then FFileEdit.Caption := FileName
642 Else FFileEdit.Caption := Mask;
643 End;
644End;
645
646
647Procedure TCustomFilelistBox.Notification(AComponent:TComponent;Operation:TOperation);
648Begin
649 Inherited Notification(AComponent,Operation);
650
651 If Operation = opRemove Then
652 If AComponent = FFileEdit Then FFileEdit := Nil;
653End;
654
655
656Procedure TCustomFilelistBox.SetFileType(Attr:TFileType);
657Begin
658 If FFileType <> Attr Then
659 Begin
660 FFileType := Attr;
661 If Handle<>0 Then BuildList;
662 Change;
663 End;
664End;
665
666
667Procedure TCustomFilelistBox.Change;
668Begin
669 If FFileEdit <> Nil Then
670 Begin
671 If FileName <> '' Then FFileEdit.Caption := FileName
672 Else FFileEdit.Caption := Mask;
673
674 FFileEdit.SelectAll;
675 End;
676
677 If FOnChange <> Nil Then FOnChange(Self);
678End;
679
680
681Function TCustomFilelistBox.WriteSCUResource(Stream:TResourceStream):Boolean;
682Begin
683 {don't Write contents To SCU}
684 Result := TControl.WriteSCUResource(Stream);
685End;
686
687Procedure TCustomFilelistBox.SetupShow;
688Begin
689 Inherited SetupShow;
690
691 BuildList;
692End;
693
694Procedure TCustomFilelistBox.Reload;
695Begin
696 StartUpdate;
697 If Handle<>0 Then BuildList;
698 CompleteUpdate;
699End;
700
701// ---------------------------------------------------------------------
702// CustomDirectoryListBox
703// ---------------------------------------------------------------------
704
705const
706 dfSubDir = 256;
707 dfErrorMessage = 512;
708
709Procedure TCustomDirectoryListBox.SetupComponent;
710Begin
711 Inherited SetupComponent;
712
713 Name := 'DirectoryListBox';
714
715 Directory := '';
716
717 Style:=lbOwnerDrawFixed;
718
719 FDriveCombo:= nil;
720
721 FPictureOpen:= TBitmap.Create;
722 FPictureOpen.LoadFromResourceName( 'FolderOpen' );
723 CreateMaskedBitmap( FPictureOpen, FPictureOpenMask, $ff00ff );
724
725 FPictureClosed:= TBitmap.Create;
726 FPictureClosed.LoadFromResourceName( 'FolderClosed' );
727 CreateMaskedBitmap( FPictureClosed, FPictureClosedMask, $ff00ff );
728End;
729
730Destructor TCustomDirectoryListBox.Destroy;
731begin
732 FPictureOpen.Free;
733 FPictureClosed.Free;
734 inherited Destroy;
735end;
736
737Procedure TCustomDirectoryListBox.MeasureItem(Index:LongInt;Var Width,Height:LongInt);
738Begin
739 Inherited MeasureItem(Index,Width,Height);
740 If Height<15 Then Height:=15;
741End;
742
743Procedure TCustomDirectoryListBox.DrawItem( Index: LongInt;
744 rec: TRect;
745 State: TOwnerDrawState );
746Var
747 X,Y,Y1,CX,CY,cx1,cy1:LongInt;
748 S: String;
749 Data: longint;
750 IndentLevel: longint;
751Begin
752 If State * [odSelected] <> [] Then
753 Begin
754 Canvas.Pen.color := clHighlightText;
755 Canvas.Brush.color := clHighlight;
756 End
757 Else
758 Begin
759 Canvas.Pen.color := PenColor;
760 Canvas.Brush.color := color;
761 End;
762 dec( rec.top ); // minor adjustments since we seem to get a slightly
763 inc( rec.left ); // incorrect area to draw on...
764
765 Canvas.FillRect(rec,Canvas.Brush.color);
766
767 X := rec.Left + 2;
768 Y := rec.Bottom + 1;
769 CX := rec.Right - X;
770 CY := rec.Top - Y;
771
772 S := '';
773 Data := 0;
774 if Index <> -1 then
775 begin
776 S := Items[ Index ];
777 Data:= longint( Items.Objects[ Index ] );
778 end;
779 IndentLevel:= Data and 255;
780
781 inc( X, IndentLevel * 5 );
782
783 Y1:=rec.Bottom+((CY- FPictureOpen.Height ) Div 2);
784 If Y1 < rec.Bottom+1 Then
785 Y1 := rec.Bottom+1;
786 inc(Y1);
787
788 if ( Data and dfErrorMessage ) > 0 Then
789 // error message - draw nothing
790
791 else if ( Data and dfSubDir ) > 0 Then
792 // subdir
793 DrawClosedFolder( X, Y1 )
794 else
795 // parent dir
796 DrawOpenFolder( X, Y1 );
797
798 inc( X, 5 );
799
800 Canvas.GetTextExtent(S,cx1,cy1);
801 Y := Y + ((CY - cy1) Div 2);
802 If Y < rec.Bottom Then
803 Y := rec.Bottom;
804 Canvas.Brush.Mode := bmTransparent;
805 Canvas.TextOut(X,Y,S);
806 Canvas.Brush.Mode := bmOpaque;
807End;
808
809Procedure TCustomDirectoryListBox.DrawOpenFolder( Var X: longint; Y: LongInt );
810Var
811 SaveBrushColor,SavePenColor:TColor;
812Begin
813 SaveBrushColor:=Canvas.Brush.Color;
814 SavePenColor:=Canvas.Pen.Color;
815
816 DrawMaskedBitmap( FPictureOpen,
817 FPictureOpenMask,
818 Canvas,
819 X, Y );
820
821 if FPictureOpen <> nil then
822 inc( X, FPictureOpen.Width );
823
824 Canvas.Brush.Color:=SaveBrushColor;
825 Canvas.Pen.Color:=SavePenColor;
826End;
827
828Procedure TCustomDirectoryListBox.DrawClosedFolder( Var X: longint; Y: LongInt );
829Var
830 SaveBrushColor,SavePenColor:TColor;
831Begin
832 SaveBrushColor:=Canvas.Brush.Color;
833 SavePenColor:=Canvas.Pen.Color;
834
835 DrawMaskedBitmap( FPictureClosed,
836 FPictureClosedMask,
837 Canvas,
838 X, Y );
839
840 if FPictureClosed <> nil then
841 inc( X, FPictureClosed.Width );
842
843 Canvas.Brush.Color:=SaveBrushColor;
844 Canvas.Pen.Color:=SavePenColor;
845End;
846
847Procedure TCustomDirectoryListBox.ItemSelect(Index:LongInt);
848Var
849 S: String;
850 Data: longint;
851 FullPath: string;
852Begin
853 If (Index < 0) Or (Index > Items.Count-1) Then Exit;
854
855 Data := longint( Items.Objects[ Index ] );
856 if ( Data and dfErrorMessage ) > 0 Then
857 Exit; // error item
858
859 FullPath:= Items[ Index ];
860 dec( Index );
861 while Index >= 0 do
862 begin
863 S := Items[ Index ];
864 Data:= longint( Items.Objects[ Index ] );
865 if ( Data and dfSubDir ) = 0 then
866 FullPath:= AddSlash( S ) + FullPath;
867 dec( Index );
868 end;
869
870 Directory:= FullPath;
871
872 Inherited ItemSelect(Index);
873End;
874
875Procedure TCustomDirectoryListBox.BuildList;
876Var
877 S: String;
878 Search: TSearchRec;
879 Status: Integer;
880 Path: string;
881 SubDirs: TStringList;
882 IndentLevel: longint;
883 PathSoFar: string;
884Begin
885 Screen.Cursor := crHourGlass;
886 BeginUpdate;
887
888 IndentLevel:= 0;
889
890 // Add Drive
891 Items.Clear;
892 Items.AddObject( Drive+':\', pointer( IndentLevel ) );
893
894 DosErrorAPI( FERR_DISABLEHARDERR );
895
896 // Add all subdirs
897 Path := Copy( Directory, 4, 255 );
898 PathSoFar := Copy( Directory, 1, 3 );
899 While Path <> '' Do
900 Begin
901 inc( IndentLevel );
902 S:= ExtractNextValue( Path, '\' );
903
904 if not DirectoryExists( PathSoFar + S ) then
905 begin
906 // directory specified doesn't exist.
907 FDirectory := PathSoFar;
908 break;
909 end;
910 Items.AddObject( S, pointer( IndentLevel ) );
911 PathSoFar := PathSoFar + S + '\';
912 End;
913
914 ItemIndex:= Items.Count - 1;
915
916 inc( IndentLevel );
917
918 SubDirs:= TStringList.Create;
919
920 Status := SysUtils.FindFirst( AddSlash( Directory ) + '*.*', faDirectory, Search);
921 While Status = 0 Do
922 Begin
923 S := Search.Name;
924 If Search.Attr And faDirectory = faDirectory Then
925 Begin
926 {avoid .. In Mainpath}
927 If ( S <> '.' )
928 and ( S <> '..' ) Then
929 SubDirs.AddObject( S, pointer( IndentLevel + dfSubDir ) );
930 End;
931 Status := SysUtils.FindNext( Search );
932 End;
933 if Status <> - ERROR_NO_MORE_FILES then
934 SubDirs.AddObject( '[Error reading directories]',
935 pointer( 1 + dfErrorMessage ) );
936
937 SysUtils.FindClose( Search );
938
939 DosErrorAPI( FERR_ENABLEHARDERR );
940
941 SubDirs.Sort;
942 Items.AddStrings( SubDirs );
943 SubDirs.Destroy;
944
945 EndUpdate;
946 Refresh;
947 Screen.Cursor := crDefault;
948End;
949
950
951Procedure TCustomDirectoryListBox.SetDirectory(NewDir:String);
952Var
953 s: String;
954Begin
955 If NewDir = '' Then
956 Begin
957 {$I-}
958 // Get current drive
959 GetDir(0,NewDir);
960 {$I+}
961 End;
962
963 If Pos(':',NewDir)<>2 Then
964 Begin
965 {$I-}
966 // Get current directory on specified drive
967 GetDir(Ord(UpCase(Drive))-Ord('A')+1,s);
968 {$I+}
969 S:= RemoveSlash( S );
970 S:= AddSlash( S );
971 NewDir:=s+NewDir;
972 End;
973
974 NewDir:= RemoveSlash( NewDir );
975
976 FDirectory := NewDir;
977 if Handle <> 0 then
978 BuildList;
979
980 If FDriveCombo <> Nil Then
981 Begin
982 If UpCase( FDriveCombo.Drive ) <> UpCase( Drive ) Then
983 FDriveCombo.Drive := Drive;
984 End;
985
986 Change;
987
988End;
989
990
991Procedure TCustomDirectoryListBox.SetDrive(NewDrive:Char);
992Var NewDir:String;
993Begin
994 If UpCase(NewDrive) <> UpCase(Drive) Then
995 Begin
996 {Change To Current Directory At NewDrive}
997 {$I-}
998 GetDir(Ord(UpCase(NewDrive))-Ord('A')+1, NewDir);
999 {$I+}
1000 If IOResult = 0 Then SetDirectory(NewDir);
1001 End;
1002End;
1003
1004
1005Function TCustomDirectoryListBox.GetDrive:Char;
1006Begin
1007 Result := FDirectory[1];
1008End;
1009
1010
1011Procedure TCustomDirectoryListBox.SetDirLabel(ALabel:TLabel);
1012Begin
1013 FDirLabel := ALabel;
1014 If FDirLabel <> Nil Then
1015 Begin
1016 FDirLabel.FreeNotification(Self);
1017 FDirLabel.Caption := FDirectory;
1018 End;
1019End;
1020
1021
1022Procedure TCustomDirectoryListBox.SetFileListBox(AFileList:TCustomFileListBox);
1023Begin
1024 If FFileList <> Nil Then FFileList.FDirList := Nil;
1025 FFileList := AFileList;
1026 If FFileList <> Nil Then
1027 Begin
1028 FFileList.FDirList := Self;
1029 FFileList.FreeNotification(Self);
1030 End;
1031End;
1032
1033
1034Procedure TCustomDirectoryListBox.Notification(AComponent:TComponent;Operation:TOperation);
1035Begin
1036 Inherited Notification(AComponent,Operation);
1037
1038 If Operation = opRemove Then
1039 Begin
1040 If AComponent = FFileList Then
1041 FFileList := Nil;
1042 If AComponent = FDirLabel Then
1043 FDirLabel := Nil;
1044 End;
1045End;
1046
1047
1048Procedure TCustomDirectoryListBox.Change;
1049Begin
1050 If FDirLabel <> Nil Then
1051 FDirLabel.Caption := FDirectory;
1052 If FFileList <> Nil Then
1053 FFileList.Directory := FDirectory;
1054
1055 If FOnChange <> Nil Then FOnChange(Self);
1056End;
1057
1058Function TCustomDirectoryListBox.WriteSCUResource(Stream:TResourceStream):Boolean;
1059Begin
1060 {don't Write contents To SCU}
1061 Result := TControl.WriteSCUResource(Stream);
1062End;
1063
1064Procedure TCustomDirectoryListBox.SetupShow;
1065Begin
1066 Inherited SetupShow;
1067
1068 BuildList;
1069End;
1070
1071Procedure TCustomDirectoryListBox.SetPictureClosed( NewBitmap: TBitmap );
1072Begin
1073 StoreBitmap( FPictureClosed, FPictureClosedMask, NewBitmap );
1074 Invalidate;
1075End;
1076
1077Procedure TCustomDirectoryListBox.SetPictureOpen( NewBitmap: TBitmap );
1078Begin
1079 StoreBitmap( FPictureOpen, FPictureOpenMask, NewBitmap );
1080 Invalidate;
1081End;
1082
1083// ---------------------------------------------------------------------
1084// TCustomDriveComboBox
1085// ---------------------------------------------------------------------
1086
1087Procedure TCustomDriveComboBox.SetupComponent;
1088Var
1089 DriveNumber: longint;
1090 CurrentDir: string;
1091
1092 DriveString: String;
1093 DriveType: TDriveType;
1094 DriveLabel: string;
1095
1096Begin
1097 Inherited SetupComponent;
1098
1099 Name := 'DriveComboBox';
1100 Style := csDropDownList;
1101 sorted := False;
1102
1103 OwnerDraw := true;
1104 OnDrawItem := DrawItem;
1105
1106 {Fill Drive Combo}
1107
1108 For DriveNumber := MinDriveNumber To MaxDriveNumber Do
1109 begin
1110 DriveType := GetDriveType( DriveNumber );
1111 DriveString := Chr( DriveNumber + Ord( 'A' ) - 1 ) + ': ';
1112
1113 if DriveType <> dtNone then
1114 begin
1115 if DriveType = dtHard then
1116 begin
1117 try
1118 DriveLabel := GetVolumeLabel( DriveNumberToLetter( DriveNumber ) );
1119 DriveString := DriveString + DriveLabel;
1120 except
1121 end;
1122 end;
1123
1124 if DriveType = dtNetwork then
1125 begin
1126 if not Designed then
1127 begin
1128 DriveString := DriveString
1129 + LowerCase( GetNetworkDriveRemotePath( DriveNumber ) );
1130 end;
1131 end;
1132
1133 Items.AddObject( DriveString, TObject( DriveType ) );
1134 end;
1135 end;
1136
1137 // Get current drive
1138 try
1139 GetDir( 0, CurrentDir );
1140 Drive := CurrentDir[ 1 ];
1141 except
1142 on EInOutError do
1143 // Current drive inaccessible
1144 Drive := GetBootDrive;
1145 end;
1146End;
1147
1148Procedure TCustomDriveComboBox.DrawItem( Canvas: TCanvas;
1149 S: string;
1150 Data: TObject;
1151 rec: TRect;
1152 State: TOwnerDrawState );
1153Var
1154 X,Y,CX,CY: LongInt;
1155 DriveType: TDriveType;
1156 DrivePath: string;
1157 TypeBitmap: TBitmap;
1158 TypeBitmapMask: TBitmap;
1159 TextHeight: longint;
1160 TextWidth: longint;
1161 TextBottom: longint;
1162 BitmapBottom: longint;
1163Begin
1164 If odSelected in State Then
1165 Begin
1166 Canvas.Pen.color := clHighlightText;
1167 Canvas.Brush.color := clHighlight;
1168 End
1169 Else
1170 Begin
1171 Canvas.Pen.color := PenColor;
1172 Canvas.Brush.color := Color;
1173 End;
1174 Canvas.FillRect(rec,Canvas.Brush.color);
1175
1176 X := rec.Left + 2;
1177 Y := rec.Bottom + 1;
1178 CX := rec.Right - X;
1179 CY := rec.Top - Y;
1180
1181 DrivePath := Copy( S, 1, 2 ); // "a:"
1182 Delete( S, 1, 3 ); // delete "a: "
1183
1184 DriveType := TDriveType( Data );
1185 TypeBitmap := DriveTypeBitmaps[ DriveType ];
1186 TypeBitmapMask := DriveTypeBitmapMasks[ DriveType ];
1187
1188 // see how high the text is, and the widest (W)
1189 Canvas.GetTextExtent( 'W: ', TextWidth, TextHeight );
1190
1191 TextBottom := Y + ( CY - TextHeight ) div 2;
1192 if TextBottom < rec.Bottom then
1193 TextBottom := rec.Bottom;
1194
1195 BitmapBottom := Y + ( CY - TypeBitmap.Height ) div 2;
1196 if BitmapBottom < rec.Bottom then
1197 BitmapBottom := rec.Bottom;
1198
1199 // Draw drive type image
1200 DrawMaskedBitmap( TypeBitmap, TypeBitmapMask,
1201 Canvas,
1202 X, BitmapBottom );
1203 inc( X, TypeBitmap.Width );
1204 inc( X, 5 );
1205
1206 // Draw drive letter
1207 Canvas.TextOut( X, TextBottom, DrivePath );
1208 inc( X, TextWidth );
1209
1210 Canvas.TextOut( X, TextBottom, S );
1211end;
1212
1213Procedure TCustomDriveComboBox.ItemSelect(Index:LongInt);
1214Begin
1215 Inherited ItemSelect(Index);
1216
1217 Change;
1218End;
1219
1220
1221Procedure TCustomDriveComboBox.Change;
1222var
1223 DriveLabel: string;
1224 DriveValid: boolean;
1225 DriveType: TDriveType;
1226Begin
1227 {determine volume label}
1228 If ItemIndex <> -1 Then
1229 Begin
1230 DriveValid := false;
1231 DriveType := TDriveType( Items.Objects[ ItemIndex ] );
1232 while not DriveValid do
1233 begin
1234 try
1235 Screen.Cursor := crHourGlass;
1236
1237 DriveLabel := GetVolumeLabel( Text[1] );
1238 DriveValid := true;
1239
1240 if DriveType <> dtNetwork then
1241 begin
1242 Text := Copy( Text, 1, 3 ) + DriveLabel;
1243 Items[ ItemIndex ] := Text;
1244 end;
1245 except
1246 on E: EInOutError do
1247 begin
1248 DriveValid := false;
1249 Screen.Cursor := crDefault;
1250 if MessageBox( e.Message,
1251 mtError,
1252 [ mbRetry, mbCancel ] ) = mrCancel then
1253 begin
1254 // Cancelling: back to last.
1255 // Actually it could be that the original drive is now
1256 // invalid... :|
1257 if ItemIndex = FLastIndex then
1258 begin
1259 // we were trying to re-read the
1260 // current drive, and it failed,
1261 // and the user doesn't want to retry,
1262 // so go back to boot drive.
1263 SetDrive( GetBootDrive );
1264 Screen.Cursor := crDefault;
1265 Exit;
1266 end;
1267 ItemIndex := FLastIndex;
1268 DriveValid := true;
1269 end;
1270 end;
1271 end;
1272 end;
1273 End;
1274 Screen.Cursor := crDefault;
1275
1276 FLastIndex := ItemIndex;
1277
1278 If FDirList <> Nil Then FDirList.Drive := Drive;
1279
1280 If FOnChange <> Nil Then FOnChange(Self);
1281
1282End;
1283
1284Function TCustomDriveComboBox.GetDrive:Char;
1285Begin
1286 Result := Text[1];
1287End;
1288
1289Procedure TCustomDriveComboBox.SetDrive(NewDrive:Char);
1290Var S:String;
1291 T:LongInt;
1292 {$IFDEF Win95}
1293 sernum,complen,Flags:LongWord;
1294 FileSystem,volname:cstring;
1295 {$ENDIF}
1296Begin
1297 NewDrive := UpCase(NewDrive);
1298 If UpCase(Drive) = NewDrive Then Exit;
1299
1300 // Find the drive in the list
1301 For T := 0 To Items.Count-1 Do
1302 Begin
1303 S := Items.Strings[T];
1304 If UpCase(S[1]) = NewDrive Then
1305 Begin
1306 // Found
1307 ItemIndex := T;
1308 break;
1309 End;
1310 End;
1311End;
1312
1313
1314Procedure TCustomDriveComboBox.SetDirListBox(ADirList:TCustomDirectoryListBox);
1315Begin
1316 If FDirList <> Nil Then FDirList.FDriveCombo := Nil;
1317 FDirList := ADirList;
1318 If FDirList <> Nil Then
1319 Begin
1320 FDirList.FDriveCombo := Self;
1321 FDirList.FreeNotification(Self);
1322 End;
1323End;
1324
1325
1326Procedure TCustomDriveComboBox.Notification(AComponent:TComponent;Operation:TOperation);
1327Begin
1328 Inherited Notification(AComponent,Operation);
1329
1330 If Operation = opRemove Then
1331 If AComponent = FDirList Then
1332 FDirList := Nil;
1333End;
1334
1335
1336Function TCustomDriveComboBox.WriteSCUResource(Stream:TResourceStream):Boolean;
1337Begin
1338 {don't Write contents To SCU}
1339 Result := TControl.WriteSCUResource(Stream);
1340End;
1341
1342
1343// ---------------------------------------------------------------------
1344// TCustomFilterComboBox
1345// ---------------------------------------------------------------------
1346
1347Procedure TCustomFilterComboBox.SetupComponent;
1348Begin
1349 Inherited SetupComponent;
1350
1351 Name := 'FilterComboBox';
1352 Style := csDropDownList;
1353 sorted := False;
1354
1355 FFilter := LoadNLSStr(SAllFiles)+' (*.*)|*.*';
1356 FMaskList.Create;
1357End;
1358
1359
1360Procedure TCustomFilterComboBox.SetupShow;
1361Begin
1362 Inherited SetupShow;
1363
1364 BuildList;
1365End;
1366
1367
1368Destructor TCustomFilterComboBox.Destroy;
1369Begin
1370 FMaskList.Destroy;
1371 FMaskList := Nil;
1372
1373 Inherited Destroy;
1374End;
1375
1376
1377Procedure TCustomFilterComboBox.ItemSelect(Index:LongInt);
1378Begin
1379 Inherited ItemSelect(Index);
1380
1381 Text := Items[Index];
1382 Change;
1383End;
1384
1385
1386Procedure TCustomFilterComboBox.Change;
1387Begin
1388 If FFileList <> Nil Then FFileList.Mask := Mask;
1389
1390 If FOnChange <> Nil Then FOnChange(Self);
1391End;
1392
1393
1394Procedure TCustomFilterComboBox.BuildList;
1395Var AMask,AFilter:String;
1396 S:String;
1397 P:Integer;
1398Begin
1399 BeginUpdate;
1400 Clear;
1401 FMaskList.Clear;
1402
1403 S := FFilter;
1404 P := Pos('|',S);
1405 While P > 0 Do
1406 Begin
1407 AFilter := Copy(S,1,P-1);
1408 Delete(S,1,P);
1409 P := Pos('|',S);
1410 If P > 0 Then
1411 Begin
1412 AMask := Copy(S,1,P-1);
1413 Delete(S,1,P);
1414 End
1415 Else
1416 Begin
1417 AMask := S;
1418 S := '';
1419 End;
1420 Items.Add(AFilter);
1421 FMaskList.Add(AMask);
1422 P := Pos('|',S);
1423 End;
1424 EndUpdate;
1425 if Items.Count > 0 then
1426 ItemIndex := 0;
1427End;
1428
1429
1430Procedure TCustomFilterComboBox.SetFilter(NewFilter:String);
1431Begin
1432 If FFilter <> NewFilter Then
1433 Begin
1434 FFilter := NewFilter;
1435 BuildList;
1436 Change;
1437 End;
1438End;
1439
1440
1441Procedure TCustomFilterComboBox.SetFilelistBox(AFileList:TCustomFilelistBox);
1442Begin
1443 If FFileList <> Nil Then FFileList.FFilterCombo := Nil;
1444 FFileList := AFileList;
1445 If FFileList <> Nil Then
1446 Begin
1447 FFileList.FFilterCombo := Self;
1448 FFileList.FreeNotification(Self);
1449 End;
1450End;
1451
1452
1453Procedure TCustomFilterComboBox.Notification(AComponent:TComponent;Operation:TOperation);
1454Begin
1455 Inherited Notification(AComponent,Operation);
1456
1457 If Operation = opRemove Then
1458 If AComponent = FFileList Then FFileList := Nil;
1459End;
1460
1461
1462Function TCustomFilterComboBox.GetMask:String;
1463Var idx:LongInt;
1464Begin
1465 idx := ItemIndex;
1466 If (idx < 0) Or (idx >= FMaskList.Count) Then Result := '*.*'
1467 Else Result := FMaskList[idx];
1468End;
1469
1470
1471Function TCustomFilterComboBox.WriteSCUResource(Stream:TResourceStream):Boolean;
1472Begin
1473 {don't Write contents To SCU}
1474 Result := TControl.WriteSCUResource(Stream);
1475End;
1476
1477var
1478 DriveType: TDriveType;
1479 ResourceName: string;
1480 Bitmap: TBitmap;
1481 MaskBitmap: TBitmap;
1482Initialization
1483 RegisterClasses( [ TCustomDriveComboBox,
1484 TCustomDirectoryListBox,
1485 TCustomFilelistBox,
1486 TCustomFilterComboBox ] );
1487
1488 for DriveType := Low( TDriveType ) to High( TDriveType ) do
1489 begin
1490 if DriveType = dtNone then
1491 begin
1492 DriveTypeBitmaps[ DriveType ] := nil;
1493 DriveTypeBitmapMasks[ DriveType ] := nil;
1494 continue; // don't load a bitmap for the none
1495 end;
1496
1497 ResourceName := DriveTypeBitmapNames[ DriveType ];
1498
1499 Bitmap:= TBitmap.Create;
1500 Bitmap.LoadFromResourceName( ResourceName );
1501 DriveTypeBitmaps[ DriveType ] := Bitmap;
1502
1503 MaskBitmap:= TBitmap.Create;
1504 CreateMaskedBitmap( Bitmap, MaskBitmap, $ff00ff );
1505 DriveTypeBitmapMasks[ DriveType ] := MaskBitmap;
1506 end;
1507
1508finalization
1509
1510 for DriveType := Low( TDriveType ) to High( TDriveType ) do
1511 begin
1512 if DriveTypeBitmaps[ DriveType ] <> nil then
1513 DriveTypeBitmaps[ DriveType ].Destroy;
1514
1515 if DriveTypeBitmapMasks[ DriveType ] <> nil then
1516 DriveTypeBitmapMasks[ DriveType ].Destroy;
1517 end;
1518
1519End.
1520
1521
Note: See TracBrowser for help on using the repository browser.