Delphi单元--共50个函数
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.
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.
