source: trunk/Components/CustomFileControls.pas@ 189

Last change on this file since 189 was 188, checked in by RBRi, 18 years ago

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