Directory related functions and procedures

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.