cncommon.pas

delphi常用过程

//------------------------------------------------------------------------------
// 扩展的文件目录操作函数
//------------------------------------------------------------------------------

// 在资源管理器中打开指定目录
procedure ExploreDir(APath: string);
var
  strExecute: string;
begin
  strExecute := Format('EXPLORER.EXE /e,%s', [APath]);
  WinExec(PChar(strExecute), SW_SHOWNORMAL);
end;

// 在资源管理器中打开指定文件
procedure ExploreFile(AFile: string);
var
  strExecute: string;
begin
  strExecute := Format('EXPLORER.EXE /e,/select,%s', [AFile]);
  WinExec(PChar(strExecute), SW_SHOWNORMAL);
end;

// 递归创建多级子目录
function ForceDirectories(Dir: string): Boolean;
begin
  Result := True;

  if Length(Dir) = 0 then
  begin
    Result := False;
    Exit;
  end;
  Dir := ExcludeTrailingBackslash(Dir);
  if (Length(Dir) < 3) or DirectoryExists(Dir)
    or (ExtractFilePath(Dir) = Dir) then
    Exit;                                // avoid 'xyz:\' problem.
  Result := ForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir);
end;

// 移动文件、目录
function MoveFile(const sName, dName: string): Boolean;
var
  s1, s2: AnsiString;
  lpFileOp: TSHFileOpStruct;
begin
  s1 := PChar(sName) + #0#0;
  s2 := PChar(dName) + #0#0;
  with lpFileOp do
  begin
    Wnd := Application.Handle;
    wFunc := FO_MOVE;
    pFrom := PChar(s1);
    pTo := PChar(s2);
    fFlags := FOF_ALLOWUNDO;
    hNameMappings := nil;
    lpszProgressTitle := nil;
    fAnyOperationsAborted := True;
  end;

  try
    Result := SHFileOperation(lpFileOp) = 0;
  except
    Result := False;
  end;
end;

// 删除文件到回收站
function DeleteToRecycleBin(const FileName: string): Boolean;
var
  s: AnsiString;
  lpFileOp: TSHFileOpStruct;
begin
  s := PChar(FileName) + #0#0;
  with lpFileOp do
  begin
    Wnd := Application.Handle;
    wFunc := FO_DELETE;
    pFrom := PChar(s);
    pTo := nil;
    fFlags := FOF_ALLOWUNDO or FOF_SILENT or FOF_NOCONFIRMATION;
    hNameMappings := nil;
    lpszProgressTitle := nil;
    fAnyOperationsAborted := True;
  end;

  try
    Result := SHFileOperation(lpFileOp) = 0;
  except
    Result := False;
  end;
end;

// 打开文件属性窗口
procedure FileProperties(const FName: string);
var
  SEI: SHELLEXECUTEINFO;
begin
  with SEI do
  begin
    cbSize := SizeOf(SEI);
    fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_INVOKEIDLIST or
      SEE_MASK_FLAG_NO_UI;
    Wnd := Application.Handle;
    lpVerb := 'properties';
    lpFile := PChar(FName);
    lpParameters := nil;
    lpDirectory := nil;
    nShow := 0;
    hInstApp := 0;
    lpIDList := nil;
  end;
  ShellExecuteEx(@SEI);
end;

// 缩短显示不下的长路径名
function FormatPath(APath: string; Width: Integer): string;
var
  SLen: Integer;
  i, j: Integer;
  TString: string;
begin
  SLen := Length(APath);
  if (SLen <= Width) or (Width <= 6) then
  begin
    Result := APath;
    Exit
  end
  else
  begin
    i := SLen;
    TString := APath;
    for j := 1 to 2 do
    begin
      while (TString[i] <> '\') and (SLen - i < Width - 8) do
        i := i - 1;
      i := i - 1;
    end;
    for j := SLen - i - 1 downto 0 do
      TString[Width - j] := TString[SLen - j];
    for j := SLen - i to SLen - i + 2 do
      TString[Width - j] := '.';
    Delete(TString, Width + 1, 255);
    Result := TString;
  end;
end;

// 通过 DrawText 来画缩略路径
procedure DrawCompactPath(Hdc: HDC; Rect: TRect; Str: string);
begin
  DrawText(Hdc, PChar(Str), Length(Str), Rect, DT_PATH_ELLIPSIS);
end;

// 打开文件框
function OpenDialog(var FileName: string; Title: string; Filter: string;
  Ext: string): Boolean;
var
  OpenName: TOPENFILENAME;
  TempFilename, ReturnFile: string;
begin
  with OpenName do
  begin
    lStructSize := SizeOf(OpenName);
    hWndOwner := GetModuleHandle('');
    Hinstance := SysInit.Hinstance;
    lpstrFilter := PChar(Filter + #0 + Ext + #0#0);
    lpstrCustomFilter := '';
    nMaxCustFilter := 0;
    nFilterIndex := 1;
    nMaxFile := MAX_PATH;
    SetLength(TempFilename, nMaxFile + 2);
    lpstrFile := PChar(TempFilename);
    FillChar(lpstrFile^, MAX_PATH, 0);
    SetLength(TempFilename, nMaxFile + 2);
    nMaxFileTitle := MAX_PATH;
    SetLength(ReturnFile, MAX_PATH + 2);
    lpstrFileTitle := PChar(ReturnFile);
    FillChar(lpstrFile^, MAX_PATH, 0);
    lpstrInitialDir := '.';
    lpstrTitle := PChar(Title);
    Flags := OFN_HIDEREADONLY + OFN_ENABLESIZING;
    nFileOffset := 0;
    nFileExtension := 0;
    lpstrDefExt := PChar(Ext);
    lCustData := 0;
    lpfnHook := nil;
    lpTemplateName := '';
  end;
  Result := GetOpenFileName(OpenName);
  if Result then
    FileName := ReturnFile
  else
    FileName := '';
end;

function SelectDirCB(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer stdcall;
begin
  if (uMsg = BFFM_INITIALIZED) and (lpData <> 0) then
    SendMessage(Wnd, BFFM_SETSELECTION, Integer(True), lpdata);
  Result := 0;
end;

function CnSelectDirectory(const Caption: string; const Root: WideString;
  var Directory: string; Owner: HWND; ShowNewButton: Boolean = True): Boolean;
var
  BrowseInfo: TBrowseInfo;
  Buffer: PChar;
  RootItemIDList, ItemIDList: PItemIDList;
  ShellMalloc: IMalloc;
  IDesktopFolder: IShellFolder;
  Eaten, Flags: LongWord;
begin
  Result := False;
  FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
  if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
  begin
    Buffer := ShellMalloc.Alloc(MAX_PATH);
    try
      SHGetDesktopFolder(IDesktopFolder);
      if Root = '' then
        RootItemIDList := nil
      else
        IDesktopFolder.ParseDisplayName(Application.Handle, nil,
          POleStr(Root), Eaten, RootItemIDList, Flags);
      with BrowseInfo do
      begin
        hwndOwner := Owner;
        pidlRoot := RootItemIDList;
        pszDisplayName := Buffer;
        lpszTitle := PChar(Caption);
        ulFlags := BIF_RETURNONLYFSDIRS;
        if ShowNewButton then
          ulFlags := ulFlags or $0040;
        lpfn := SelectDirCB;
        lparam := Integer(PChar(Directory));
      end;
      ItemIDList := SHBrowseForFolder(BrowseInfo);
      Result :=  ItemIDList <> nil;
      if Result then
      begin
        ShGetPathFromIDList(ItemIDList, Buffer);
        ShellMalloc.Free(ItemIDList);
        Directory := Buffer;
      end;
    finally
      ShellMalloc.Free(Buffer);
    end;
  end;
end;

function GetDirectory(const Caption: string; var Dir: string;
  ShowNewButton: Boolean): Boolean;
var
  OldErrorMode: UINT;
  BrowseRoot: WideString;
  OwnerHandle: HWND;
begin
  OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  try
    BrowseRoot := '';
    if Screen.ActiveCustomForm <> nil then
      OwnerHandle := Screen.ActiveCustomForm.Handle
    else
      OwnerHandle := Application.Handle;
    Result := CnSelectDirectory(Caption, BrowseRoot, Dir, OwnerHandle,
      ShowNewButton);
  finally
    SetErrorMode(OldErrorMode);
  end;
end;

// 两个字符串的前面的相同字符数
function SameCharCounts(s1, s2: string): Integer;
var
  Str1, Str2: PChar;
begin
  Result := 1;
  s1 := s1 + #0;
  s2 := s2 + #0;
  Str1 := PChar(s1);
  Str2 := PChar(s2);

  while (s1[Result] = s2[Result]) and (s1[Result] <> #0) do
  begin
    Inc(Result);
  end;
  Dec(Result);
{$IFDEF MSWINDOWS}
  if (StrByteType(Str1, Result - 1) = mbLeadByte) or
    (StrByteType(Str2, Result - 1) = mbLeadByte) then
    Dec(Result);
{$ENDIF}
{$IFDEF LINUX}
  if (StrByteType(Str1, Result - 1) <> mbSingleByte) or
    (StrByteType(Str2, Result - 1) <> mbSingleByte) then
    Dec(Result);
{$ENDIF}
end;

// 在字符串中某字符出现的次数
function CharCounts(Str: PChar; Chr: Char): Integer;
var
  p: PChar;
begin
  Result := 0;
  p := StrScan(Str, Chr);
  while p <> nil do
  begin
{$IFDEF MSWINDOWS}
    case StrByteType(Str, Integer(p - Str)) of
      mbSingleByte: begin
        Inc(Result);
        Inc(p);
      end;
      mbLeadByte: Inc(p);
    end;
{$ENDIF}
{$IFDEF LINUX}
    if StrByteType(Str, Integer(p - Str)) = mbSingleByte then begin
      Inc(Result);
      Inc(p);
    end;
{$ENDIF}
    Inc(p);
    p := StrScan(p, Chr);
  end;
end;

// 取两个目录的相对路径
function GetRelativePath(ATo, AFrom: string;
  const PathStr: string = '\'; const ParentStr: string = '..';
  const CurrentStr: string = '.'; const UseCurrentDir: Boolean = False): string;
var
  i, HeadNum: Integer;
begin
  ATo := StringReplace(ATo, '/', '\', [rfReplaceAll]);
  AFrom := StringReplace(AFrom, '/', '\', [rfReplaceAll]);
  while AnsiPos('\\', ATo) > 0 do
    ATo := StringReplace(ATo, '\\', '\', [rfReplaceAll]);
  while AnsiPos('\\', AFrom) > 0 do
    AFrom := StringReplace(AFrom, '\\', '\', [rfReplaceAll]);
  if StrRight(ATo, 1) = ':' then
    ATo := ATo + '\';
  if StrRight(AFrom, 1) = ':' then
    AFrom := AFrom + '\';

  HeadNum := SameCharCounts(AnsiUpperCase(ExtractFilePath(ATo)),
    AnsiUpperCase(ExtractFilePath(AFrom)));
  if HeadNum > 0 then
  begin
    ATo := StringReplace(Copy(ATo, HeadNum + 1, MaxInt), '\', PathStr, [rfReplaceAll]);
    AFrom := Copy(AFrom, HeadNum + 1, MaxInt);

    Result := '';
    HeadNum := CharCounts(PChar(AFrom), '\');
    for i := 1 to HeadNum do
      Result := Result + ParentStr + PathStr;
    if (Result = '') and UseCurrentDir then
      Result := CurrentStr + PathStr;
    Result := Result + ATo;
  end
  else
    Result := ATo;
end;

{$IFNDEF BCB}
const
  shlwapi32 = 'shlwapi.dll';

function PathRelativePathToA; external shlwapi32 name 'PathRelativePathToA';
function PathRelativePathToW; external shlwapi32 name 'PathRelativePathToW';
function PathRelativePathTo; external shlwapi32 name 'PathRelativePathToA';

// 使用Windows API取两个目录的相对路径
function RelativePath(const AFrom, ATo: string; FromIsDir, ToIsDir: Boolean): string;
  function GetAttr(IsDir: Boolean): DWORD;
  begin
    if IsDir then
      Result := FILE_ATTRIBUTE_DIRECTORY
    else
      Result := FILE_ATTRIBUTE_NORMAL;
  end;
var
  p: array[0..MAX_PATH] of Char;
begin
  PathRelativePathTo(p, PChar(AFrom), GetAttr(FromIsDir), PChar(ATo), GetAttr(ToIsDir));
  Result := StrPas(p);
end;
{$ENDIF}

// 连接两个路径，
// Head - 首路径，可以是 C:\Test、\\Test\C\Abc、http://www.abc.com/dir/ 等格式
// Tail - 尾路径，可以是 ..\Test、Abc\Temp、\Test、/web/lib 等格式或绝对地址格式
function LinkPath(const Head, Tail: string): string;
var
  HeadIsUrl: Boolean;
  TailHasRoot: Boolean;
  TailIsRel: Boolean;
  AHead, ATail, S: string;
  UrlPos, i: Integer;
begin
  if Head = '' then
  begin
    Result := Tail;
    Exit;
  end;

  if Tail = '' then
  begin
    Result := Head;
    Exit;
  end;

  TailHasRoot := (AnsiPos(':\', Tail) = 2) or // C:\Test
                 (AnsiPos('\\', Tail) = 1) or // \\Name\C\Test
                 (AnsiPos('://', Tail) > 0);  // ftp://ftp.abc.com
  if TailHasRoot then
  begin
    Result := Tail;
    Exit;
  end;

  UrlPos := AnsiPos('://', Head);
  HeadIsUrl := UrlPos > 0;
  AHead := StringReplace(Head, '/', '\', [rfReplaceAll]);
  ATail := StringReplace(Tail, '/', '\', [rfReplaceAll]);

  TailIsRel := ATail[1] = '\'; // 尾路径是相对路径
  if TailIsRel then
  begin
    if AnsiPos(':\', AHead) = 2 then
      Result := AHead[1] + ':' + ATail
    else if AnsiPos('\\', AHead) = 1 then
    begin
      S := Copy(AHead, 3, MaxInt);
      i := AnsiPos('\', S);
      if i > 0 then
        Result := Copy(AHead, 1, i + 1) + ATail
      else
        Result := AHead + ATail;
    end else if HeadIsUrl then
    begin
      S := Copy(AHead, UrlPos + 3, MaxInt);
      i := AnsiPos('\', S);
      if i > 0 then
        Result := Copy(AHead, 1, i + UrlPos + 1) + ATail
      else
        Result := AHead + ATail;
    end
    else
    begin