{============================================================================}
{ 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.