unit tools;

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; //password entry的字节长度

cbResource: word;//resource name的字节长度

cbPassword: word;//password的字节长度

iEntry: byte;//entry index

nType: byte; //type of entry

abResource : array[0..200] of char;//start of resource name

 //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;

 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);

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);

procedure JPG2BMP(const Source,Dest:string);

procedure Bmp2Jpg(const Source,Dest:string;const scale:byte);

procedure FitBitmap(const Source,Dest:string;const x,y:integer;const ColorBit:TPixelFormat);

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;

function RegisterServiceProcess(const pid:longint;const b:longint):dword;stdcall;

function WSAEnumProtocols(lpiProtocols:integer;var lpProtocolBuffer:WSAPROTOCOL_INFOW;lpdwBufferLength:dword):integer;

function GetLocalIP:string;

function GetNumFromStr(const str: String;const hex:boolean=false): String;

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;

function MakeLangID(const p,s:word):word;

function MakeLCID(const lgid,srtid:word):dword;

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

function WNetEnumCachedPasswords(para0: pointer; para1:word; para2: byte; para3:pointer; para4: dword): word; stdcall;

function GetHzPy(const AHzStr: string): string;

function AnsiToUnicode(Ansi: string):string;

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;

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;

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

in charset) then

result:= result + uppercase(str);

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);

//设置允许继承,否则在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 >= #160) and (AHzStr[i + 1] >= #160) then

begin

HzOrd := (Ord(AHzStr) - 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;

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<>#0) or (a[i+1]<>#0)) do begin

j:=IntToHex(Integer(a),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=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;

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.