[Back to DIRS SWAG index] [Back to Main SWAG index] [Original]

    {============================================================================}
    { PickFile.Pas - A unit that returns a filename selected by the user using    }
    {                the point and shoot method.                                  }
    {                You are free to modify and freely distribute the following   }
    {                source code in any way you feel neccessary.                  }
    {                I plan on using it in some of my database programs in order  }
    {                for the user to select a databases for Him/Her to use.       }
    { Author : Jim Luckas (76630,370)                                             }
    {                                                                             }
    { P.S. this is my first attempt at TP V4.0 (What a wonderfull experiance!)    }
    {=============================================================================}

    unit pickfile;

    interface
    uses dos,crt;
    {$I-,S-,V-}

    Const
      Shadow   = TRUE;
      NoShadow = FALSE;

    Var Picked: Boolean; {True if a file was picked}

    Function FPick(Path          : PathStr;
                   BorderColor,WinColor,
                   TopX,TopY,Deep: Byte;
                   Shadow        : Boolean ) : PathStr;

    implementation

    type S_Type = string[13];

    Function FAttr(path : PathStr) : Byte;
      var info: SearchRec;
      begin
        FindFirst(path,Directory,info);
        if DosError= 0 then
          FAttr := info.attr
        else
          FAttr := 0;
        end;

    {-----------------------------------------------------------------------------}
    { This is the Function that you call from your main program.                  }
    { Path        = Search Path example. '*.pas'                                  }
    { Deep        = Maximum number of file names in the box.                      }
    { Shadow      = Should the box have a shadow?                                 }
    { This function returns the filename without the extension.                   }
    { Sample call : WriteLn(FPick('*.pas',White,White+Blue*16,10,10,23,Shadow))   }
    {-----------------------------------------------------------------------------}

    {--------------------------- Globals to be used by program -------------------}

    Const
      FNameLen = 13;
      BoxWidth    = FNameLen + 2;
      ShadowWidth = BoxWidth + 2;

    Type
      Stack_Ptr  = String[FNameLen];

    Var
      HeapTop   : ^Integer;
      PtrArray  : Array[1..256] of ^Stack_Ptr;
      NuOfFiles,
      BotY,RecNum,Ypos : Byte;

    Function FPick(Path          : PathStr;
                   BorderColor,WinColor,
                   TopX,TopY,Deep: Byte;
                   Shadow        : Boolean ) : PathStr;

        Var
          SearchDir  : DirStr;
          SearchName : NameStr;
          SearchExt  : ExtStr;

    {-----------------------------------------------------------------------------}
    { Return the last directory name in the string                                }
    {-----------------------------------------------------------------------------}

        Function LastDir(p:DirStr):DirStr;
        var i : integer;
            disk : string[5];
        begin
          i := length(p);
          if p[i]='\' then begin
            dec(i);
            p[0] := chr(i);
          end;
          while (i>0) and not (p[i] IN ['\',':']) do dec(i);
          if (i>1) and (p[2]=':') then
            disk := p[1]+':'
          else
            disk := '';
          {
          if p[i]='\' then
            disk := disk + ' ..\';
          }
          LastDir := disk + Copy(p,i+1,255);
        end;

    {-----------------------------------------------------------------------------}
    { Draw the Display Box for the filenames                                      }
    {-----------------------------------------------------------------------------}

        Procedure Draw_Frame;
        begin
          If NuOfFiles > (Deep-TopY) then           {<- Decide How   }
            BotY := Deep                            {   Long to make }
          else BotY := (TopY + 1) + NuOfFiles;      {   Display Box  }
          If Shadow then                            {<- Check to see if  }
            Begin                                       {   we want a shodow }
              Window(TopX+1,TopY+1,TopX+ShadowWidth,BotY + 1); {<- Window the       }
              TextAttr := $07;                          {   shadow image     }
              ClrScr;                                   {   and clear it     }
            end;
          TextAttr := BorderColor;                   {<- Set the Frame color }
          Window(TopX,TopY,TopX+BoxWidth,BotY+1);    {<- Window the file box }
          Inc(TopY); dec(BotY);
          Write('ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿');                    {     Now     }
          GotoXY(3,1);Write(LastDir(SearchDir));
          GotoXY(1,2);
          For Ypos := TopY to BotY do                   {   Draw the  }
            Write('³              ³');                  {     Box     }
          Write('ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ');                    {    image    }
          Inc(TopX);
          Deep := BotY - TopY;                       {<- Change to inside depth }
          GotoXY(6,Deep+3);
          If NuOfFiles > Deep+1 then                 {<- Let the user Know   }
            Write(' more ');                         {   theres more to come }
        end;

    {-----------------------------------------------------------------------------}
    { Store the FileNames in memory for now                                       }
    {-----------------------------------------------------------------------------}

      Function Get_Files : Boolean;
        Var
          DirInfo : SearchRec;                      { Turbo's FileName Rec }

        Procedure AddFile(name:S_Type);
          begin
            inc(NuOfFiles);                       {<- Increment File Counter }
            New(PtrArray[NuOfFiles]);             {<- Get new pointer }
            PtrArray[NuOfFiles]^ := name;         {<- Store the FileName }
          end;

        begin
          NuOfFiles := 0;                           {<- Set Number of Files to 0 }
          FindFirst(SearchDir+Path,Archive, DirInfo);
          Get_Files := True;                        {<- Set Return to True }
          If DosError IN [0,18] then begin          {<- Check to see if any files }
            While DosError = 0 do
              begin
                AddFile(DirInfo.name);
                FindNext(DirInfo);
              end;
            FindFirst(SearchDir+'*.*',Directory, DirInfo);
            If DosError=0 then begin                {<- Check to see if any files }
              While DosError = 0 do
                begin
                  with DirInfo do
                    if (attr=Directory) and (name<>'.') then
                      AddFile(name+'\');
                  FindNext(DirInfo);                    {<- Thanks Again }
                end
             end {if}
            else Get_Files := False;            {<- If no files found Return False }
           end {if}
          else Get_Files := False;            {<- If no files found Return False }
        end;

    {-----------------------------------------------------------------------------}
    { Function that returns a parsed file name. exp.(Test.pas would return Test)  }
    {-----------------------------------------------------------------------------}

      Function ParsedFile( FileToParse : S_Type) : S_Type;   { File name Passed }
        var d: DirStr;
            n: NameStr;
            x: ExtStr;
        begin
          if FileToParse[length(FileToParse)]='\' then
            ParsedFile := FileToParse
          else begin
            FSplit(FileToParse,d,n,x);
            while length(n)<SizeOf(NameStr)-1 do n := n + ' ';
            ParsedFile := n+x;                   {<- Return Parsed FileName }
          end;
        end;

    {-----------------------------------------------------------------------------}
    { Draw the initial Display of FileNames                                       }
    {-----------------------------------------------------------------------------}

      Procedure Draw_Files;
        begin
          Window(TopX,TopY,TopX+FNameLen,BotY); {<- First we need to Clear }
          TextAttr := WinColor;              {   The Display box to our }
          ClrScr;                            {   selected color         }
          For RecNum := 1 to deep+1 do       {<- Fill Display to Bottom }
            begin
              GotoXY(2,RecNum);
              Write(ParsedFile(PtrArray[RecNum]^));          {<- Write FileName }
            end;
          Window(1,1,80,25);                 {<- Set to default window }
        end;

    {-----------------------------------------------------------------------------}
    { Procedure to scroll window                                                  }
    {-----------------------------------------------------------------------------}
      Procedure Scroll(Direction : Char;
                       X,Y,Width,Deep,Lines,Attr : Byte);
        Var
          Reg : Registers;
        begin
          dec(X);                                     { Assembly  }
          dec(Y);                                     { is not    }
          inc(Deep,Y);                                { one of my }
          inc(Width,X);                               { favorite  }
          If Direction = 'D' then                     { things    }
            Reg.ah := 7                               { But must  }
          else Reg.ah := 6;                           { be done   }
          Reg.al := Lines;                            { sometimes }
          Reg.bh := Attr;                             { to save   }
          Reg.ch := Y;                                { on code   }
          reg.cl := X;
          reg.dh := Deep;
          Reg.dl := Width ;
          Intr(16,Reg);
        end;

    {-----------------------------------------------------------------------------}
    { Here's we we actually start to pick the FileName                            }
    {-----------------------------------------------------------------------------}

      Procedure Pick_File;
        Const FileNameLen = FNameLen + 1;
        Var CH       : Char;
            filename : String[FileNameLen];
            i        : Integer;
        begin
          Ypos := TopY;                             {<- Start selection at top }
          RecNum := 1;                              {<- and with the First file }
          repeat
              GotoXY(TopX,Ypos);
              TextAttr := $70;                      {<- HighLight attributte }
              For i := 1 to FileNameLen do
                FileName[i] := ' ';                 {<- Blankfill FileName }
              FileName[0] := chr(FileNameLen);
              Insert(ParsedFile(PtrArray[RecNum]^),FileName,2);
              Write(FileName);                      {<- Now Write HighLight Bar }
              CH := ReadKey;                        {<- Wait for Keystroke }
              If CH = #0 then                       {<- Is it an extended  }
                CH := ReadKey;                      {<- If so Read second Half }
              GotoXY(TopX,Ypos);                    {<- Rewrite FileName }
              TextAttr := WinColor;                 {   in Normal        }
              Write(FileName);                      {   Attributte       }
              Case CH of
                #80 : begin                         {<- Down Arrow Key }
                        inc(Ypos);
                        inc(RecNum);
                      end;
                #72 : Begin                         {<- Up Arrow Key }
                        dec(Ypos);
                        dec(RecNum);
                      end;
                #27 : PtrArray[RecNum]^ := '';      {<- If ESC the Return Null }
              end;
              If Ypos > BotY then                   {<- Did we reach the }
                begin                               {   Bottom of the    }
                  dec(Ypos);                        {   Display and need }
                  If RecNum <= NuOfFiles then       {   to Scroll Up     }
                    Scroll('U',TopX,TopY,FNameLen,deep,1,WinColor)
                  else RecNum := NuOfFiles;
                end;
              If Ypos < TopY then                   {<- Did we reach the }
                begin                               {   Top of the       }
                  inc(Ypos);                        {   Display and need }
                  If RecNum > 0 then                {   to Scroll Down   }
                    Scroll('D',TopX,TopY,FNameLen,Deep,1,WinColor)
                  Else RecNum := 1;
                end;
            until (CH = #13) or (CH = #27);      {<- Break out If Return or Esc }
          end;

    {-----------------------------------------------------------------------------}
    { This is where main function FPick Starts                              }
    {-----------------------------------------------------------------------------}

    var SelectionMade : Boolean;
        oldDeep,oldX,oldY : Integer;
        oldWind : record
          x,y     : integer;
          attr    : byte;
          max,min : word;
          end;
        DeepX,DeepY : Integer;

    begin
      if Deep<1 then Deep := 1;     {Minimum value}
      {Change Deep to a screen position}
        Deep := Deep + TopY + 2;
        if Shadow then
          DeepY := ShadowWidth - BoxWidth
        else
          DeepY:= 0;
        if Deep+DeepY>hi(WindMax) then begin {adjust to end of screen}
          Deep := hi(WindMax)-DeepY;
          if Deep-TopY < 2 then begin {not enough room!}
            FPick := '';
            DosError := 0;
            Exit;
          end;
        end;
      DeepX := TopX + BoxWidth + DeepY;
      DeepY := Deep + DeepY;
      oldDeep := Deep;
      oldX := TopX;  oldY := TopY;
      with oldWind do begin
        x := WhereX;     y := WhereY;
        attr := TextAttr;
        min := WindMin;  max := WindMax;
      end;
      SelectionMade := FALSE;
      FSplit(FExpand(Path),SearchDir,SearchName,SearchExt);
      repeat
        Picked := FALSE;
        Path := SearchName+SearchExt;
        Mark(HeapTop);                                {<- Mark HeapTop             }
        If Get_Files then                             {<- if Files Found Continue  }
          begin
            Draw_Frame;                               {<- Draw the Display Frame   }
            Draw_Files;                               {<- Fill Display with Files  }
            Pick_File;                                {<- Pick a FileName          }
            path := PtrArray[RecNum]^;
            SelectionMade := (path='');
            if SelectionMade then
              path := SearchDir
            else begin
              path := FExpand(SearchDir + path);
              if path[length(path)]='\' then
                SearchDir := path
              else begin
                SelectionMade := TRUE;
                Picked        := TRUE;
              end;
            end;
          end
        else begin
          path := '';                                 {<- No Files Found Ret ''   }
          SelectionMade := TRUE;
        end;
        Release(HeapTop);                             {<- Release the memory used  }
        {Restore the input parameters}
          TopX := oldX;  TopY := oldY;
          Deep := oldDeep;
        {Clear up the screen}
          Window(TopX,TopY,DeepX,DeepY);
          TextAttr := oldWind.attr;
          GotoXY(1,1);
          ClrScr;
      until SelectionMade;
      {Restore the screen}
        with oldWind do begin
          Window(lo(min)+1,hi(min)+1,lo(max)+1,hi(max)+1);
          GotoXY(x,y);
          TextAttr := Attr;
        end;
      FPick := path;
    end;

    Begin
    End.

    { -------------------   DEMO PROGRAM --------------- }

    {--------------------------- Demo for PickFile.pas ---------------------------}
    {                For a better description peruse pickfile.pas                 }
    {-----------------------------------------------------------------------------}
    { PickFile.tpu    - Turbo unit for selecting a file from the directory }
    { PFdemo.pas      - This pas file to demonstarate PickFile             }
    { PickFile.pas    - The source for PickFile.tpu.                       }
    { All yours to use as you wish.                                        }
    {                                                                      }
    { Function FPick (Path        : PathStr;                               }
    {                 BorderColor,WindowColor,                             }
    {                 TopX,TopY,BotY,Shadow : Byte ) : PathStr;            }
    { Shadow  1=yes 0=no                                                   }
    {----------------------------------------------------------------------}

    uses Dos,Crt,PickFile;

    Const
      OnBlack     =   0;
      OnBlue      = $10;
      OnGreen     = $20;
      OnCyan      = $30;
      OnRed       = $40;
      OnMagenta   = $50;
      OnBrown     = $60;
      OnLightGray = $70;

    Var
      PathName : String[80];
      FileName : PathStr;
      Starts   : integer;

    Begin
      Textattr := White+OnBlue;
      ClrScr;
      Textattr := White+OnMagenta;
      Write('Enter a FileSpec : ');
      Starts := WhereX;
      ReadLn(PathName);
      Textattr := White+OnBlue;
    {------------------ This is where we call the function --------------------}

      FileName := FPick(PathName,White,White+OnBlue,Starts,WhereY+1,25,Shadow);

    {--------------------------------------------------------------------------}
    {
      TextAttr := $07;
      ClrScr;
    }
      If Picked then
        WriteLn('You selected : ',Filename)
      Else If Filename = '' then
        WriteLn('PickFile Aborted (',DosError,')')
      Else
        Writeln('You quit looking in : ',Filename);
    end.

[Back to DIRS SWAG index] [Back to Main SWAG index] [Original]