u_pub.pas

提取网页文件图片地址,应用此工具

unit U_Pub;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics,
  StdCtrls, ComCtrls, ExtCtrls, shlobj, shellapi, forms,OleServer;

function GetWinTempDir: string;
function GetNewDirName(DirName: string): string; //的到不重名的文件夹名
function GetNewFileName(FileName: string): string; //得到不重名的文件名
function GetFileNametoDirName(FileName: string): string; //从文件名转为目录名
function InStr(const sShort: string; const sLong: string): Boolean;
//判断字符串是否包含

function IsValidFileName(strFileName: string): boolean; //判断文件名是否合法
function GetFolder(aRoot: integer; aCaption: string): string;
//function IfStrInStrings(str:string;lst:Tstrings):boolean;//判断字符串是否在
procedure renf(var s1: string; s2: string);
function InspectDirName(DirName: string): boolean;
 function AddDirSuffix(Dir: string): string;
procedure InfoDlg(Mess: string; Caption: string; Flags: Integer);
function InfoOk(Mess: string; Caption: string): Boolean;
procedure ErrorDlg(Mess: string; Caption: string);
procedure WarningDlg(Mess: string; Caption: string);
function QueryDlg(Mess: string; Caption: string): Boolean;
function CorrFileName(tems: string):string;
implementation

////////////////////////////////////////////////////////////////////

function IsValidFileName(strFileName: string): boolean; //判断文件名是否合法
var
  ErrorStr: string;
  i: integer;
  CharStr: string;
begin
  ErrorStr := '/\:*?<>|"';
  for i := 1 to Length(StrFileName) do
  begin
    CharStr := Copy(StrFileName, i - 1, 1);
    if InStr(CharStr, ErrorStr) then
      result := false
    else
      result := true;
  end;
end;
////////////////////////////////////////////////////////

////////////////////////////////////////////
///////////////////////////////////////////////
// 判断s1是否包含在s2中

function InStr(const sShort: string; const sLong: string): Boolean;
var
  s1, s2: string;
begin
  s1 := LowerCase(sShort);
  s2 := LowerCase(sLong);
  Result := Pos(s1, s2) > 0;
end;
////////////////////////////////////////////////

function GetFileNametoDirName(FileName: string): string;
//带路径的文件名转为绝对文件名
var
  iPos: integer;

begin
  iPos := Pos('.', FileName);
  if iPos = 0 then
    result := FileName
  else
    result := copy(FileName, 0, iPos - 1);
end;
/////////////////////////////////////////////////

function GetNewFileName(FileName: string): string; //得到不重名的文件名
var
  i, iPos: integer;
  NewName: string;
begin
  i := 1;
  NewName := FileName;
  while FileExists(NewName) do
  begin
    iPos := Pos('.', FileName);
    if iPos <> 0 then

      NewName := copy(FileName, 0, iPos - 1) + inttostr(i) + copy(FileName,
        iPos, 4);
    i := i + 1;
  end;
  result := NewName;
end;
//////////////////////////////////

function GetNewDirName(DirName: string): string; //的到不重名的文件夹名
var
  i: integer;
  NewName: string;
begin
  i := 1;
  NewName := DirName;
  while DirectoryExists(NewName) do
  begin
    NewName := DirName + inttostr(i);
    i := i + 1;
  end;
  result := NewName;
end;
////////////////////////////

function AddDirSuffix(Dir: string): string;
begin
  Result := Trim(Dir);
  if Result = '' then
    Exit;
  if Result[Length(Result)] <> '\' then
    Result := Result + '\';
end;
////////////////////////////////

function GetWinTempDir: string;
var
  Buf: array[0..MAX_PATH] of Char;
begin
  GetTempPath(MAX_PATH, Buf);
  Result := AddDirSuffix(Buf);
end;
/////////////////////

function GetFolder(aRoot: integer; aCaption: string): string;
//打开浏览文件夹对话框
var
  pPrograms, pBrowse: PItemIDList;
  hBrowseInfo: TBROWSEINFO;
  hPChar: PChar;

begin
  if (not SUCCEEDED(SHGetSpecialFolderLocation(Getactivewindow, aRoot,
    pPrograms))) then
    EXIT;
  hPChar := StrAlloc(max_path);
  with hBrowseInfo do
  begin
    hwndOwner := Getactivewindow;
    pidlRoot := pPrograms;
    pszDisplayName := hPChar;
    lpszTitle := pChar(aCaption);
    ulFlags := BIF_RETURNONLYFSDIRS;
    lpfn := nil;
    lParam := 0;
  end;

  pBrowse := SHBrowseForFolder(hBrowseInfo);
  if (pBrowse <> nil) then
    if (SHGetPathFromIDList(pBrowse, hPChar)) then
      Result := hPChar;
  StrDispose(hPChar);
end;
////////////////////////

function CorrFileName(tems: string):string;

begin
  renf(tems, '/');
  renf(tems, '\');
  renf(tems, ':');
  renf(tems, '*');
  renf(tems, '?');
  renf(tems, '"');
  renf(tems, '<');
  renf(tems, '>');
  renf(tems, '|');
  result := tems;

end;
/////////////////////////

procedure renf(var s1: string; s2: string);
begin
  if pos(s2, s1) <> 0 then
    repeat
      delete(s1, pos(s2, s1), 1)
    until pos(s2, s1) = 0;
end;
///////////////////////////

function InspectDirName(DirName: string): boolean;
var
   ErrorStr: string;
   i:integer;
begin

  result := false;
  if length(DirName) < 3 then
    exit;
  if (not (DirName[1] in ['a'..'z']))     and    (not (DirName[1] in ['A'..'Z']))  then
    exit;
  if   (Copy(DirName, 2, 1) <> ':') or (Copy(DirName, 3, 1) <> '\') then
  begin
 //   infodlg( Copy(DirName, 2, 1) + '-' + Copy(DirName, 3, 1),'',1);

    exit;
    end;
  if InStr('\\', DirName) then
    exit;
  ErrorStr := '/:*?<>|"';
 for i := 3 to (length(DirName) - 1) do
  begin
    if instr(copy(DirName, i, 1), ErrorStr) then
      exit;
  end;
  result := true;
 // DirName := AddDirSuffix(DirName);
end;

//▎============================================================▎//
//▎===================⑤扩展的对话框函数=======================▎//
//▎============================================================▎//

// 显示提示窗口
procedure InfoDlg(Mess: string; Caption: string; Flags: Integer);
begin
  Application.MessageBox(PChar(Mess), PChar(Caption), Flags);
end;

// 显示提示确认窗口
function InfoOk(Mess: string; Caption: string): Boolean;
begin
  Result := Application.MessageBox(PChar(Mess), PChar(Caption),
    MB_OK + MB_ICONINFORMATION) = IDOK;
end;

// 显示错误窗口
procedure ErrorDlg(Mess: string; Caption: string);
begin
  Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONSTOP);
end;

// 显示警告窗口
procedure WarningDlg(Mess: string; Caption: string);
begin
  Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONWARNING);
end;

// 显示查询是否窗口
function QueryDlg(Mess: string; Caption: string): Boolean;
begin
  Result := Application.MessageBox(PChar(Mess), PChar(Caption),
    MB_YESNO + MB_ICONQUESTION) = IDYES;
end;

end.