WinAPI函数库

原创 2006年05月25日 14:53:00

{=========================================================================
   功  能: 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.

相关文章推荐

WinAPI函数库

  • 2008年04月15日 10:26
  • 793KB
  • 下载

WinAPI函数库资料下载

  • 2011年02月16日 09:26
  • 88KB
  • 下载

Ramda 函数库参考教程

作者: 阮一峰 日期: 2017年3月 9日 学习函数式编程的过程中,我接触到了 Ramda.js。 我发现,这是一个很重要的库,提供了许多有用的方法,每个 JavaScri...

动态链接库方法 调用winapi函数

  • 2013年01月05日 19:27
  • 2.94MB
  • 下载

lpld函数库

  • 2015年12月08日 11:07
  • 2.47MB
  • 下载

Qt中调用OpenCV函数库时Crashed问题的解决。

这几天想在虚拟机上搭建Ubuntu的开发环境,包括了Matlab和QT(C++)的开发工具安装等,同时由于做图像处理,所以还必须要安装FFMPEG和OpenCV库。下面就讲讲我们安装时出现qt中调用O...

STM32F10xxx_Library_固件函数库

  • 2016年05月19日 16:28
  • 2.79MB
  • 下载

CAN-bus接口函数库使用手册

  • 2015年08月28日 17:25
  • 679KB
  • 下载

C语言开发函数库时利用不透明指针对外隐藏结构体细节

1 模块化设计要求库接口隐藏实现细节作为一个函数库来说,尽力减少和其调用方的耦合,是最基本的设计标准。C语言,作为经典“程序=数据结构+算法”的践行者,在实现函数库的时候,必然存在大量的结构体定义,接...
  • smstong
  • smstong
  • 2016年02月21日 12:15
  • 3566

C++函数库电子手册

  • 2014年11月21日 21:33
  • 1008KB
  • 下载
内容举报
返回顶部
收藏助手
不良信息举报
您举报文章:WinAPI函数库
举报原因:
原因补充:

(最多只允许输入30个字)