FILE_FIND: Arborescence des répertoires dans un mémo

label labels : gosub labels
gosub constantes
gosub variables
gosub form0
gosub GUI
gosub initialisations

end


labels:
  label constantes, variables
  label form0, GUI, initialisations
  label folder, info
  label iniloop, ini1
  return

constantes:
  dim maxi% : maxi% = 5000
  dim indent$ : indent$ = string$(100,"-")
  dim dll$ : dll$ = "FileInfo.dll"
  return

variables:
  dim no%, no1%, no_rep%, no_tree%, depth%, ptr%, f$, f1$, i%, d$
  dim cnt%(maxi%), dir$(maxi%)
  dim no_wait%, n_file%, n_folder%, rep$, a%, dat$, att$, batt$
  return

form0:
  caption 0,"Tree-View"
  width 0,1200
  height 0,800
  return

GUI:
  ' invisible elements
  no% = no% + 1 : open_dialog no%

  ' sample application program objects
  no% = no% + 1 : container no% : no1% = no% : top no%,10 : left no%,10
    width no%,950 : height no%,50 : caption no%,"Select folder"
  no% = no% + 1 : edit no% : parent no%,no1% : no_rep% = no%
    top no%,20 : left no%,10 : width no%,860
  no% = no% + 1 : button no% : parent no%,no1% : top no%,17 : left no%,880
    width no%, 50 : caption no%,"Start" : on_click no%,folder

  ' treeview objects
  no% = no% + 1 : container no% : no1% = no% : top no%,80 : left no%,10
    width no%,900 : height no%,650 : caption no%,"Folder tree"
  no% = no% + 1 : list no% : parent no%,no1% : no_tree% = no%
    top no%,20 : left no%,10 : width no%,880 : height no%,600
    font_name no%,"Courier"

  ' function objects
  no% = no% + 1 : container no% : no1% = no% : top no%,80 : left no%,910
    width no%,250 : height no%,650 : caption no%,"Functions"

  ' message d'attente
  no% = no% + 1 : form no% : hide no% : no_wait% = no% : inactive no%
    top no%,300 : left no%,300 : height no%,150 : width no%,300
    caption no%,"Traitement en cours..."
  no% = no% + 1 : alpha no% : parent no%,no_wait% : top no%,40 : left no%,10
    caption no%,"Veuillez patienter..." : font_color no%,255,0,0
    font_bold no% : font_italic no% : font_size no%,16

  return

initialisations:
  dll_on dll$
  batt$ = string$(7," ")
  return

folder:
  inactive 0
  show no_wait%
  pause 1
  clear no_tree%
  n_file% = 0 : n_folder% = 0
  f$ = text$(no_rep%)
  if f$="" then f$ = dir_current$
  if dir_exists(f$)=0 then f$ = dir_current$
  dir_change f$
  item_add no_tree%,"Tree "+chr$(34)+f$+chr$(34)
  rep$ = f$
  depth% = 0
  f$ = file_find_first$
  dir$(0) = f$
  cnt%(0) = 0
iniloop:
  if f$="_"
    if depth%>0
      depth% = depth% - 1
      file_find_close
      dir_change ".."
      f$ = file_find_first$
      if cnt%(depth%)>0
        for i%=1 to cnt%(depth%)
          f$ = file_find_next$
        next i%
      end_if
      goto iniloop
    else
      goto ini1
    end_if
  end_if
  cnt%(depth%) = cnt%(depth%) + 1
  if dir_exists(f$)=1
    depth% = depth% + 1
    f1$ = "D "+left$(indent$,depth%)+f$
    item_add no_tree%,f1$
    gosub info
    n_folder% = n_folder% + 1
    cnt%(depth%) = 0
    file_find_close
    dir_change f$+"\"
    dir$(depth%) = f$+"\"
    f$ = file_find_first$
  else
    f1$ = "  "+left$(indent$,depth%)+f$
    item_add no_tree%,f1$
    gosub info
    n_file% = n_file% + 1
    f$ = file_find_next$
  end_if
  goto iniloop
ini1:
  file_find_close
  item_add no_tree%,str$(n_folder%)+" folders and "+str$(n_file%)+" files in tree "+chr$(34)+rep$+chr$(34)
  hide no_wait%
  active 0
  to_foreground 0
  return
 
info:
  f1$ = rep$
  if right$(f1$,1)<>"\" then f1$ = f1$ + "\"
  if depth%>0
    for i%=1 to depth%
      f1$ = f1$ + dir$(i%)
      if right$(f1$,1)<>"\" then f1$ = f1$ + "\"
    next i%
  end_if
  f1$ = f1$ + f$
  att$ = ""
  a% = dll_call1("GetFileAttributes",adr(f1$))
  if a%=-1
'    item_add no_tree%,f1$
    a% = 16
  end_if
  if bin_and(a%,1)>0 then att$ = att$ + "R"
  if bin_and(a%,2)>0 then att$ = att$ + "H"
  if bin_and(a%,4)>0 then att$ = att$ + "S"
  if bin_and(a%,16)>0 then att$ = att$ + "D"
  if bin_and(a%,32)>0 then att$ = att$ + "A"
  att$ = att$ + string$(5," ")
  att$ = left$(att$,5)
  if (bin_and(a%,128)=0) and (bin_and(a%,16)=0)
    dat$ = string$(255," ")
    i% = dll_call2("GetFileDate",adr(f1$),adr(dat$))
    item_add no_tree%,"  "+left$(batt$,depth%)+str$(a%)+"="+att$+"created at "+dat$
  else
    item_add no_tree%,"  "+left$(batt$,depth%)+str$(a%)+"="+att$
  end_if
  return

library FileInfo;

uses
  SysUtils,
  Classes,
  TextToPanoramic in 'TextToPanoramic.pas';

  {$R *.res}

function GetFileAttributes(fil: pchar):integer; stdcall; export;
var
  f: string;
begin
  f := pchar(pstring(fil)^);
  result := FileGetAttr(f);
end;

function GetFileDate(fil: pchar; dat: integer):integer; stdcall; export;
var
  d,f: string;
begin
  f := pchar(pstring(fil)^);
  d := DateTimeToStr(FileDateToDateTime(FileAge(f)));
  CopyTextToPanoramic(integer(@d), 0, dat);
  result := 0;
end;

Exports
  GetFileAttributes, GetFileDate;

begin
end.