Re: [delphi-br] Travar Sistema

[JJW Informática Ltda . - Roberto]

uses
  Forms,
  Classes,
  SysUtils,
  Windows,
  Controls,
  Psapi,
  tlhelp32;

type
  TJJWProcessInformation = record
    FileName: string;
    Path: string;
  end;

  TJJWProcessList = array of TJJWProcessInformation;

// retira a lista de processos de do windows 98  
procedure CreateWin9xProcessList(var AList: TJJWProcessList);
var
  hSnapShot: THandle;
  ProcInfo: TProcessEntry32;
  I: Integer;
begin
  SetLength(AList, 0);

  hSnapShot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  if (hSnapShot <> THandle(-1)) then
  begin
    ProcInfo.dwSize := SizeOf(ProcInfo);
    if (Process32First(hSnapshot, ProcInfo)) then
    begin
      I := Length(AList);
      SetLength(AList, I +1);
      AList[I].FileName := ExtractFileName(ProcInfo.szExeFile);
      AList[I].Path := ExtractFilePath(ProcInfo.szExeFile);

      while (Process32Next(hSnapShot, ProcInfo)) do
      begin
        I := Length(AList);
        SetLength(AList, I +1);
        AList[I].FileName := ExtractFileName(ProcInfo.szExeFile);
        AList[I].Path := ExtractFilePath(ProcInfo.szExeFile);
      end;
    end;
    CloseHandle(hSnapShot);
  end;
end;

// retira a lista de processos do windows NT/2000/XP/2003
procedure CreateWinNTProcessList(var AList: TJJWProcessList);

  type
    PTOKEN_USER = ^TOKEN_USER;

    _TOKEN_USER = record
      User: TSidAndAttributes;
    end;

    TOKEN_USER = _TOKEN_USER;

  // retorna o domínio e usuário dono de um processo
  function GetUserAndDomainFromPID(ProcessId: DWORD;
    var User, Domain: string): Boolean;
  var
    hToken: THandle;
    cbBuf: Cardinal;
    ptiUser: PTOKEN_USER;
    snu: SID_NAME_USE;
    ProcessHandle: THandle;
    UserSize, DomainSize: DWORD;
    bSuccess: Boolean;
  begin
    Result := False;
    ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION, False, ProcessId);
    if ProcessHandle <> 0 then
    begin
    //  EnableProcessPrivilege(ProcessHandle, 'SeSecurityPrivilege', True);
      if OpenProcessToken(ProcessHandle, TOKEN_QUERY, hToken) then
      begin
        bSuccess := GetTokenInformation(hToken, TokenUser, nil, 0, cbBuf);
        ptiUser  := nil;
        while (not bSuccess) and (GetLastError = ERROR_INSUFFICIENT_BUFFER) do
        begin
          ReallocMem(ptiUser, cbBuf);
          bSuccess := GetTokenInformation(hToken, TokenUser, ptiUser, cbBuf, 
cbBuf);
        end;
        CloseHandle(hToken);

        if not bSuccess then
          Exit;

        UserSize := 0;
        DomainSize := 0;
        LookupAccountSid(nil, ptiUser.User.Sid, nil, UserSize, nil, DomainSize, 
snu);
        if (UserSize <> 0) and (DomainSize <> 0) then
        begin
          SetLength(User, UserSize);
          SetLength(Domain, DomainSize);
          if LookupAccountSid(nil, ptiUser.User.Sid, PChar(User), UserSize,
            PChar(Domain), DomainSize, snu) then
          begin
            Result := True;
            User := StrPas(PChar(User));
            Domain := StrPas(PChar(Domain));
          end;
        end;

        if bSuccess then
        begin
          FreeMem(ptiUser);
        end;
      end;
      CloseHandle(ProcessHandle);
    end;
  end;

  // retorna o nome do usuário logado atualmente
  function _GetUserName : string;
  const
    MAX_USER_NAME_LEN = 254;
  var
    UserName: string;
    UserNameLen: DWORD;
  begin
    UserNameLen := MAX_USER_NAME_LEN - 1;
    SetLength(UserName, MAX_USER_NAME_LEN);
    if GetUserName(PChar(UserName), UserNameLen) then
      Result := Copy(UserName, 1, UserNameLen -1)
    else
      Result := EmptyStr;
  end;

var
  PIDArray: array [0..1023] of DWORD;
  cb: DWORD;
  I, J: Integer;
  ProcCount: Integer;
  hMod: HMODULE;
  hProcess: THandle;
  ModuleName: array [0..300] of Char;
  User, Domain, CurrentUser: string;
begin
  CurrentUser := _GetUserName;

  EnumProcesses(@PIDArray, SizeOf(PIDArray), cb);
  ProcCount := cb div SizeOf(DWORD);
  for I := 0 to ProcCount - 1 do
  begin
    hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or
      PROCESS_VM_READ,
      False,
      PIDArray[I]);
    if (hProcess <> 0) then
    begin
      GetUserAndDomainFromPID(PIDArray[I], User, Domain);

      EnumProcessModules(hProcess, @hMod, SizeOf(hMod), cb);
      GetModuleFilenameEx(hProcess, hMod, ModuleName, SizeOf(ModuleName));

      if AnsiSameText(User, CurrentUser) then
      begin
        J := Length(AList);
        SetLength(AList, J +1);
        AList[J].FileName := ExtractFileName(ModuleName);
        AList[J].Path := ExtractFilePath(ModuleName);
      end;

      CloseHandle(hProcess);
    end;
  end;
end;

// retira a lista de processos independente da versão do windows
procedure GetProcessList(var AList: TJJWProcessList);
var
  ovi: TOSVersionInfo;
begin
  ovi.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  GetVersionEx(ovi);
  case ovi.dwPlatformId of
    VER_PLATFORM_WIN32_WINDOWS: CreateWin9xProcessList(AList);
    VER_PLATFORM_WIN32_NT: CreateWinNTProcessList(AList);
  end
end;

------- USANDO -------------

  GetProcessList(ProcessList);
  Count := 0;
  for I := Low(ProcessList) to High(ProcessList) do
    if AnsiSameText(ProcessList[I].FileName, ExtractFileName(ParamStr(0))) then
      Inc(Count);

  Count irá guardar quantas instâncias do seu sistema estão abertas. coloque 
esse código no seu DPR para fazer a verificação q necessita



[As partes desta mensagem que não continham texto foram removidas]



-- 
<<<<< FAVOR REMOVER ESTA PARTE AO RESPONDER ESTA MENSAGEM >>>>>

<*> Para ver as mensagens antigas, acesse:
    http://br.groups.yahoo.com/group/delphi-br/messages

<*> Para falar com o moderador, envie um e-mail para:
    [EMAIL PROTECTED]
 
Links do Yahoo! Grupos

<*> Para visitar o site do seu grupo na web, acesse:
    http://br.groups.yahoo.com/group/delphi-br/

<*> Para sair deste grupo, envie um e-mail para:
    [EMAIL PROTECTED]

<*> O uso que você faz do Yahoo! Grupos está sujeito aos:
    http://br.yahoo.com/info/utos.html