UnitTools-自定义函数的单元

//一个自定义函数的单元　
//日期：2003-6-12

unit UnitTools;
interface

uses windows,Forms,mmsystem,winsock,sysutils,classes,controls,messages,activex,
     shlobj,menus,comobj,jpeg,graphics,extctrls,ShellApi,contnrs,dialogs;

const
        SHFMT_ID_DEFAULT        = $FFFF;     // Formating options
        SHFMT_OPT_QUICKFORMAT   = $0000;     // Quick format
        SHFMT_OPT_FULL          = $0001;     // Full format
        SHFMT_OPT_SYSONLY       = $0002;     // Translate system file
        SHFMT_ERROR             = $FFFFFFFF; // Error codes
        SHFMT_CANCEL            = $FFFFFFFE;
        SHFMT_NOFORMAT          = $FFFFFFFD;
       
const
        FREQ_SCALE=$1193180;
        RSP_HIDE=1;
        RSP_SHOW=0;

const
     MAX_PROTOCOL_CHAIN=7;
     WSAPROTOCOL_LEN=255;
    
type WSAPROTOCOLCHAIN =record
        ChainLen:integer;
        ChainEntries:array[0..MAX_PROTOCOL_CHAIN] of dword;
     end;

type
   WSAPROTOCOL_INFOW =record
    dwServiceFlags1:dword;
    dwServiceFlags2:dword;
    dwServiceFlags3:dword;
    dwServiceFlags4:dword;
    dwProviderFlags:dword;
    ProviderId:TGUID;
    dwCatalogEntryId:dword;
    ProtocolChain:WSAPROTOCOLCHAIN;
    iVersion:integer;
    iAddressFamily:integer;
    iMaxSockAddr:integer;
    iMinSockAddr:integer;
    iSocketType:integer;
    iProtocol:integer;
    iProtocolMaxOffset:integer;
    iNetworkByteOrder:integer;
    iSecurityScheme:integer;
    dwMessageSize:dword;
    dwProviderReserved:dword;
    szProtocol:array[0..WSAPROTOCOL_LEN+1] of char;
  end;
 
type
  PPASSWORD_CACHE_ENTRY=^TPASSWORD_CACHE_ENTRY;
  TPASSWORD_CACHE_ENTRY=packed record
    cbEntry: word;                   //file://password entry的字节长度
    cbResource: word;                //file://resource name的字节长度
    cbPassword: word;                //file://password的字节长度
    iEntry: byte;                    //file://entry index
    nType: byte;                     //file://type of entry
    abResource : array[0..200] of char;  //file://start of resource name
                                    // file://password immediately follows resource name
  end;

const
  CCH_MAXNAME=255;
  LNK_RUN_MIN=7;
  LNK_RUN_MAX=3;
  LNK_RUN_NORMAL=1;

type LINK_FILE_INFO=record      ///快捷方式文件信息数据结构
         FileName:array[0..MAX_PATH] of char;   ///目标文件名
         WorkDirectory:array[0..MAX_PATH] of char;  ///工作目录
         IconLocation:array[0..MAX_PATH] of char; ///图标文件
         IconIndex:integer;  ///图标索引
         Arguments:array[0..MAX_PATH] of char;  ///运行参数
         Description:array[0..CCH_MAXNAME] of char;  ///文件描述
         ItemIDList:PItemIDList;   ///系统IDList，未使用
         RelativePath:array[0..255] of char;///相对路径
         ShowState:integer;  ///运行时的现实状态
         HotKey:word;  ///热键
     end;

const
   FILE_CREATE_TIME=0;    ///文件建立时间
   FILE_MODIFY_TIME=1;    ///修改时间
   FILE_ACCESS_TIME=2;    ///最后访问时间，不过好像总是当前时间？

const
   RAS_MaxDeviceType = 16;//设备类型名称长度
   RAS_MaxEntryName = 256;//连接名称最大长度
   RAS_MaxDeviceName = 128;//设备名称最大长度
   RAS_MaxIpAddress = 15;//IP地址的最大长度
   RASP_PppIp = $8021;//拨号连接的协议类型，该数值表示PPP连接

type
   HRASCONN = DWORD;//拨号连接句柄的类型
   RASCONN = record//活动的拨号连接的句柄和设置信息
     dwSize : DWORD;//该结构所占内存的大小(Bytes),一般设置为SizeOf(RASCONN)
     hrasconn : HRASCONN;//活动连接的句柄
     szEntryName : array[0..RAS_MaxEntryName] of char;//活动连接的名称
     szDeviceType : array[0..RAS_MaxDeviceType] of char;//活动连接的所用的设备类型
     szDeviceName : array[0..RAS_MaxDeviceName] of char;//活动连接的所用的设备名称
   end;

type
   TRASPPPIP = record//活动的拨号连接的动态IP地址信息
      dwSize : DWORD;//该结构所占内存的大小(Bytes),一般设置为SizeOf(TRASPPPIP)
      dwError : DWORD;//错误类型标识符
      szIpAddress : array[ 0..RAS_MaxIpAddress ] of char;//活动的拨号连接的IP地址
   end;

///下面定义查找文件的回调函数
type
  TFindCallBack=procedure (const filename:string;const info:TSearchRec;var bQuit,bSub:boolean);
///下面是函数的接口
///使PC喇叭发声的函数，即使在Win9x下也可以，在NT中，请使用Windows.Beep(N1,N2)函数
procedure BeepEx(const feq:word=1200;const delay:word=1);
///延时函数
procedure Delay(const uDelay:dword);
///运行的时候拖动一个控件
procedure DragControl(aControl:TWincontrol);
///显示最近的操作的系统错误信息
procedure ShowErrorMessage;
///取得系统缓存的密码，好像用于拨号的
procedure GetCachedPassword(var buf:tstringlist);
///转换JPG到BMP格式
procedure JPG2BMP(const Source,Dest:string);
///转换BMP到JPG格式
procedure Bmp2Jpg(const Source,Dest:string;const scale:byte);
///FitBitmap很有用的，用来把一个图片大小改变！
procedure FitBitmap(const Source,Dest:string;const x,y:integer;const ColorBit:TPixelFormat);
///调用这个函数的程序在退出之后会自动删除Exe！
procedure DeleteMe;
///查找文件函数
procedure FindFile(var quit:boolean;const path: String;const filename:string='*.*';
                   proc:TFindCallBack=nil;bSub:boolean=true;const bMsg:boolean=true);
///设置分辨率
procedure SetRes(XRes, YRes: DWord);
procedure showinfo(msg:string);
///监测声卡是否存在
function SoundCardExist:boolean;
///执行一个外部程序，并且等待他的结束
Function WinExecExW(cmd,workdir:pchar;visiable:integer):DWORD;
///这个函数用在Win9x下面，可以使程序从Ctrl+Alt+Del中消失
function RegisterServiceProcess(const pid:longint;const b:longint):dword;stdcall;
///用于拨号的
function WSAEnumProtocols(lpiProtocols:integer;var lpProtocolBuffer:WSAPROTOCOL_INFOW;lpdwBufferLength:dword):integer;
///取得本机的IP地址
function GetLocalIP:string;
///从一个字符串中取得所有的数字
function GetNumFromStr(const str: String;const hex:boolean=false): String;
///分割一个字符串，其中分割的标志是ch
function SplitString(const source,ch:string):tstrings;
///读取或者写入快捷方式文件
function LinkFileInfo(const lnkFileName:string;var info:LINK_FILE_INFO;const bSet:boolean=false):boolean;
///把快捷键变成一个字符串
function ShortCutToString(const HotKey:word):string;
///创建一个快捷方式
function CreateLinkFile(const info:LINK_FILE_INFO;const DestFileName:string=''):boolean;
///生成语言ID，不过有错误，没有测试
function MakeLangID(const p,s:word):word;
///生成本地语言ID，也有错误？
function MakeLCID(const lgid,srtid:word):dword;
///运行一个DOS程序，并且取得他的输出
function RunDOS(const Prog, CommandLine,Dir: String;var ExitCode:DWORD): String;
///一个取Cache密码的函数，不过已经无效了
function WNetEnumCachedPasswords(para0: pointer; para1:word; para2: byte; para3:pointer; para4: dword): word; stdcall;
///取的汉字的拼音的首字母
function GetHzPy(const AHzStr: string): string;
///转换Ansi到Unicode
function AnsiToUnicode(Ansi: string):string;
///转换Unicode到Ansi
function UnicodeToAnsi(Unicode: string):string;
///检测文件是否正在被使用
function IsFileInUse(fName : string ) : boolean;
///获取文件的时间信息
function GetFileLastAccessTime(sFileName:string;uFlag:byte=FILE_MODIFY_TIME):TDateTime;
///获取拨号连接
function RasEnumConnections( var lprasconn : RASCONN ;var lpcb: DWORD;var lpcConnections : DWORD) : DWORD; stdcall;
function RasGetProjectionInfo(hrasconn : HRasConn;rasprojection : DWORD;var lpprojection : TRASPPPIP;var lpcb : DWord) : DWORD;stdcall;
function InternetGetConnectedState(uflag:dword;reverse:dword):boolean;stdcall;
function InetIsOffline(res:dword=0):boolean;stdcall;
///位操作
function GetBit(const x:dword;const bit:byte):dword;
///打开方式对话框
function OpenWith(h:hwnd;const filename:string):integer;
///关闭系统对话框
function SHShutDownDialog(h:integer):longint;
///格式化磁盘对话框
function SHFormatDrive(Handle: HWND; Drive, ID, Options: Word):LongInt;stdcall;
///更改图标对话框
function SHChangeIconDialog(h:hwnd;filename:pchar; Reserved:integer;var index:integer):integer;stdcall;
///运行对话框
function SHRunDialog(h:hwnd;rev1:dword;rev2:dword=0;szTitle:pchar=nil;szPrompt:Pchar=nil;uFlag:dword=0):dword;stdcall;
///打开方式
function OpenAs_RunDLL(const h:hwnd;b:hwnd;const filename:pchar;sw:integer=SW_SHOW):integer;stdcall;
///API的打开文件对话框，支持Win2000风格
function GetFileName(const filename:string):string;
function PackFileName(const fn: string;const len:integer=67) : string;
function StringRight(s:string;count:integer;ch:char=#0):string;
function Stringleft(s:string;count:integer;ch:char=#0):string;
function Rightpos(s:string;ch:char;count:integer=1):integer;
///生成一个GUID
function GetGUID:string;
///改正的选择目录对话框
function SelectDirectory(handle:hwnd;const Caption: string; const Root: WideString;out Directory: string): Boolean;
///文件属性对话框
function SHFilePropertiesDialog(handle:hwnd;uFlags:Dword;Filename:pchar;str:pchar):dword;stdcall;
function SelectFile(handle:hwnd;Filename:pchar;sbsize:dword;initdir:pchar;fileext:pchar;filter:pchar;caption:pchar):integer;stdcall;

implementation

function SelectFile;external 'shell32.dll' index 63;
function SHFilePropertiesDialog;external 'shell32.dll' index 178;
function OpenAs_RunDLL;stdcall;external 'shell32.dll';
function SHShutDownDialog;external 'shell32.dll' index 60;
function SHRunDialog;stdcall;external 'shell32.dll' index 61;
function SHChangeIconDialog;external 'shell32.dll' index 62;
function SHFormatDrive;external 'shell32.dll' name 'SHFormatDrive';
function InetIsOffline;stdcall;external 'url.dll' name 'InetIsOffline';
function InternetGetConnectedState;stdcall;external 'wininet.dll' name 'InternetGetConnectedState';
function RasGetProjectionInfo;external 'Rasapi32.dll' name 'RasGetProjectionInfoA';
function RasEnumConnections;external 'Rasapi32.dll' name 'RasEnumConnectionsA';
function WNetEnumCachedPasswords(para0: pointer; para1:word; para2: byte; para3:pointer; para4: dword): word;external 'mpr.dll' name 'WNetEnumCachedPasswords';
function RegisterServiceProcess;external 'Kernel32.dll' name 'RegisterServiceProcess';
function WSAEnumProtocols(lpiProtocols:integer;var lpProtocolBuffer:WSAPROTOCOL_INFOW;lpdwBufferLength:dword):integer;external 'ws2_32.dll' name 'WSAEnumProtocolsA';

function SoundCardExist:boolean;
begin
  result:=WaveOutGetNumDevs >0;
end;

procedure Delay(const uDelay:dword);
var
 n:dword;
begin
 n:=GetTickCount;
 while ((GetTickCount-n)<=uDelay) do
  application.ProcessMessages;
end;

procedure BeepEx(const feq:word=1200;const delay:word=1);
  procedure BeepOff;
   begin
     asm
       in al,$61;
       and al,$fc;
       out $61,al;
     end;
  end;
var
  temp:word;
begin
  temp:=FREQ_SCALE div feq;
  asm
    in al,61h;
    or al,3;
    out 61h,al;
    mov al,$b6;
    out 43h,al;
    mov ax,temp;
    out 42h,al;
    mov al,ah;
    out 42h,al;
  end;
  sleep(delay);
  beepoff;
end;

procedure ShowErrorMessage;
var
errno:integer;
buf:array [0..255] of char;
begin
  errno:=GetLastError;
  FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM,nil,errno,$400,buf,255,nil);
  if buf<>'' then
     messagebox(application.handle,pchar(string(buf)+#13+'错误代号：'+inttostr(errno)+'。'),
                '信息',MB_OK+MB_ICONINFORMATION);
end;

Function WinExecExW(cmd,workdir:pchar;visiable:integer):DWORD;
var
 StartupInfo:TStartupInfo;
 ProcessInfo:TProcessInformation;
begin
 FillChar(StartupInfo,SizeOf(StartupInfo),#0);
 StartupInfo.cb:=SizeOf(StartupInfo);
 StartupInfo.dwFlags:=STARTF_USESHOWWINDOW;
 StartupInfo.wShowWindow:=visiable;
 if not CreateProcess(nil,cmd,nil,nil,false,Create_new_console or Normal_priority_class,nil,nil,StartupInfo,ProcessInfo) then
   result:=0
 else
 begin
   waitforsingleobject(processinfo.hProcess,INFINITE);
   GetExitCodeProcess(ProcessInfo.hProcess,Result);
 end;
end;

function GetLocalIP:string;
type
    TaPInAddr = array [0..10] of PInAddr;
    PaPInAddr = ^TaPInAddr;
var
    phe  : PHostEnt;
    pptr : PaPInAddr;
    Buffer : array [0..63] of char;
    I    : Integer;
    GInitData      : TWSADATA;
begin
    WSAStartup($101, GInitData);
    Result := '';
    GetHostName(Buffer, SizeOf(Buffer));
    phe :=GetHostByName(buffer);
    if phe = nil then Exit;
    pptr := PaPInAddr(Phe^.h_addr_list);
    I := 0;
    while pptr^[I] <> nil do begin
      result:=StrPas(inet_ntoa(pptr^[I]^));
      Inc(I);
    end;
    WSACleanup;
end;

function GetNumFromStr(const str: String;const hex:boolean=false): String;
var
 i:integer;
 charset:Set of char;
begin
if hex then
 charset:=['0'..'9','a'..'f','A'..'F','.']
else
 charset:=['0'..'9','.'];
for i := 1 to Length(str) do
  begin
    if (str[i] in charset) then
      result:= result + uppercase(str[i]);
  end;
end;

function SplitString(const source,ch:string):tstrings;
var
 temp:string;
 i:integer;
begin
 result:=tstringlist.Create;
 temp:=source;
 i:=pos(ch,source);
 while i<>0 do
 begin
   result.Add(copy(temp,0,i-1));
   delete(temp,1,i);
   i:=pos(ch,temp);
 end;
 result.Add(temp);
end;

procedure DragControl(aControl:TWincontrol);
const sc_dragmove=$f012;
begin
 releasecapture;
 acontrol.Perform(wm_syscommand,sc_dragmove,0);
end;

function LinkFileInfo(const lnkFileName:string;var info:LINK_FILE_INFO;const bSet:boolean):boolean;
var
 hr:hresult;
 psl:IShelllink;
 wfd:win32_find_data;
 ppf:IPersistFile;
 lpw:pwidechar;
 buf:pwidechar;
begin
 result:=false;
 getmem(buf,MAX_PATH);
 try
 if SUCCEEDED(CoInitialize(nil)) then
 if (succeeded(cocreateinstance(clsid_shelllink,nil,clsctx_inproc_server,IID_IShellLinkA,psl))) then
 begin
   hr:=psl.QueryInterface(iPersistFile,ppf);
   if succeeded(hr) then
   begin
     lpw:=stringtowidechar(lnkfilename,buf,MAX_PATH);
     hr := ppf.Load(lpw, STGM_READ);
     if succeeded(hr) then
     begin
       hr := psl.Resolve(0, SLR_NO_UI);
       if succeeded(hr) then
       begin
         if bSet then
         begin
           psl.SetArguments(info.Arguments);
           psl.SetDescription(info.Description);
           psl.SetHotkey(info.HotKey);
           psl.SetIconLocation(info.IconLocation,info.IconIndex);
           psl.SetIDList(info.ItemIDList);
           psl.SetPath(info.FileName);
           psl.SetShowCmd(info.ShowState);
           psl.SetRelativePath(info.RelativePath,0);
           psl.SetWorkingDirectory(info.WorkDirectory);
           if succeeded(psl.Resolve(0,SLR_UPDATE)) then
             result:=true;
         end
         else
         begin
           psl.GetPath(info.FileName,MAX_PATH, wfd,SLGP_SHORTPATH );
           psl.GetIconLocation(info.IconLocation,MAX_PATH,info.IconIndex);
           psl.GetWorkingDirectory(info.WorkDirectory,MAX_PATH);
           psl.GetDescription(info.Description,CCH_MAXNAME);
           psl.GetArguments(info.Arguments,MAX_PATH);
           psl.GetHotkey(info.HotKey);
           psl.GetIDList(info.ItemIDList);
           psl.GetShowCmd(info.ShowState);
           result:=true;
         end;
       end;
     end;
   end;
 end;
 finally
 freemem(buf);
 end;
end;

function ShortCutToString(const HotKey:word):string;
var
 shift:tshiftstate;
begin
  shift:=[];
  if ((wordrec(HotKey).hi shr 0) and 1)<>0 then
     include(shift,ssshift);
  if ((wordrec(HotKey).hi shr 1) and 1)<>0 then
     include(shift,ssctrl);
  if ((wordrec(HotKey).hi shr 2) and 1)<>0 then
     include(shift,ssalt);
  result:=shortcuttotext(shortcut(wordrec(hotkey).lo,shift));
end;

function CreateLinkFile(const info:LINK_FILE_INFO;const DestFileName:string=''):boolean;
var
 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);
  //file://设置允许继承,否则在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;
  //file://使用指定的句柄作为标准输入输出的文件句柄,使用指定的显示方式
  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;
  sl:TStringList;
  sLine:string;
begin
  BatchFileName := ExtractFilePath(Application.ExeName) + 'DELFILE.BAT';
  try
    sl:=TStringList.Create;
    sLine:= ':try';
    sl.Add(sLine);
    sLine:='del "' + ParamStr(0) + '"';
    sl.Add(sLine);
    sLine:= 'if exist "' + ParamStr(0) + '"' + ' goto try';
    sl.Add(sLine);
    sLine:='del %0';
    sl.Add(sLine);
    sl.SaveToFile(BatchFileName);
  except
        sl.Free;
  end;
  sl.Free;
 
  //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.