{=========================================================================
功 能: WinAPI函数库
时 间: SilverLong 2005/10/09
版 本: 1.0
备 注:
=========================================================================}
unit WinAPI;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, StdCtrls, ExtCtrls, Mask, ImgList, ToolWin ,winsock,
ComObj,WinInet,Registry, Buttons, Menus,ShellApi, Grids,TlHelp32;
const
SystemBasicInformation = 0;
SystemPerformanceInformation = 2;
SystemTimeInformation = 3;
type
TPDWord = ^DWORD;
TSystem_Basic_Information = packed record
dwUnknown1: DWORD;
uKeMaximumIncrement: ULONG;
uPageSize: ULONG;
uMmNumberOfPhysicalPages: ULONG;
uMmLowestPhysicalPage: ULONG;
uMmHighestPhysicalPage: ULONG;
uAllocationGranularity: ULONG;
pLowestUserAddress: Pointer;
pMmHighestUserAddress: Pointer;
uKeActiveProcessors: ULONG;
bKeNumberProcessors: byte;
bUnknown2: byte;
wUnknown3: word;
end;
type
TSystem_Performance_Information = packed record
liIdleTime: LARGE_INTEGER; {LARGE_INTEGER}
dwSpare: array[0..75] of DWORD;
end;
type
TSystem_Time_Information = packed record
liKeBootTime: LARGE_INTEGER;
liKeSystemTime: LARGE_INTEGER;
liExpTimeZoneBias: LARGE_INTEGER;
uCurrentTimeZoneId: ULONG;
dwReserved: DWORD;
end;
var
NtQuerySystemInformation: function(infoClass: DWORD;
buffer: Pointer;
bufSize: DWORD;
returnSize: TPDword): DWORD; stdcall = nil;
liOldIdleTime: LARGE_INTEGER = ();
liOldSystemTime: LARGE_INTEGER = ();
SysBaseInfo: TSystem_Basic_Information;
SysPerfInfo: TSystem_Performance_Information;
SysTimeInfo: TSystem_Time_Information;
status: Longint; {long}
dbSystemTime: Double;
dbIdleTime: Double;
//function GetCPUUsage:Double;
const
{第一组:按钮内容选择}
OKOnly=0;{仅显示"确定"按钮}
OKCancel=1;{显示"确定"和"取消"按钮}
AbortRetryIgnore=2;{"中止""重试""放弃"}
YesNoCancel=3;{"是""否""取消"}
YesNo=4;{"是"和"否"}
RetryCancel=5;{"重试""取消"}
{第二组:显示图标选择}
Critical=16;{"STOP"图标}
Question=32;{"?"图标}
Excalamation=48;{"!"图标}
Information=64;{"i"图标}
{第三组:缺省指针位置(激活状态)}
DefaultButton1=0;{第一按钮}
DefaultButton2=256;{第二按钮}
DefaultButton3=512;{第三按钮}
{第四组:信息框方式}
ApplicationModal=0;{应用方式}
SystemModal=4096;{系统方式}
//功 能: 将Pascal字符串转换成null结尾字符串函数
function StrToPch(Str:string):PChar;
//功 能: 消息框
function MsgBox(msg:string;mbType:Word;title:string):Word;
//功 能: 拷贝文件
function CopyF(var ExistingFileName:string;const NewFileName:string;var
Mode:Integer):Boolean;
{************************************}
//功 能: 得到进程号
function GetProID(ProName:String):int64;
//功 能: 杀死进程
procedure KillProByName(proname:String);
//功 能: 将字符转换成大写
function UP(var str:String):String;
//功 能: 避免调试
function EnableDebugPrivilege: Boolean;
//功 能: 杀死进程
function KillTask(ExeFileName: string): Integer;
//功 能: 取得一台机器的CPU占用率
function GetCPUUsage:Double;
//功 能: 取得用户名称
function GetUserName: AnsiString;
//功 能: 取得 Windows 产品序号
function GetWindowsProductID: string;
//功 能: 屏蔽系统按键
Function ShieldSyskeystoke(State:Integer):Boolean;
//隐藏Windows的任务条
procedure hideTaskbar(Title:String);
//功 能: 显示Windows的任务条
procedure showTaskbar(Title:String);
//功 能: 驱动器容量
Procedure ShowDriverContent(Driver:PChar;var AllContent,DoContent:PChar);
//重定向一个DOS应用程序
function CreateDOSProcessRedirected(const CommandLine, InputFile,
OutputFile, ErrMsg :string):boolean;
implementation
{=================================================================
功 能: 将Pascal字符串转换成null结尾字符串函数
参 数: Str 原字符串
返回值: PChar
备 注:
版 本:
1.0 2005-10-18 9:05
=================================================================}
function StrToPch(Str:string):PChar;
var
a:PChar;
begin
a:=StrAlloc(Length(Str)+1);
StrPCopy(a,Str);
StrToPch:=a;
end;
{=================================================================
功 能: 消息框
参 数: msg 消息
mbType 按钮类型
title 标题
返回值: Word
备 注:
版 本:
1.0 2005-10-18 9:05
=================================================================}
function MsgBox(msg:string;mbType:Word;title:string):Word;
var hWnd1:HWND;
pText,pCaption:Pchar;
begin
pText:=StrToPch(title);
pCaption:=StrToPch(msg);
hWnd1:=GetActiveWindow();
MsgBox:=MessageBox(hWnd1,pText,pCaption,mbType);
end;
{=================================================================
功 能: 拷贝文件
参 数: ExistingFileName 原文件名(包含路径)
NewFileName 新的文件名(包含路径)
Mode 模式
返回值: false 失败,true 成功
备 注:
版 本:
1.0 2005-10-18 9:05
=================================================================}
function CopyF(var ExistingFileName:string;const NewFileName:string;var
Mode:Integer):Boolean;
var
EFile,NFile:PChar;
CpFlag,FailIfExists:Boolean;
msg:string;
ErrID,mbType:integer;
begin
EFile:=StrToPch(ExistingFileName);
NFile:=StrToPch(NewFileName);
if (Mode=1) or (Mode=3) then
FailIfExists:=True
else
FailIfExists:=False;
CpFlag:=CopyFile(EFile,NFile,FailIfExists);
if not CpFlag then
begin
ErrID:=GetLastError();
ExistingFileName:=SysErrorMessage(ErrID);
if Mode<2 then
begin
msg:='CopyFile Error!';
mbType:=OKOnly+Excalamation;
MsgBox(msg,mbType,ExistingFileName);
end;
Mode:=ErrID;
end;
CopyF:=CpFlag;
end;
{=================================================================
功 能: 将字符转换成大写
参 数: str 字符串
返回值: 转换成大写的字符串
备 注:
版 本:
1.0 2005-10-18 9:05
=================================================================}
function UP(var str:String):String;
var j:integer;
begin
try
for j := 1 to length(str) do
str[j] := UpCase(str[j]);
except
end;
end;
{=================================================================
功 能: 避免调试
参 数: 无
返回值: false 失败,true 成功
备 注:
版 本:
1.0 2005-10-18 9:05
=================================================================}
function EnableDebugPrivilege: Boolean;
function EnablePrivilege(hToken: Cardinal; PrivName: string; bEnable: Boolean): Boolean;
var
TP: TOKEN_PRIVILEGES;
Dummy: Cardinal;
begin
TP.PrivilegeCount := 1;
LookupPrivilegevalue(nil, pchar(PrivName), TP.Privileges[0].Luid);
if bEnable then
TP.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED
else TP.Privileges[0].Attributes := 0;
AdjustTokenPrivileges(hToken, False, TP, SizeOf(TP), nil, Dummy);
Result := GetLastError = ERROR_SUCCESS;
end;
var
hToken: Cardinal;
begin
OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES, hToken);
if EnablePrivilege(hToken, 'SeDebugPrivilege', True) then
ShowMessage('OK');
CloseHandle(hToken);
end;
{=================================================================
功 能: 杀死进程
参 数: ExeFileName:String 程序名
返回值: Integer 小于0则删除失败,大于0则删除成功
备 注:
版 本:
1.0 2005-10-18 9:05
=================================================================}
function KillTask(ExeFileName: string): Integer;
const
PROCESS_TERMINATE = $0001;
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
begin
Result := 0;
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
while Integer(ContinueLoop) <> 0 do
begin
if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
UpperCase(ExeFileName))) then
Result := Integer(TerminateProcess(
OpenProcess(PROCESS_TERMINATE,
BOOL(0),
FProcessEntry32.th32ProcessID),
0));
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
CloseHandle(FSnapshotHandle);
end;
{=================================================================
功 能: 得到进程号
参 数: ProName:String 程序名
返回值: int64 进程号
备 注:
版 本:
1.0 2005-10-18 9:05
=================================================================}
function GetProID(ProName:String):int64;
var //p: pProcessInfo;
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
tmp:String;
begin
result:=0;
try
Up(ProName);
FSnapshotHandle := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS,0);
FProcessEntry32.dwSize:=Sizeof(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle,FProcessEntry32);
while ContinueLoop do
begin
//New(p);
tmp:=FProcessEntry32.szExeFile;
Up(tmp);
if ProName=tmp then
begin
result:= FProcessEntry32.th32ProcessID;
break;
end;
ContinueLoop:=Process32Next(FSnapshotHandle,FProcessEntry32);
end;
except
end;
end;
{=================================================================
功 能: 杀死进程
参 数: ProName:String 程序名
返回值: 无
备 注:
版 本:
1.0 2005-10-18 9:05
=================================================================}
procedure KillProByName(proname:String);
var
HProcess: Thandle;
uExitCode: int64;
ID:int64;
begin
try
ID := GetProID(proname);
if ID > 0 then
hProcess := openprocess(PROCESS_TERMINATE,FALSE,ID);
if TerminateProcess(hProcess,3838) then
begin
Application.MessageBox('删除进程成功.', 'Look', MB_OK);
end;
except
end;
end;
function Li2Double(x: LARGE_INTEGER): Double;
begin
Result := x.HighPart * 4.294967296E9 + x.LowPart
end;
{=================================================================
功 能: 取得一台机器的CPU占用率
参 数: 无
返回值: CPU占用率
备 注:
版 本:
1.0 2005-10-18 9:05
=================================================================}
function GetCPUUsage:Double;
var
bLoopAborted : boolean;
begin
if @NtQuerySystemInformation = nil then
NtQuerySystemInformation := GetProcAddress(GetModuleHandle('ntdll.dll'),
'NtQuerySystemInformation');
status := NtQuerySystemInformation(SystemBasicInformation
, @SysBaseInfo, SizeOf(SysBaseInfo), nil);
if status <> 0 then Exit;
bLoopAborted := False;
while not bLoopAborted do
begin
status := NtQuerySystemInformation(SystemTimeInformation
, @SysTimeInfo, SizeOf(SysTimeInfo), 0);
if status <> 0 then Exit;
status := NtQuerySystemInformation(SystemPerformanceInformation
, @SysPerfInfo, SizeOf(SysPerfInfo),
nil);
if status <> 0 then Exit;
if (liOldIdleTime.QuadPart <> 0) then
begin
dbIdleTime := Li2Double(SysPerfInfo.liIdleTime) - Li2Double(liOldIdleTime);
dbSystemTime := Li2Double(SysTimeInfo.liKeSystemTime) - Li2Double(liOldSystemTime);
dbIdleTime := dbIdleTime / dbSystemTime;
dbIdleTime := 100.0 - dbIdleTime * 100.0 / SysBaseInfo.bKeNumberProcessors + 0.5;
Result:=dbIdleTime;
bLoopAborted:=True;
end;
// store new CPU‘s idle and
End;
End;
{=================================================================
功 能: 取得用户名称
参 数: 无
返回值: 用户名称
备 注:
版 本:
1.0 2005-10-18 9:05
=================================================================}
function GetUserName: AnsiString;
var
lpName: PAnsiChar;
lpUserName: PAnsiChar;
lpnLength: DWORD;
begin
Result := '';
lpnLength := 0;
WNetGetUser(nil, nil, lpnLength); // 取得字串所需的长度
if lpnLength > 0 then
begin
GetMem(lpUserName, lpnLength);
if WNetGetUser(lpName, lpUserName, lpnLength) = NO_ERROR then
Result := lpUserName;
FreeMem(lpUserName, lpnLength);
end;
end; { GetUserName }
{=================================================================
功 能: 取得 Windows 产品序号
参 数: 无
返回值: Windows 产品序号
备 注:
版 本:
1.0 2005-10-18 9:05
=================================================================}
function GetWindowsProductID: string;
var
reg: TRegistry;
begin
Result := '';
reg := TRegistry.Create;
with reg do
begin
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('Software/Microsoft/Windows/CurrentVersion', False);
Result := ReadString('ProductID');
end;
reg.Free;
End;
{=================================================================
功 能: 屏蔽系统按键
参 数: State 状态
返回值: Boolean(成功: True 失败: False)
备 注:也许你希望程序在运行时不想让用户按系统按键 Alt-Tab
或 Ctrl-Alt-Del，那么可以通过以下的程序来屏蔽这些按键。
版 本:
1.0 2005-10-18 9:05
=================================================================}
Function ShieldSyskeystoke(State:Integer):Boolean;
var tmp,Flag :integer;
Begin
Result:=False;
tmp := 0;
Flag := 1;
Case State Of
1:Begin
SystemParametersInfo(SPI_SETFASTTASKSWITCH, Flag, @tmp, 0); //屏蔽 Alt-Tab
Result:=True;
End;
2:Begin
SystemParametersInfo(SPI_SCREENSAVERRUNNING,Flag, @tmp, 0);//屏蔽 Ctrl-Alt-Del
Result:=True;
End;
Else
Result:=False;
End;
End;
{=================================================================
功 能: 隐藏Windows的任务条
参 数: Title 标题条
返回值: 无
备 注:找到标题条的句
柄，然后向它发送相应消息（SW_HIDE）即可
版 本:
1.0 2005-10-18 9:05
=================================================================}
procedure hideTaskbar(Title:String);
var wndHandle : THandle;
wndClass : array[0..50] of Char;
begin
StrPCopy(@wndClass[0], Title);//'Shell_TrayWnd');
wndHandle := FindWindow(@wndClass[0], nil);
ShowWindow(wndHandle, SW_HIDE);
End;
{=================================================================
功 能: 显示Windows的任务条
参 数: Title 标题条
返回值: 无
备 注:找到标题条的句
柄，然后向它发送相应消息（SW_RESTORE）即可
版 本:
1.0 2005-10-18 9:05
=================================================================}
procedure showTaskbar(Title:String);
var wndHandle : THandle;
wndClass : array[0..50] of Char;
begin
StrPCopy(@wndClass[0], Title);//'Shell_TrayWnd');
wndHandle := FindWindow(@wndClass[0], nil);
ShowWindow(wndHandle, SW_RESTORE);
end;
{=================================================================
功 能: 驱动器容量
参 数: Driver 驱动器(要显示的驱动器名,如：driver:='c:/';)
返回值: String(驱动器容量)
备 注:要得到驱动器的容量和剩余容量，用下面的程序
版 本:
1.0 2005-10-18 9:05
=================================================================}
Procedure ShowDriverContent(Driver:PChar;var AllContent,DoContent:PChar);
var
sec1, byt1, cl1, cl2:Longword;
AllStr,DoString:String;
Begin
GetDiskFreeSpace(Driver, sec1, byt1, cl1, cl2);
cl1 := cl1 * sec1 * byt1;
cl2 := cl2 * sec1 * byt1;
AllStr:=Formatfloat('###,##0',cl2);//'该驱动器总共容量' + Formatfloat('###,##0',cl2) + '字节';
DoString:=Formatfloat('###,##0',cl1);//'该驱动器可用容量' + Formatfloat('###,##0',cl1) + '字节';
AllContent:=PChar(AllStr);
DoContent:=PChar(DoString);
End;
{=================================================================
功 能 : 重定向一个DOS应用程序
描述 : executes a (DOS!) app defined in the CommandLine
parameter redirected to take input from InputFile
and give output to OutputFile
返回值 : True on success
参 数 :
CommandLine : the command line for the app,
including its full path
InputFile : the ascii file where from the app
takes input
OutputFile : the ascii file to which the app's
output is redirected
ErrMsg : additional error message string.
Can be empty
Error checking : YES
Target :
版 本 :1.0 2005-10-18 9:05
备 注 :
例程 :
CreateDOSProcessRedirected('C:/MyDOSApp.exe',
'C:/InputPut.txt',
'C:/OutPut.txt',
'Please, record this message')
=================================================================}
function CreateDOSProcessRedirected(const CommandLine, InputFile,
OutputFile, ErrMsg :string):boolean;
const
ROUTINE_ID = '[function: CreateDOSProcessRedirected ]';
var
OldCursor : TCursor;
pCommandLine : array[0..MAX_PATH] of char;
pInputFile,
pOutPutFile : array[0..MAX_PATH] of char;
StartupInfo : TStartupInfo;
ProcessInfo : TProcessInformation;
SecAtrrs : TSecurityAttributes;
hAppProcess,
hAppThread,
hInputFile,
hOutputFile : THandle;
begin
Result := False;
{ Check for InputFile existence }
if not FileExists(InputFile)
then
raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
'Input file * %s *' + #10 +
'does not exist' + #10 + #10 +
ErrMsg, [InputFile]);
{ Save the cursor }
OldCursor := Screen.Cursor;
Screen.Cursor := crHourglass;
{ Copy the parameter Pascal strings to null terminated
strings }
StrPCopy(pCommandLine, CommandLine);
StrPCopy(pInputFile, InputFile);
StrPCopy(pOutPutFile, OutputFile);
TRY
{ Prepare SecAtrrs structure for the CreateFile calls.
This SecAttrs structure is needed in this case because
we want the returned handle can be inherited by child
process. This is true when running under WinNT.
As for Win95, the documentation is quite ambiguous }
FillChar(SecAtrrs, SizeOf(SecAtrrs), #0);
SecAtrrs.nLength := SizeOf(SecAtrrs);
SecAtrrs.lpSecurityDescriptor := nil;
SecAtrrs.bInheritHandle := True;
{ Create the appropriate handle for the input file }
hInputFile := CreateFile(pInputFile,
{pointer to name of the file }
GENERIC_READ or GENERIC_WRITE,
{access (read-write) mode }
FILE_SHARE_READ or FILE_SHARE_WRITE,
{share mode }
@SecAtrrs,
{pointer to security attributes }
OPEN_ALWAYS,
{how to create }
FILE_ATTRIBUTE_NORMAL or FILE_FLAG_WRITE_THROUGH,
{ file attributes }
0 ); {handle to file with attributes to copy }
{ Is hInputFile a valid handle? }
if hInputFile = INVALID_HANDLE_VALUE
then
raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
'WinApi function CreateFile returned an' +
'invalid handle value' + #10 +
'for the input file * %s *' + #10 + #10 +
ErrMsg, [InputFile]);
{ Create the appropriate handle for the output file }
hOutputFile := CreateFile(pOutPutFile,
{pointer to name of the file }
GENERIC_READ or GENERIC_WRITE,
{access (read-write) mode }
FILE_SHARE_READ or FILE_SHARE_WRITE,
{share mode }
@SecAtrrs,
{pointer to security attributes }
CREATE_ALWAYS,
{ how to create }
FILE_ATTRIBUTE_NORMAL or FILE_FLAG_WRITE_THROUGH,
{file attributes }
0 );
{handle to file with attributes to copy }
{ Is hOutputFile a valid handle? }
if hOutputFile = INVALID_HANDLE_VALUE
then
raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
'WinApi function CreateFile returned an' +
'invalid handle value' + #10 +
'for the output file * %s *' + #10 + #10 +
ErrMsg, [OutputFile]);
{ Prepare StartupInfo structure }
FillChar(StartupInfo, SizeOf(StartupInfo), #0);
StartupInfo.cb := SizeOf(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW or
STARTF_USESTDHANDLES;
StartupInfo.wShowWindow := SW_HIDE;
StartupInfo.hStdOutput := hOutputFile;
StartupInfo.hStdInput := hInputFile;
{ Create the app }
Result := CreateProcess(nil,
{ pointer to name of executable module }
pCommandLine,
{ pointer to command line string }
nil,
{ pointer to process security attributes }
nil,
{ pointer to thread security attributes }
True,
{ handle inheritance flag }
HIGH_PRIORITY_CLASS,
{ creation flags }
nil,
{ pointer to new environment block }
nil,
{ pointer to current directory name }
StartupInfo,
{ pointer to STARTUPINFO }
ProcessInfo);
{ pointer to PROCESS_INF }
{ wait for the app to finish its job and take the
handles to free them later }
if Result
then
begin
WaitforSingleObject(ProcessInfo.hProcess, INFINITE);
hAppProcess := ProcessInfo.hProcess;
hAppThread := ProcessInfo.hThread;
end
else
raise Exception.Create(ROUTINE_ID + #10 + #10 +
'Function failure' + #10 + #10 +
ErrMsg);
FINALLY
{ Close the handles.
Kernel objects, like the process and the files
we created in this case, are maintained by a usage
count. So, for cleaning up purposes, we have to
close the handles to inform the system that we don't
need the objects anymore }
if hOutputFile <> 0 then CloseHandle(hOutputFile);
if hInputFile <> 0 then CloseHandle(hInputFile);
if hAppThread <> 0 then CloseHandle(hAppThread);
if hAppProcess <> 0 then CloseHandle(hAppProcess);
{ Restore the old cursor }
Screen.Cursor:= OldCursor;
END;
end; { CreateDOSProcessRedirected }
{=================================================================
功 能: 提取当前光标下的单词
参 数:
返回值:
备 注: 这个函数能够用来提取当前光标下的单词：
版 本:
1.0 2005-10-18 9:05
=================================================================}
function RECharIndexByPos(Memo: TMemo;X, Y: Integer): Integer;
{ function returns absolute character position }
{ for given cursor coordinates }
var
P: TPoint;
begin
P := Point(X, Y);
Result := SendMessage(Memo.Handle,EM_CHARFROMPOS, 0, longint(@P));
end;
{=================================================================
功 能:
参 数:
返回值:
备 注:
版 本:
1.0 2005-10-18 9:05
=================================================================}
var mstrmResFile:TMemoryStream;
procedure ParseResFile;
function GetTypeName( bConvertToType : boolean; piVal : pointer ) : string;
var
w : WORD;
wc : WideChar;
begin
Result := '';
/
// Get the type or name, which is either a integer or a WideString
{Get the first byte of the type/name. If this is 0xFFFF then the
following byte is the resource type/name. If it is not, then
this is the first byte of the first char of the type/name}
mstrmResFile.Read( w, 2 );
if( w = $FFFF ) then
begin
{Get the type/name}
mstrmResFile.Read( w, 2 );
if( piVal <> nil ) then
integer(piVal^) := w;
if( bConvertToType ) then
begin
case( w ) of
1 : Result := 'RT_CURSOR';
2 : Result := 'RT_BITMAP';
3 : Result := 'RT_ICON';
4 : Result := 'RT_MENU';
5 : Result := 'RT_DIALOG';
6 : Result := 'RT_STRING';
7 : Result := 'RT_FONTDIR';
8 : Result := 'RT_FONT';
9 : Result := 'RT_ACCELERATOR';
10 : Result := 'RT_RCDATA';
12 : Result := 'RT_GROUP_CURSOR';
14 : Result := 'RT_GROUP_ICON';
11 : Result := 'RT_MESSAGETABLE';
16 : Result := 'RT_VERSION';
17 : Result := 'RT_DLGINCLUDE';
19 : Result := 'RT_PLUGPLAY';
20 : Result := 'RT_VXD';
21 : Result := 'RT_ANICURSOR';
else
Result := '?? ' + IntToStr( w );
end;
end
else
Result := IntToStr( w );
end
else begin
if( piVal <> nil ) then
integer(piVal^) := -1;
{'Undo' last read}
mstrmResFile.Position := mstrmResFile.Position - 2;
repeat
{Get a char}
mstrmResFile.Read( wc, sizeof( WideChar ) );
{Add char to the string}
Result := Result + wc;
{Was the last char read the NULL terminator?}
until( integer(wc) = 0 );
end;
end;
function GetPadAmount( iVal : integer ) : integer;
begin
Result := 0;
while( (iVal mod 4) <> 0 ) do
begin
inc( iVal );
inc( Result );
end;
end;
var
li : TListItem;
sType : string;
sName : string;
iTypeVal : integer;
iDataSize : integer;
iHeaderSize : integer;
iHeaderOffset : integer;
begin
{Clear current items}
//lv_ResTypes.Items.BeginUpdate;
//lv_ResTypes.Items.Clear;
//lv_ResTypes.Items.EndUpdate;
if( mstrmResFile = nil ) then
Exit;
mstrmResFile.Position := 0;
{32bytes for empty record}
if( mstrmResFile.Size < 32 ) then
begin
ShowMessage( 'File too small' );
Exit;
end;
{Skip over header}
mstrmResFile.Position := 32;
{Parse the file}
while( mstrmResFile.Position < mstrmResFile.Size ) do
begin
{Save offset of the header}
iHeaderOffset := mstrmResFile.Position;
{Get the data size}
mstrmResFile.Read( iDataSize, 4 );
{Get the header size}
mstrmResFile.Read( iHeaderSize, 4 );
{Get the type}
sType := GetTypeName( true, @iTypeVal );
{Get the name}
sName := GetTypeName( false, nil );
{Add to the list view}
//li := lv_ResTypes.Items.Add;
li.Caption := IntToStr( iHeaderOffset );
li.SubItems.Add( IntToStr( iHeaderSize ) );
li.SubItems.Add( sType );
li.SubItems.Add( sName );
li.Data := pointer(iTypeVal);
{Go to end of header}
mstrmResFile.Position := iHeaderOffset + iHeaderSize;
{Go to end of data (ie to next header, if there is one)
Remember to move over any alignment bits}
mstrmResFile.Position := mstrmResFile.Position + iDataSize + GetPadAmount( iDataSize );
end;
end;
end.
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
