xkernel.pas

我自己用的Delphi函数单元 具体说明见打包文件的HELP目录下面

unit xKernel;

interface

uses Windows, Messages, SysUtils, Forms, TlHelp32, Psapi, ShellAPI, Classes, Menus;

type
  TxEnumProcesses_ToolHelp = function (ProcessEntry: TProcessEntry32; pContext: Pointer): Boolean;
  TxEnumProcesses_Psapi = function (ProcessID: DWORD; pContext: Pointer): Boolean;

function GetApplicationFileName(Wnd: HWND): string;
//------------------------------------------------------------------//
function GetLocalComputerName: string;
function GetLocalUserName: string;

//------------------------------------------------------------------//
procedure DeleteMe;
function ShortCutToString(const HotKey:word):string;
function DeleteToRecycleBin(hWindow: HWND; sFileName: string): Boolean;

//------------------------------------------------------------------//
function ExecuteByShell(const sAction, sFileName, sPara: string): Boolean;
function Execute(const Command: string; bWait: Boolean; bShow: Boolean; PI: PProcessInformation): Boolean;
function ExecAndWait(const Command: String; bShow: Boolean = True): Boolean;
function ExecAndGo(const Command: String; bShow: Boolean = True): Boolean;
function ExecRedirect(const Command: String; SL: TStrings): Boolean;


//------------------------------------------------------------------//
function StartProcess(const sFilePath: String): Boolean;
procedure CloseProcess(const sWndClass:string);
function FindProcess(const sWndClass:string):Boolean;

//------------------------------------------------------------------//
procedure DebugStr(S: string ; bSystem : Boolean = True);
procedure DebugStrFmt(const Format: string; const Args: array of const ; bSystem : Boolean = True);
procedure DebugStrVar(const V: Variant; bSystem : Boolean = True);

//------------------------------------------------------------------//
//向自定义调试终端发送调试信息
procedure Debug(S: string);
procedure DebugEx(const Format: string; const Args: array of const);
procedure DebugV(const V: Variant);


implementation

uses xStrings,xTools;

procedure xEnumProcesses_ToolHelp(EnumProc: TxEnumProcesses_ToolHelp; pContext: Pointer);
var
  hSnapshot   : THandle;
  bResult     : Boolean;
  ProcessEntry: TProcessEntry32;
begin
  if not Assigned(EnumProc) then Exit;
  
  hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  if hSnapshot = 0 then
    RaiseLastError('CreateToolhelp32Snapshot');;
  
  ProcessEntry.dwSize := sizeof(ProcessEntry);
  bResult := Process32First(hSnapshot, ProcessEntry);
  while bResult do
  begin
    if not EnumProc(ProcessEntry, pContext) then break;
    
    ProcessEntry.dwSize := sizeof(ProcessEntry);
    bResult := Process32Next(hSnapshot, ProcessEntry);
  end;
  
  CloseHandle(hSnapshot);
end;

procedure xEnumProcesses_Psapi(EnumProc: TxEnumProcesses_Psapi; pContext: Pointer);
var
  cbNeeded: DWORD;  
  P, PP   : PDWORD; 
  I       : Integer;
begin
  if not Assigned(EnumProc) then Exit;
  
  EnumProcesses(nil, 0, cbNeeded);
  GetMem(P, cbNeeded);
  try
    if not EnumProcesses(P, cbNeeded, cbNeeded) then
      RaiseLastError('EnumProcesses');
    
    PP := P;
    for I := 0 to cbNeeded div sizeof(DWORD) - 1 do
    begin
      if not EnumProc(PP^, pContext) then break;
      Inc(PP);
    end;
  finally
    FreeMem(P);
  end;
end;

var
  ApplicationFileName: string;
  
function xEnumProcesses_ToolHelp_GetApplicationFileName_Proc(ProcessEntry: TProcessEntry32; pContext: Pointer): Boolean;
begin
  Result := ProcessEntry.th32ProcessID <> DWORD(pContext);
  if not Result then ApplicationFileName := ProcessEntry.szExeFile;
end;

//------------------------------------------------------------------//
//从指定的窗口句柄取得建立此窗口的模块文件名。

function GetApplicationFileName(Wnd: HWND): string;
var
  Buf              : array[0..255] of char;
  ProcessID        : DWORD;                
  hProcess, hModule: THandle;              
  cbNeeded         : DWORD;                
begin
  GetWindowThreadProcessId(Wnd, @ProcessID);
  if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then
  begin
    xEnumProcesses_ToolHelp(xEnumProcesses_ToolHelp_GetApplicationFileName_Proc, Pointer(ProcessID));
    Result := ApplicationFileName;
  end else
  begin
    hProcess := OpenProcess(PROCESS_ALL_ACCESS, false, ProcessID);
    hModule := 0;
    // 取得第一个 module handle
    EnumProcessModules(hProcess, @hModule, 4, cbNeeded);
    GetModuleFileNameEx(hProcess, hModule, Buf, sizeof(Buf));
    Result := strpas(Buf);
    CloseHandle(hProcess);
  end;
end;

//------------------------------------------------------------------//
//取得本地计算机名
function GetLocalComputerName: string;
var
  aLength: DWORD;
  aLocalComputerName: array[0..MAX_PATH - 1] of Char;
begin
  aLength := MAX_COMPUTERNAME_LENGTH + 1;
  GetComputerName(aLocalComputerName, aLength);
  Result := aLocalComputerName;
end;

//------------------------------------------------------------------//
//取得本地用户名
function GetLocalUserName: string;
var
   aLength: DWORD;
   aUserName: array[0..MAX_PATH - 1] of Char;
begin
    aLength := MAX_PATH;
    GetUserName(aUserName, aLength);
    Result := aUserName;
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;

//------------------------------------------------------------------//
//把快捷键变成一个字符串
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 DeleteToRecycleBin(hWindow: HWND; sFileName: string): Boolean;
var
    SH: TSHFILEOPSTRUCT;
begin
    FillChar(SH, SizeOf(SH),0);
    with SH do
    begin
        Wnd := hWindow;
        wFunc := FO_DELETE;
        pFrom := PChar(sFileName);
        StrCat(pFrom, #0);
        fFlags:= FOF_SILENT or FOF_ALLOWUNDO;
    end;
    Result := SHFileOperation(SH) = 0;
end;

//------------------------------------------------------------------//
//通过外壳执行，调用ShellExecute
function ExecuteByShell(const sAction, sFileName, sPara: string): Boolean;
begin
  Result := ShellExecute(Application.Handle, PChar(sAction), PChar(sFileName), PChar(sPara), PChar(''), SW_SHOW) > 32;
  if not Result then RaiseLastError('ShellExecute');
end;

//------------------------------------------------------------------//
//执行进程
function Execute(const Command: string; bWait: Boolean; bShow: Boolean; PI: PProcessInformation): Boolean;
var
    StartupInfo : TStartupInfo;
    ProcessInfo : TProcessInformation;
//  bSuccess    : Boolean;
begin
    FillChar(StartupInfo, SizeOf(StartupInfo), 0);
    with StartupInfo do
    begin
        cb := SizeOf(TStartupInfo);
        dwFlags := STARTF_USESHOWWINDOW;
        if bShow then wShowWindow := SW_NORMAL
        else wShowWindow := SW_HIDE;
    end;
    Result:=CreateProcess(nil,
                          PChar(Command),                //指向命令行
                          nil,                           //指向进程安全属性
                          nil,                           //指向线程安全属性
                          False,                         //处理继承标志,是否继承父程权利
                          CREATE_NEW_CONSOLE or          //创建标志
                          NORMAL_PRIORITY_CLASS,
                          nil,                           //指向新环境块
                          nil,                           //指向当前目录名
                          StartupInfo,                   //指向STARTUPINFO
                          ProcessInfo);                  //指向PROCESS_INF
    //GetExitCodeProcess(ProcessInfo.hProcess, DWORD(Result));
    if not Result then Exit;
    if bWait then 
    begin
        WaitForInputIdle(ProcessInfo.hProcess, INFINITE);
    	WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
    end;
    if Assigned(PI) then Move(ProcessInfo, PI^, SizeOf(ProcessInfo));
end;

//------------------------------------------------------------------//
//执行子进程，等待返回
function ExecAndWait(const Command: String; bShow: Boolean = True): Boolean;
var
    PI:TProcessInformation;
begin
    Result:=Execute(Command,True,bShow,@PI);
end;

//------------------------------------------------------------------//
//执行子进程，立即返回
function ExecAndGo(const Command: String; bShow: Boolean = True): Boolean;
var
    PI:TProcessInformation;
begin
    Result:=Execute(Command,False,bShow,@PI);
end;

//------------------------------------------------------------------//
//重定向执行子进程，等待执行后返回，SL中存储重定向信息。
function ExecRedirect(const Command: String; SL: TStrings): Boolean;
var
  StartupInfo : TStartupInfo;
  ProcessInfo : TProcessInformation;
  hOutput     : Integer;
  sFilePath   : String;
  pBuf1,pBuf2 : array[0..MAX_PATH] of char;
  
begin
  SL.Clear;

  GetTempPath(MAX_PATH, pBuf1);
  GetTempFileName(pBuf1, PChar('TEMP'), 0, pBuf2);
  sFilePath:= String(pBuf2);
  
  hOutput:=FileCreate(sFilePath);
  try
    FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
    with StartupInfo do
    begin
      cb:= SizeOf(TStartupInfo);
      dwFlags:= STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK or STARTF_USESTDHANDLES;
      wShowWindow:= SW_HIDE;
      hStdInput:= INVALID_HANDLE_VALUE;
      hStdOutput:= hOutput;
      hStdError:= INVALID_HANDLE_VALUE;
    end;

    Result := CreateProcess(nil,PChar(Command), nil, nil, False,
                 NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo);
    if Result then
    begin
      WaitForInputIdle(ProcessInfo.hProcess, INFINITE);
      WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
    end;
  finally
    FileClose(hOutput);
    SL.LoadFromFile(sFilePath);
    DeleteFile(sFilePath);
  end;
end;


//------------------------------------------------------------------//
function StartProcess(const sFilePath : String): Boolean;
begin
	Result := ExecAndGo(sFilePath);
end;

procedure CloseProcess(const sWndClass:string);
begin
    SendMessage(FindWindow(PChar(sWndClass), nil), WM_CLOSE,0,0);
end;

function FindProcess(const sWndClass:string):Boolean;
begin
     if FindWindow(PChar(sWndClass), nil) = 0 then
        Result := False
     else
        Result := True;
end;


//输出到的操作系统的调试信息。若程序在IDE环境中执行，则输出到Event Log。
//bSystem = True时，输出到操作系统；
//bSystem = False时，向自定义调试终端发送调试信息
procedure DebugStr(S: string ; bSystem : Boolean = True);
var
    cds  : TCopyDataStruct;
    hWindow : THandle;
begin
    if bSystem then
    begin
      if not IsIncludeCRLF(S) then S := S + ASC_CRLF;
      OutputDebugString(PChar(S));
    end
    else
    begin
        hWindow := FindWindow('TDebugMsgForm', nil);
        if hWindow <> 0 then
        begin
            try
                cds.cbData := Length(s) + 1;
			    GetMem(cds.lpData, cds.cbData ); //为传递的数据区分配内存
			    StrCopy(cds.lpData, PChar (s));
        	    SendMessage(hWindow, WM_COPYDATA, 0, LParam(@cds));
            finally
			    FreeMem(cds.lpData); //释放资源
            end;
        end;
    end;
end;

//------------------------------------------------------------------//
//输出到操作系统的带格式的调试信息。格式信息与SysUtils.Format相同。
//如： DebugStrFmt('%d %s',[ResponesNo,ReceiveMessage]);
procedure DebugStrFmt(const Format: string; const Args: array of const ; bSystem : Boolean = True);
var
	s:string;
begin
	if bSystem then  DebugStr(SysUtils.Format(Format, Args))
	else
	begin
		FmtStr(s,Format,Args);
		DebugStr(s,false);
	end;
end;

//------------------------------------------------------------------//
//将任意值转换为调试信息，发送。bSystem指示发往自定义调试器，还是系统调试器。
procedure DebugStrVar(const V: Variant; bSystem : Boolean = True);
begin
	DebugStr(varToStr(v),bSystem);
end;

//------------------------------------------------------------------//
procedure Debug(S: string);
begin
	DebugStr(S,False);
end;

procedure DebugEx(const Format: string; const Args: array of const);
begin
    DebugStrFmt(Format,Args,False);
end;

procedure DebugV(const V: Variant);
begin
	DebugStrVar(v,False);
end;

end.