Directory related functions and procedures (Views: 29)
Problem/Question/Abstract: Directory related functions and procedures Answer: Here is a unit with some tool functions. See "CreatePath" it works recursively: unit Dirs; interface function NormDir(Dir: string): string; function MakeRelDir(Dir: string): string; function CommonDir(dir1, dir2: string): string; function SubtractDir(dir, minusdir: string): string; function NextDir(path: string; var pos: integer): string; function SkipRoot(dir: string): integer; procedure CreatePath(pth: string); function RemoveExt(Filename: string): string; implementation uses SysUtils; {Ensures an ending backslash if the directory isn't empty} function NormDir(Dir: string): string; begin if Length(Dir) > 0 then begin if Dir[Length(Dir)] <> '\' then result := Dir + '\' else result := Dir; end else begin result := ''; end; end; function MakeRelDir(Dir: string): string; var i: integer; begin i := SkipRoot(Dir); if i > 0 then begin if Dir[i] = '\' then result := Copy(Dir, i + 1, Length(Dir) - i) else result := Copy(Dir, i, Length(Dir) - i + 1); end else begin result := Dir; end; end; {Evaluates the common part of two directories} function CommonDir(dir1, dir2: string): string; var i: integer; dir1_: string; dir2_: string; begin dir1_ := UpperCase(dir1); dir2_ := UpperCase(dir2); i := 1; while (i <= Length(dir1_)) and (i <= Length(dir2_)) do begin if dir1_[i] <> dir2_[i] then Exit; inc(i); end; result := Copy(dir1, 1, i - 1); end; {Subtracts a directory from another} function SubtractDir(dir, minusdir: string): string; var p, pa, pb: integer; dira, dirb: string; begin pa := 1; pb := 1; repeat p := pa; dira := UpperCase(NextDir(dir, pa)); if dira = '' then break; dirb := UpperCase(NextDir(minusdir, pb)); if dirb = '' then break; if dira <> dirb then break; until false; result := Copy(dir, p, Length(dir) - p + 1); end; {SkipRoot finds the position of the ending backslash after Drive or Computername ('C:\' or '\\MyComp\')} function SkipRoot(dir: string): integer; begin if (Length(dir) >= 2) and (Copy(dir, 1, 2) = '\\') then begin result := 3; while (result <= Length(dir)) and (dir[result] <> '\') do inc(result); end else begin if Length(dir) > 1 then begin result := 1; while (result <= Length(dir)) and (dir[result] <> ':') do inc(result); if result > Length(dir) then result := 1 else inc(result); end else begin result := 0; end; end; end; {Used in other functions} function NextDir(path: string; var pos: integer): string; var i: integer; begin if pos > Length(path) then begin result := ''; end else begin if pos <= 1 then pos := SkipRoot(path); i := pos; repeat inc(pos) until (pos > Length(path)) or (path[pos] = '\'); result := Copy(path, i, pos - i); end; end; {Creates a path} procedure CreatePath(pth: string); var p: integer; NewPath: string; NxtDir: string; begin p := 1; while true do begin NxtDir := NextDir(pth, p); if NxtDir = '' then break; NewPath := Copy(pth, 1, p - 1); CreateDir(NewPath); end; end; {Removes the extension} function RemoveExt(Filename: string): string; var i: integer; begin i := Length(Filename); while true do begin if (i = 0) or (FileName[i] = '\') then begin result := FileName; Exit; end; if Filename[i] = '.' then begin result := Copy(Filename, 1, i - 1); Exit; end; dec(i); end; end; end. |