tools.pas

一个非常好的delphi源代码包

 anobj:IUnknown;
 shlink:IShellLink;
 pFile:IPersistFile;
 wFileName:widestring;
begin
 wFileName:=destfilename;
 anobj:=CreateComObject(CLSID_SHELLLINK);
 shlink:=anobj as IShellLink;
 pFile:=anobj as IPersistFile;
 shlink.SetPath(info.FileName);
 shlink.SetWorkingDirectory(info.WorkDirectory);
 shlink.SetDescription(info.Description);
 shlink.SetArguments(info.Arguments);
 shlink.SetIconLocation(info.IconLocation,info.IconIndex);
// shlink.SetIDList(info.ItemIDList);
 shlink.SetHotkey(info.HotKey);
 shlink.SetShowCmd(info.ShowState);
 shlink.SetRelativePath(info.RelativePath,0);
 if DestFileName='' then
  wFileName:=ChangeFileExt(info.FileName,'lnk');
 result:=succeeded(pFile.Save(pwchar(wFileName),false));
end;

function MakeLangID(const p,s:word):word;
begin
  result:=word((word(s)) shl 10) or (word(p));
end;

function MakeLCID(const lgid,srtid:word):dword;
begin
  result:=dword(((dword(word(srtid))) shl 16) or (dword(word(lgid))));
end;

function RunDOS(const Prog, CommandLine,Dir: String;var ExitCode:DWORD): String;

procedure CheckResult(b: Boolean);
begin
  if not b then
     Raise Exception.Create(SysErrorMessage(GetLastError));
end;

var
  HRead,HWrite:THandle;
  StartInfo:TStartupInfo;
  ProceInfo:TProcessInformation;
  b:Boolean;
  sa:TSecurityAttributes;
  inS:THandleStream;
  sRet:TStrings;
begin
  Result := '';
  FillChar(sa,sizeof(sa),0);
  //设置允许继承,否则在NT和2000下无法取得输出结果
  sa.nLength := sizeof(sa);
  sa.bInheritHandle := True;
  sa.lpSecurityDescriptor := nil;
  b := CreatePipe(HRead,HWrite,@sa,0);
  CheckResult(b);

  FillChar(StartInfo,SizeOf(StartInfo),0);
  StartInfo.cb := SizeOf(StartInfo);
  StartInfo.wShowWindow := SW_SHOW;
  //使用指定的句柄作为标准输入输出的文件句柄,使用指定的显示方式
  StartInfo.dwFlags     := STARTF_USESTDHANDLES+STARTF_USESHOWWINDOW;
  StartInfo.hStdError   := HWrite;
  StartInfo.hStdInput   := GetStdHandle(STD_INPUT_HANDLE);//HRead;
  StartInfo.hStdOutput  := HWrite;

  b := CreateProcess(PChar(Prog),PChar(CommandLine),nil,nil,True,CREATE_NEW_CONSOLE,nil,PChar(Dir),StartInfo,ProceInfo);

  CheckResult(b);
  WaitForSingleObject(ProceInfo.hProcess,INFINITE);
  GetExitCodeProcess(ProceInfo.hProcess,ExitCode);

  inS := THandleStream.Create(hread);

  if inS.Size>0 then
  begin
    sRet := TStringList.Create;
    sRet.LoadFromStream(inS);
    Result := sRet.Text;
    sRet.Free;
  end;
  inS.Free;

  CloseHandle(HRead);
  CloseHandle(HWrite);
end;

procedure GetCachedPassword(var buf:tstringlist);

  function pce(x:PPASSWORD_CACHE_ENTRY;y:dword):boolean;stdcall;
  var
    buffer1:array [0..200] of char;
  begin
    move(x.abResource,buffer1,x.cbResource);
    if x.cbResource<50 then
      fillchar(buffer1[x.cbResource],50-x.cbResource,#32);

    move(x.abResource[x.cbResource],buffer1[50],x.cbPassword);
    buffer1[x.cbPassword+50]:=#0;
    buf.Add(buffer1);

    Result:=true;
  end;

begin
  buf:=tstringlist.Create;
  buf.Clear;
  WNetEnumCachedPasswords(nil,0,255,@pce,0);
end;

function GetHzPy(const AHzStr: string): string;
const
  ChinaCode: array[0..25, 0..1] of Integer = ((1601, 1636), (1637, 1832), (1833, 2077),
    (2078, 2273), (2274, 2301), (2302, 2432), (2433, 2593), (2594, 2786), (9999, 0000),
    (2787, 3105), (3106, 3211), (3212, 3471), (3472, 3634), (3635, 3722), (3723, 3729),
    (3730, 3857), (3858, 4026), (4027, 4085), (4086, 4389), (4390, 4557), (9999, 0000),
    (9999, 0000), (4558, 4683), (4684, 4924), (4925, 5248), (5249, 5589));
var
  i, j, HzOrd: integer;
begin
  i := 1;
  while i <= Length(AHzStr) do
  begin
    if (AHzStr[i] >= #160) and (AHzStr[i + 1] >= #160) then
    begin
      HzOrd := (Ord(AHzStr[i]) - 160) * 100 + Ord(AHzStr[i + 1]) - 160;
      for j := 0 to 25 do
      begin
        if (HzOrd >= ChinaCode[j][0]) and (HzOrd <= ChinaCode[j][1]) then
        begin
          Result := Result + char(byte('A') + j);
          break;
        end;
      end;
      Inc(i);
    end else Result := Result + AHzStr[i];
    Inc(i);
  end;
end;

function AnsiToUnicode(Ansi: string):string; 
var 
  s:string; 
  i:integer; 
  j,k:string[2]; 
  a:array [1..1000] of char; 
begin 
  s:=''; 
  StringToWideChar(Ansi,@(a[1]),500); 
  i:=1; 
  while ((a[i]<>#0) or (a[i+1]<>#0)) do begin 
    j:=IntToHex(Integer(a[i]),2); 
    k:=IntToHex(Integer(a[i+1]),2); 
    s:=s+k+j; 
    i:=i+2; 
  end; 
    Result:=s; 
end;

function UnicodeToAnsi(Unicode: string):string;
var
  s:string;
  i:integer;
  j,k:string[2];

 function ReadHex(AString:string):integer;
 begin
  Result:=StrToInt('$'+AString)
 end;

begin
  i:=1;
  s:='';
  while i<Length(Unicode)+1 do begin
    j:=Copy(Unicode,i+2,2);
    k:=Copy(Unicode,i,2);
    i:=i+4;
    s:=s+Char(ReadHex(j))+Char(ReadHex(k));
  end;
  if s<>'' then
    s:=WideCharToString(PWideChar(s+#0#0#0#0))
  else
    s:='';
  Result:=s;
end;

procedure FitBitmap(const Source,Dest:string;const x,y:integer;const ColorBit:TPixelFormat);
var
  abmp,bbmp:tbitmap;
  scalex,scaley:real;
begin
  abmp:=tbitmap.Create;
  bbmp:=tbitmap.Create;
  try
    abmp.LoadFromFile(Source);
    scaley:=abmp.Height/y;
    scalex:=abmp.Width/x;
    bbmp.Width:=round(abmp.Width/scalex);
    bbmp.Height:=round(abmp.Height/scaley);
    bbmp.PixelFormat:=pf8bit;
    SetStretchBltMode(bbmp.Canvas.Handle,COLORONCOLOR);
    stretchblt(bbmp.Canvas.Handle,0,0,bbmp.Width,bbmp.Height,abmp.Canvas.Handle,0,0,abmp.Width,abmp.Height,srccopy);
    bbmp.SaveToFile(Dest);
 finally
   abmp.Free;
   bbmp.Free;
 end;
end;

procedure Jpg2Bmp(const source,dest:string);
var
  MyJpeg: TJpegImage;
  bmp: Tbitmap;
begin
bmp:=tbitmap.Create;
MyJpeg:= TJpegImage.Create;
try
  myjpeg.LoadFromFile(source);
  bmp.Assign(myjpeg);
  bmp.SaveToFile(dest);
finally
  bmp.free;
  myjpeg.Free;
end;
end;

procedure Bmp2Jpg(const source,dest:string;const scale:byte);
var
  MyJpeg: TJpegImage;
  Image1: TImage;
begin
Image1:= TImage.Create(application);
MyJpeg:= TJpegImage.Create;
try
  Image1.Picture.Bitmap.LoadFromFile(source);
  MyJpeg.Assign(Image1.Picture.Bitmap); 
  MyJpeg.CompressionQuality:=scale;
  MyJpeg.Compress;
  MyJpeg.SaveToFile(dest);
finally
  image1.free;
  myjpeg.Free;
end;
end;

function IsFileInUse(fName : string ) : boolean; 
var 
  HFileRes : HFILE; 
begin 
  Result := false; 
  if not FileExists(fName) then
    exit; 
  HFileRes := CreateFile(pchar(fName), GENERIC_READ or GENERIC_WRITE,0, nil, OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL, 0); 
  Result := (HFileRes = INVALID_HANDLE_VALUE); 
  if not Result then 
    CloseHandle(HFileRes); 
end;

function GetFileLastAccessTime(sFileName:string;uFlag:byte):TDateTime;
var
  ffd:TWin32FindData;
  dft:DWord;
  lft:TFileTime;
  h:THandle;
begin
  h:=FindFirstFile(PChar(sFileName),ffd);
  if h<>INVALID_HANDLE_VALUE then
  begin
  case uFlag of
  FILE_CREATE_TIME:FileTimeToLocalFileTime(ffd.ftCreationTime,lft);
  FILE_MODIFY_TIME:FileTimeToLocalFileTime(ffd.ftLastWriteTime,lft);
  FILE_ACCESS_TIME:FileTimeToLocalFileTime(ffd.ftLastAccessTime,lft);
  else
    FileTimeToLocalFileTime(ffd.ftLastAccessTime,lft);
  end;
  FileTimeToDosDateTime(lft,LongRec(dft).Hi,LongRec(dft).Lo);
  Result:=FileDateToDateTime(dft);
  windows.FindClose(h);
  end
  else
  result:=0;
end;

procedure DeleteMe;
var
  BatchFile: TextFile;
  BatchFileName: string;
  ProcessInfo: TProcessInformation;
  StartUpInfo: TStartupInfo;
begin
  BatchFileName := changefileext(paramstr(0),'.bat');

  AssignFile(BatchFile, BatchFileName);
  Rewrite(BatchFile);

  Writeln(BatchFile, ':try');
  Writeln(BatchFile, 'del "' + ParamStr(0) + '"');
  Writeln(BatchFile, 'if exist "' + ParamStr(0) + '"' + ' goto try');
  Writeln(BatchFile, 'del %0');
  CloseFile(BatchFile);

  FillChar(StartUpInfo, SizeOf(StartUpInfo), $00);
  StartUpInfo.dwFlags := STARTF_USESHOWWINDOW;
  StartUpInfo.wShowWindow := SW_HIDE;

  if CreateProcess(nil, PChar(BatchFileName), nil, nil,False, IDLE_PRIORITY_CLASS,
                   nil, nil, StartUpInfo,ProcessInfo) then
  begin
    CloseHandle(ProcessInfo.hThread);
    CloseHandle(ProcessInfo.hProcess);
  end;
end;

procedure FindFile(var quit:boolean;const path: String;const filename:string='*.*';
                   proc:TFindCallBack=nil;bSub:boolean=true;const bMsg:boolean=true);
var
  fpath: String;
  info: TsearchRec;

 procedure ProcessAFile;
 begin
  if (info.Name<>'.') and (info.Name<>'..') and ((info.Attr and faDirectory)<>faDirectory) then
  begin
  if assigned(proc) then
    proc(fpath+info.FindData.cFileName,info,quit,bsub);
  end;
 end;

 procedure ProcessADirectory;
 begin
  if (info.Name<>'.') and (info.Name<>'..') and ((info.attr and fadirectory)=fadirectory) then
    findfile(quit,fpath+info.Name,filename,proc,bsub,bmsg);
 end;

begin
if path[length(path)]<>'\' then
  fpath:=path+'\'
else
  fpath:=path;
try
  if 0=findfirst(fpath+filename,faanyfile and (not fadirectory),info) then
  begin
    ProcessAFile;
    while 0=findnext(info) do
      begin
        ProcessAFile;
        if bmsg then application.ProcessMessages;
        if quit then
          begin
            findclose(info);
            exit;
          end;
      end;
  end;
finally
  findclose(info);
end;
try
  if bsub and (0=findfirst(fpath+'*',faanyfile,info)) then
    begin
      ProcessADirectory;
      while findnext(info)=0 do
        ProcessADirectory;
    end;
finally
  findclose(info);
end;
end;

function GetBit(const x:dword;const bit:byte):dword;
begin
  result:=(x shr (bit-1)) and 1;
end;

function SetBit(const x:dword;const bit:byte):dword;
begin
  result:=x or (1 shr (bit-1));
end;

function OpenWith(h:hwnd;const filename:string):integer;
begin
 result:=ShellExecute(h,'open','rundll32.exe',pchar('shell32.dll,OpenAs_RunDLL '+filename),'',sw_show);
end;

procedure SetRes(XRes, YRes: DWord);
var
 lpDevMode : TDeviceMode;
begin
 lpDevMode.dmFields:=DM_PELSWIDTH or DM_PELSHEIGHT;
 lpDevMode.dmPelsWidth:=XRes;
 lpDevMode.dmPelsHeight:=YRes;
 ChangeDisplaySettings(lpDevMode, 0);
end;

function GetFileName(const filename:string):string;
begin
  result:=changefileext(Extractfilename(filename),'');
end;

function Rightpos(s:string;ch:char;count:integer=1):integer;
var
 i,n:integer;
begin
  n:=0;
  for i:=length(s) downto 1 do
  begin
    if s[i]=ch then inc(n);
    if n=count then break;
  end;
  result:=i;
end;

function PackFileName(const fn: string;const len:integer=67) : string;
var
 name,path,drv:string;
 buf:array [0..MAX_PATH] of char;
begin
result:=expandfilename(fn);
if (len>=length(result)) then exit;
name:=extractfilename(result);
drv:=extractfiledrive(result);
path:=copy(extractfilepath(result),3,length(result)-3);
if length(name)>len-7 then
 begin
 getshortpathname(pchar(fn),buf,MAX_PATH);
 name:=extractfilename(buf);
 result:=drv+path+name;
 if length(result)<len then exit;
 end;
repeat
 delete(path,rightpos(path,'\',2),length(path)-rightpos(path,'\',2));
 result:=drv+path+'...\'+name;
until length(result)<=len;
end;

function stringRight(s:string;count:integer;ch:char=#0):string;
begin
  if ch=#0 then
  begin
    result:=copy(s,length(s)-count+1,count);
    exit;
  end;
  result:=copy(s,rightpos(s,ch)+1,length(s)-rightpos(s,ch));
end;

function stringleft(s:string;count:integer;ch:char=#0):string;
begin
  if ch=#0 then
    result:=copy(s,1,count)
  else
    result:=copy(s,1,pos(ch,s)-1);
end;

procedure showinfo(msg:string);
begin
  application.MessageBox(pchar(msg),pchar(application.title),mb_ok+mb_iconinformation);
end;

function GetGUID:string;
var
 id:tguid;
begin
 if CoCreateGuid(id)=s_ok then
  result:=guidtostring(id);
end;

function SelectDirectory(handle:hwnd;const Caption: string; const Root: WideString;out Directory: string): Boolean;
var
  lpbi:_browseinfo;
  buf:array [0..MAX_PATH] of char;
  id:ishellfolder;
  eaten,att:cardinal;
  rt:pitemidlist;
  initdir:pwidechar;
begin
  result:=false;
  lpbi.hwndOwner:=handle;
  lpbi.lpfn:=nil;
  lpbi.lpszTitle:=pchar(caption);
  lpbi.ulFlags:=BIF_RETURNONLYFSDIRS+64;
  SHGetDesktopFolder(id);
  initdir:=pwchar(root);
  id.ParseDisplayName(0,nil,initdir,eaten,rt,att);
  lpbi.pidlRoot:=rt;
  getmem(lpbi.pszDisplayName,MAX_PATH);
  try
   result:=shgetpathfromidlist(shbrowseforfolder(lpbi),buf);
  except
   freemem(lpbi.pszDisplayName);
  end;
  if result then directory:=buf;
end;

end.