ich habe mir anhand des coolen beispiels von haentschman was gebastelt und frage mich nun warum es nicht so funktioniert wie erwünscht
bei mir blockiert der main thread....
was ich tat war alten code von luckie ausbuddeln und dann als thread verpackt arbeiten lassen.

hier die threaded unit

zusammenfalten · markieren

Delphi-Quellcode:

unit kzProc;

interface

uses
  Winapi.Windows, Winapi.Messages, Winapi.PsAPI, Winapi.TlHelp32,
  System.Classes, System.SysUtils;

type
  TPIDList = array of DWORD;

  TProcessInfo = packed record
    PID: Cardinal;
    Parent: Cardinal;
    Filename: string;
    Filepath: string;
    Owner: string;
    ClassName: string;
    Threads: Cardinal;
    Modules: Cardinal;
    Priority: Cardinal;
    Memory: SIZE_T;
    Version: string;
  end;

  TProcesses = array of TProcessInfo;

  TGetProcessesEvent = procedure(Sender: TObject; Processes: TProcesses) of object;
  TGetProcesses = class(TThread)
  private
    FOnChange: TGetProcessesEvent;
  public
    property OnChange: TGetProcessesEvent read FOnChange write FOnChange;
    procedure Execute; override;
  end;

  TkzProcessEvent = procedure(Sender: TObject) of object;
  TkzProcess = class(TPersistent)
    strict private
      FPreviousDebugState: Boolean;
      FProcesses: TProcesses;
      FHasProcesses: Boolean;
      FIsBusy: Boolean;
      FGetProcessThread: TGetProcesses;
    protected
      procedure DoOnGetProcesses(Sender: TObject; Processes: TProcesses);
    private
      FOnChange: TkzProcessEvent;
    public
      constructor Create;
      destructor Destroy; override;
      procedure Refresh;
      function KillProcess(PID: DWORD; Wait: DWORD): Boolean;
    public
      property OnGetProcesses: TkzProcessEvent read FOnChange write FOnChange;
      property IsBusy: Boolean read FIsBusy;
      property Processes: TProcesses read FProcesses;
      property HasProcesses: Boolean read FHasProcesses;
  end;

// Get ProcessID By ProgramName (Include Path or Not Include)
function GetPIDByProgramName(const APName: string): THandle;

// Get Window Handle By ProgramName (Include Path or Not Include)
function GetHWndByProgramName(const APName: string): THandle;

// Get Window Handle By ProcessID
function GetHWndByPID(const hPID: THandle): THandle;

// Get ProcessID By Window Handle
function GetPIDByHWnd(const hWnd: THandle): THandle;

// Get Process Handle By Window Handle
function GetProcessHndByHWnd(const hWnd: THandle): THandle;

// Get Process Handle By Process ID
function GetProcessHndByPID(const hAPID: THandle): THandle;

implementation

// Get Window Handle By ProgramName (Include Path or Not Include)
function GetHWndByProgramName(const APName: string): THandle;
begin
   Result := GetHWndByPID(GetPIDByProgramName(APName));
end;

// Get Process Handle By Window Handle
function GetProcessHndByHWnd(const hWnd: THandle): THandle;
var
   PID: DWORD;
   AhProcess: THandle;
begin
   if hWnd <> 0 then
   begin
      GetWindowThreadProcessID(hWnd, @PID);
      AhProcess := OpenProcess(PROCESS_ALL_ACCESS, false, PID);
      Result := AhProcess;
      CloseHandle(AhProcess);
   end
   else
      Result := 0;
end;

// Get Process Handle By Process ID
function GetProcessHndByPID(const hAPID: THandle): THandle;
var
   AhProcess: THandle;
begin
   if hAPID <> 0 then
   begin
      AhProcess := OpenProcess(PROCESS_ALL_ACCESS, false, hAPID);
      Result := AhProcess;
      CloseHandle(AhProcess);
   end
   else
      Result := 0;
end;

// Get Window Handle By ProcessID
function GetPIDByHWnd(const hWnd: THandle): THandle;
var
   PID: DWORD;
begin
   if hWnd <> 0 then
   begin
      GetWindowThreadProcessID(hWnd, @PID);
      Result := PID;
   end
   else
      Result := 0;
end;

// Get Window Handle By ProcessID
function GetHWndByPID(const hPID: THandle): THandle;
  type
   PEnumInfo = ^TEnumInfo;
   TEnumInfo = record
      ProcessID: DWORD;
      HWND: THandle;
   end;

   function EnumWindowsProc(Wnd: DWORD; var EI: TEnumInfo): BOOL; stdcall;
   var
      PID: DWORD;
   begin
      GetWindowThreadProcessID(Wnd, @PID);
      Result := (PID <> EI.ProcessID) or (not IsWindowVisible(WND)) or (not IsWindowEnabled(WND));
      if not Result then
        EI.HWND := WND; //break on return FALSE
   end;

   function FindMainWindow(PID: DWORD): DWORD;
   var
      EI: TEnumInfo;
   begin
      EI.ProcessID := PID;
      EI.HWND := 0;
// EnumWindows(@EnumWindowsProc, Integer(@EI));
      EnumWindows(@EnumWindowsProc, LPARAM(@EI));
      Result := EI.HWND;
   end;

begin
   if hPID <> 0 then
      Result := FindMainWindow(hPID)
   else
      Result := 0;
end;

// Get ProcessID By ProgramName (Include Path or Not Include)
function GetPIDByProgramName(const APName: string): THandle;
var
   isFound: boolean;
   AHandle, AhProcess: THandle;
   ProcessEntry32: TProcessEntry32;
   APath: array[0..MAX_PATH] of char;
begin
   Result := 0;
   AHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
   try
      ProcessEntry32.dwSize := Sizeof(ProcessEntry32);
      isFound := Process32First(AHandle, ProcessEntry32);
      while isFound do
      begin
         AhProcess := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ,
            false, ProcessEntry32.th32ProcessID);
         GetModuleFileNameEx(AhProcess, 0, @APath[0], sizeof(APath));
         if (UpperCase(StrPas(APath)) = UpperCase(APName)) or
            (UpperCase(StrPas(ProcessEntry32.szExeFile)) = UpperCase(APName)) then
         begin
            Result := ProcessEntry32.th32ProcessID;
            break;
         end;
         isFound := Process32Next(AHandle, ProcessEntry32);
         CloseHandle(AhProcess);
      end;
   finally
      CloseHandle(AHandle);
   end;
end;

function GetSecurityInfo(handle: THandle; ObjectType: DWord; SecurityInfo: SECURITY_INFORMATION; ppsidOwner: PSID; ppsidGroup: PSID; ppDacl: PACL; ppSacl: PACL; ppSecurityDescriptor: PSECURITY_DESCRIPTOR): DWORD; stdcall; external 'advapi32.dll';
//function ConvertSidToStringSid(SID: PSID; var StringSid: PWideChar): Boolean; stdcall; external 'advapi32.dll' name 'ConvertSidToStringSidW';
//function ConvertStringSidToSid(StringSid: PWideChar; var Sid: PSID): Boolean; stdcall; external 'advapi32.dll' name 'ConvertStringSidToSidW';

function SidToString(ASID: PSID): WideString;
var
  sDummy : PWideChar;
begin
  ConvertSidToStringSid(ASID, sDummy);
  Result := string(sDummy);
end;

function StrSIDToName(const StrSID: Widestring; var Name: WideString; var SIDType: DWORD): Boolean;
var
  SID : PSID;
  Buffer, Temp : PWideChar;
  NameLen, TempLen : Cardinal;
  succes : Boolean;
begin
  SID := nil;
  succes := ConvertStringSIDToSID(PWideChar(StrSID), SID);
  if succes then
  begin
    NameLen := 0;
    TempLen := 0;
    LookupAccountSidW(nil, SID, nil, NameLen, nil, TempLen, SIDType);
    if NameLen > 0 then
    begin
      GetMem(Buffer, NameLen * sizeOf(WideChar));
      GetMem(Temp, TempLen * sizeof(WideChar));
      try
        succes := LookupAccountSidW(nil, SID, Buffer, NameLen, Temp, TempLen, SIDType);
        if succes then
        begin
          Name := WideString(Buffer);
        end;
      finally
        FreeMem(Buffer);
        FreeMem(Temp);
      end;
    end;
    LocalFree(Cardinal(SID));
  end;
  result := succes;
end;

function EnablePrivilege(const Privilege: string; fEnable: Boolean; out PreviousState: Boolean): Boolean;
var
  ok : Boolean;
  Token : THandle;
  NewState : TTokenPrivileges;
  Luid : TLargeInteger;
  PrevState : TTokenPrivileges;
  Return : DWORD;
begin
  PreviousState := True;
  if (GetVersion() > $80000000) then // Win9x
    Result := True
  else // WinNT
  begin
    ok := OpenProcessToken(GetCurrentProcess(), MAXIMUM_ALLOWED, Token);
    if ok then
    begin
      try
        ok := LookupPrivilegeValue(nil, PChar(Privilege), Luid);
        if ok then
        begin
          NewState.PrivilegeCount := 1;
          NewState.Privileges[0].Luid := Luid;
          if fEnable then
            NewState.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED
          else
            NewState.Privileges[0].Attributes := 0;
          ok := AdjustTokenPrivileges(Token, False, NewState, SizeOf(TTokenPrivileges), PrevState, Return);
          if ok then
          begin
            PreviousState := (PrevState.Privileges[0].Attributes and SE_PRIVILEGE_ENABLED <> 0);
          end;
        end;
      finally
        CloseHandle(Token);
      end;
    end;
    Result := ok;
  end;
end;

procedure TGetProcesses.Execute;
  function _GetClassName(const AValue: string): string;
  var
    ClassName: string;
    LhWnd: THandle;
  begin
    LhWnd := GetHWndByProgramName(AValue);
    SetLength(ClassName, 255);
    //get the class name and reset the
    //memory area to the size of the name
    SetLength(ClassName, GetClassName(LhWnd, PChar(className), Length(className)));
    Result := ClassName;
    if Result = '' then
      Result := Integer(LhWnd).ToString;
  end;
  function GetMemory(const APID: DWORD): SIZE_T;
  var
    hProcess: THandle;
    PMC: PPROCESS_MEMORY_COUNTERS;
    cb: DWORD;
  begin
    Result := 0;
    cb := SizeOf(_PROCESS_MEMORY_COUNTERS);
    GetMem(PMC, cb);
    try
      PMC^.cb := cb;
      hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, APID);
      begin
        if ( hProcess = 0 ) then
          Exit;
        if ( GetProcessMemoryInfo(hProcess, PMC, SizeOf(PMC^)) ) then
          Result := (PMC^.WorkingSetSize Div 1024)
        else
          Result := 0;
      end;
    finally
      CloseHandle(hProcess);
      FreeMem(PMC, SizeOf(_PROCESS_MEMORY_COUNTERS));
    end;
  end;
  function GetPriority(const APID: DWORD): DWORD;
  var
    hProcess : THandle;
  begin
    hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or GENERIC_READ, False, APID);
    if (hProcess <> 0) then
    begin
      Result := GetPriorityClass(hProcess);
      CloseHandle(hProcess);
    end
    else
      Result := 0;
  end;
  function GetParentPID(const APID: DWORD): DWORD;
  const
    BufferSize = 4096;
  var
    HandleSnapShot : THandle;
    EntryParentProc : TProcessEntry32;
    HandleParentProc: THandle;
    ParentProcessId : DWORD;
    ParentProcessFound : Boolean;
    ParentProcPath : String;
  begin
    Result := 0;
    ParentProcessFound := False;
    HandleSnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); //enumerate the process
    if HandleSnapShot <> INVALID_HANDLE_VALUE then
    begin
      EntryParentProc.dwSize := SizeOf(EntryParentProc);
      if Process32First(HandleSnapShot, EntryParentProc) then //find the first process
      begin
        repeat
          if EntryParentProc.th32ProcessID = APID then
          begin
            ParentProcessId := EntryParentProc.th32ParentProcessID; //get the id of the parent process
            HandleParentProc := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, ParentProcessId);
            if HandleParentProc <> 0 then
            begin
              ParentProcessFound := True;
              CloseHandle(HandleParentProc);
            end;
            Break;
          end;
        until not Process32Next(HandleSnapShot, EntryParentProc);
      end;
      CloseHandle(HandleSnapShot);
    end;
    if ParentProcessFound then
      Result := ParentProcessId
    else
      Result := 0;
  end;

  function GetVersion(const Filename: string): string;
  type
    PDWORDArr = ^DWORDArr;
    DWORDArr = array[0..0] of DWORD;
  var
    VerInfoSize : DWORD;
    VerInfo : Pointer;
    VerValueSize : DWORD;
    VerValue : PVSFixedFileInfo;
    LangID : DWORD;
  begin
    result := '';
    VerInfoSize := GetFileVersionInfoSizeW(PWideChar(Filename), LangID);
    if VerInfoSize <> 0 then
    begin
      VerInfo := Pointer(GlobalAlloc(GPTR, VerInfoSize * 2));
      if Assigned(VerInfo) then
      try
        if GetFileVersionInfoW(PWideChar(Filename), 0, VerInfoSize, VerInfo) then
        begin
          if VerQueryValueW(VerInfo, '\', Pointer(VerValue), VerValueSize) then
         begin
            with VerValue^ do
            begin
              result := Format('%d.%d.%d.%d', [dwFileVersionMS shr 16, dwFileVersionMS and $FFFF,
                dwFileVersionLS shr 16, dwFileVersionLS and $FFFF]);
            end;
          end
          else
            result := '';
        end;
      finally
        GlobalFree(THandle(VerInfo));
      end;
    end;
  end;
  function GetThreads(const APID: DWORD): DWORD;
  var
    hSnapShot : Thandle;
    pe32 : TProcessEntry32W;
  begin
    Result := 0;
    hSnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
    if hSnapShot <> INVALID_HANDLE_VALUE then
    begin
      pe32.dwSize := SizeOf(TProcessEntry32W);
      if not Process32FirstW(hSnapShot, pe32) then
      begin
        CloseHandle(hSnapShot);
      end
      else
      repeat
        if APID = pe32.th32ProcessID then
        begin
          Result := pe32.cntThreads;
          Break;
        end;
      until not Process32NextW(hSnapShot, pe32);
      CloseHandle(hSnapShot);
    end;
  end;
  function GetModulePath(const APID: DWORD): string;
  var
    hSnapShot : Thandle;
    hModuleSnapShot : THandle;
    pe32 : TProcessEntry32W;
    me32 : TModuleEntry32W;
  begin
    hSnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, APID);
    if hSnapShot <> INVALID_HANDLE_VALUE then
    begin
      pe32.dwSize := SizeOf(TProcessEntry32W);
      if not Process32FirstW(hSnapShot, pe32) then
      begin
        CloseHandle(hSnapShot);
      end
      else
      begin
        if APID <> 0 then // Process 0 is no real process!
        begin
          hModuleSnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, APID);
          if hModuleSnapShot <> INVALID_HANDLE_VALUE then
          begin
            me32.dwSize := SizeOf(TModuleEntry32W);
            if Module32FirstW(hModuleSnapShot, me32) then
            begin
              Result := me32.szExePath;
            end
            else
            begin
              Result := '';
              CloseHandle(hModuleSnapShot);
            end;
            CloseHandle(hModuleSnapShot);
          end
          else
            Result := '';
        end;
      end;
      CloseHandle(hSnapShot);
    end;
  end;
  function GetModules(const APID: DWORD): DWORD;
  var
    hProcess : THandle;
    ModuleList : array[0..1024] of DWORD;
    cbNeeded : DWORD;
  begin
    cbNeeded := 0;
    hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, APID);
    if hProcess <> 0 then
    begin
      if EnumProcessModules(hProcess, @ModuleList, SizeOf(ModuleList), cbNeeded) then
      begin
        Result := cbNeeded div SizeOf(DWORD);
      end
      else
      begin
        Result := 0;
      end;
      CloseHandle(hProcess);
    end
    else
    begin
      Result := 0;
    end;
  end;
  function GetOwnerName(const APID: DWORD): string;
  var
    hProcess : THandle;
    ppsidOwner : PSID;
    SecDescriptor : PSECURITY_DESCRIPTOR;
    err : DWord;
    s : string;
    SIDType : DWORD;
    Owner : WideString;
  const
    SE_UNKNOWN_OBJECT_TYPE: DWord = 0;
    SE_FILE_OBJECT : DWord = 1;
    SE_SERVICE : DWord = 2;
    SE_PRINTER : DWord = 3;
    SE_REGISTRY_KEY : DWord = 4;
    SE_LMSHARE : DWord = 5;
    SE_KERNEL_OBJECT : DWord = 6;
    SE_WINDOW_OBJECT : DWord = 7;
  begin
    Owner := '';
    hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or GENERIC_READ, False, APID);
    if (hProcess <> 0) then
    begin
      err := GetSecurityInfo(hProcess, SE_KERNEL_OBJECT, OWNER_SECURITY_INFORMATION, @ppsidOwner, nil, nil, nil, @SecDescriptor);
      if (err = 0) then
      begin
        s := SidToString(ppsidOwner);
        StrSIDToName(s, Owner, SIDType);
        LocalFree(Cardinal(SecDescriptor));
      end;
      CloseHandle(hProcess);
    end;
    Result := Owner;
  end;
  function GetProcessName(PID: DWORD; var ProcessName: string): DWORD;
  var
    dwReturn : DWORD;
    hProc : Cardinal;
    buffer : array[0..MAX_PATH - 1] of Char;
  begin
    dwReturn := 0;
    Zeromemory(@buffer, sizeof(buffer));
    hProc := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, FALSE, PID);
    if hProc <> 0 then
    begin
      GetModulebaseName(hProc, 0, buffer, sizeof(buffer));
      ProcessName := (string(buffer));
      CloseHandle(hProc);
    end
    else
      dwReturn := GetLastError;
    result := dwReturn;
  end;


var
 ProcessList: TPIDList;
 PidProcess: PDWORD;
 cb: DWORD;
 cbNeeded: DWORD;
 BufferSize: Cardinal;
 dwReturn: DWORD;
 cntProcesses: Cardinal;
 PidWork: PDWORD;
 i: Cardinal;
 ProcessName: string;
 LPID: DWORD;
 LProcesses: TProcesses;
 LPreviousDebugState: Boolean;
begin
  EnablePrivilege('SeDebugPrivilege', True, LPreviousDebugState);
  cbNeeded := 0;
  BufferSize := 1024;
  GetMem(PidProcess, BufferSize);
  // make sure memory is allocated
  if Assigned(PidProcess) then
  begin
    try
      // enumerate the processes
      if EnumProcesses(PidProcess, BufferSize, cbNeeded) then
      begin
        dwReturn := 0;
        cntProcesses := cbNeeded div sizeof(DWORD) - 1;
        PidWork := PidProcess;
        SetLength(ProcessList, cntProcesses);
        // walk the processes
        for i := 0 to cntProcesses - 1 do
        begin
          ProcessList[i] := PidWork^;
          Inc(PidWork);
        end;
      end
      else // EnumProcesses = False
        dwReturn := GetLastError;
      finally
        // clean up no matter what happend
        FreeMem(PidProcess, BufferSize);
      end;
  end
  else // GetMem = nil
    dwReturn := GetLastError;

  SetLength(LProcesses, Length(ProcessList));
  for i := 0 to Length(ProcessList) - 1 do
  begin
    LPID := ProcessList[i];
    LProcesses[i].PID := LPID;
    if (GetProcessName(LPID, ProcessName) <> 0) then
      ProcessName := 'Unknown';
    LProcesses[i].Parent := GetParentPID(LPID);
    LProcesses[i].Filename := ProcessName;
    LProcesses[i].Owner := GetOwnerName(LPID);
// LProcesses[i].ClassName := _GetClassName(LPID);
// LProcesses[i].ClassName := _GetClassName(ProcessName);

    LProcesses[i].Modules := GetModules(LPID);
    LProcesses[i].Filepath := GetModulePath(LPID);
    if (Length(LProcesses[i].Filepath) > 0) then
      LProcesses[i].Version := GetVersion(LProcesses[i].Filepath);
    LProcesses[i].Threads := GetThreads(LPID);
    LProcesses[i].Priority := GetPriority(LPID);
  end;
  SetLength(ProcessList, 0);
  Synchronize(
    procedure
      begin
        if Assigned(FOnChange) then
          FOnChange(Self, LProcesses);
      end);
  SetLength(LProcesses, 0);
  EnablePrivilege('SeDebugPrivilege', LPreviousDebugState, LPreviousDebugState);
end;


constructor TkzProcess.Create;
begin
  inherited Create;
  EnablePrivilege('SeDebugPrivilege', True, FPreviousDebugState);
  Self.Refresh;
  Self.Refresh;
end;

destructor TkzProcess.Destroy;
begin
  inherited Destroy;
  EnablePrivilege('SeDebugPrivilege', FPreviousDebugState, FPreviousDebugState);
end;

procedure TkzProcess.DoOnGetProcesses(Sender: TObject; Processes: TProcesses);
begin
  FProcesses := Processes;
  FHasProcesses := (Length(FProcesses) > 0);
  FIsBusy := False;
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

procedure TkzProcess.Refresh;
begin
  FGetProcessThread := TGetProcesses.Create(False);
  try
    FIsBusy := True;
    FHasProcesses := False;
    FGetProcessThread.OnChange := Self.DoOnGetProcesses;
    FGetProcessThread.FreeOnTerminate := True;
    FGetProcessThread.Execute;
  finally
    FGetProcessThread.Terminate;
  end;
end;

function TkzProcess.KillProcess(PID: DWORD; Wait: DWORD): Boolean;
var
  hProcess: THandle;
  wfso: DWORD;
begin
  hProcess := OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE, False, PID);
  if (hProcess <> 0) then
  begin
    if TerminateProcess(hProcess, 1) then
    begin
      // TerminateProcess returns immediately, verify if we have killed the process
      wfso := WaitForSingleObject(hProcess, Wait);
      Result := (not wfso = WAIT_FAILED);
    end
    else
      Result := False;
  end
  else
    Result := False;
end;

end.

und so wende ich es an

zusammenfalten · markieren

Delphi-Quellcode:

unit uMain;

interface

uses
  Winapi.Windows, Winapi.Messages,
  System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ComCtrls,
  Vcl.ExtCtrls, Vcl.StdCtrls,
  uListView,
  kzProc;

type
  TfrmMain = class(TForm)
    pnlMain: TPanel;
    lvProcesses: TListView;
    pnlButtons: TPanel;
    btnRefresh: TButton;
    Panel1: TPanel;
    cbUnknown: TCheckBox;
    cbUniques: TCheckBox;
    btnKill: TButton;
    procedure btnRefreshClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormActivate(Sender: TObject);
    procedure lvProcessesMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure lvProcessesDblClick(Sender: TObject);
    procedure cbUnknownClick(Sender: TObject);
    procedure btnKillClick(Sender: TObject);
  protected
      procedure DoOnProcesses(Sender: TObject);
  strict private
    // current mouseclick positions
    FX: Integer;
    FY: Integer;
    // copy of everything
    FProcOriginal: TProcesses;
    // local hitinfo
    FHitInfo: THitInfo;
  private
    // the class
    FkzProc: TkzProcess;
    // local display copy
    FProc: TProcesses;
  private
    procedure DisplayIt;
  public
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.dfm}

procedure TfrmMain.DisplayIt;
var
  i: Integer;
  li: TListItem;
begin
  if Length(Self.FProc) > 0 then
  begin
    Self.lvProcesses.Items.BeginUpdate;
    Self.lvProcesses.Items.Clear;
    for i := 0 to Pred(Length(Self.FProc)) do
    begin
      li := lvProcesses.Items.Add;
      // PID
      li.Caption := Self.FProc[i].PID.ToString;
      // Parent
      li.SubItems.Add(Self.FProc[i].Parent.ToString);
      // Filename
      li.SubItems.Add(Self.FProc[i].Filename);
      // Filepath
      li.SubItems.Add(Self.FProc[i].Filepath);
      // Owner
      li.SubItems.Add(Self.FProc[i].Owner);
      // ClassName
      li.SubItems.Add(Self.FProc[i].ClassName);
      // Threads
      li.SubItems.Add(Self.FProc[i].Threads.ToString);
      // Modules
      li.SubItems.Add(Self.FProc[i].Modules.ToString);
      // Priority
      li.SubItems.Add(Self.FProc[i].Priority.ToString);
      // Memory
      li.SubItems.Add(Self.FProc[i].Memory.ToString);
      // FileVersion
      li.SubItems.Add(Self.FProc[i].Version);
    end;
    Self.lvProcesses.Items.EndUpdate;
  end;
end;

procedure TfrmMain.cbUnknownClick(Sender: TObject);
  function AddToRecord(const AValue: TProcessInfo): TProcesses;
  var
    i: Integer;
  begin
    i := Length(Result);
    SetLength(Result, i + 1);
    Result[i].Filename := AValue.Filename;
    Result[i].Filepath := AValue.Filepath;
    Result[i].Memory := AValue.Memory;
    Result[i].Modules := AValue.Modules;
    Result[i].Owner := AValue.Owner;
    Result[i].Parent := AValue.Parent;
    Result[i].Priority := AValue.Priority;
    Result[i].Threads := AValue.Threads;
    Result[i].Version := AValue.Version;
    Result[i].PID := AValue.PID;
  end;
var
  i: Integer;
  NewRec: TProcessInfo;
begin
  SetLength(Self.FProc, 0);
  for i := 0 to Pred(Length(Self.FProcOriginal)) do
  begin
    NewRec.Filename := Self.FProcOriginal[i].Filename;
    NewRec.Filepath := Self.FProcOriginal[i].Filepath;
    NewRec.Memory := Self.FProcOriginal[i].Memory;
    NewRec.Modules := Self.FProcOriginal[i].Modules;
    NewRec.Owner := Self.FProcOriginal[i].Owner;
    NewRec.ClassName := Self.FProcOriginal[i].ClassName;
    NewRec.Parent := Self.FProcOriginal[i].Parent;
    NewRec.Priority := Self.FProcOriginal[i].Priority;
    NewRec.Threads := Self.FProcOriginal[i].Threads;
    NewRec.Version := Self.FProcOriginal[i].Version;
    NewRec.PID := Self.FProcOriginal[i].PID;
    if ((Self.cbUnknown.Checked) and (NewRec.Filename <> 'Unknown')) then
      Self.FProc := AddToRecord(NewRec)
      else
      if (not Self.cbUnknown.Checked) then
        Self.FProc := AddToRecord(NewRec);
  end;
  Self.DisplayIt;
end;

procedure TfrmMain.DoOnProcesses(Sender: TObject);
begin
  Self.FProc := Self.FkzProc.Processes;
  Self.FProcOriginal := Self.FkzProc.Processes;
  Self.DisplayIt;
end;

procedure TfrmMain.btnKillClick(Sender: TObject);
begin
  // precheck if retrieved data can be used
  if ((FHitInfo.Row >= 0) and (FHitInfo.Column >= 0)) then
  begin
    Self.btnKill.Enabled := (not Self.FkzProc.KillProcess(StrToInt64(GetHitTestInfoValueAt(Self.lvProcesses, FHitInfo.Row, 0)), 500));
  end;
end;

procedure TfrmMain.btnRefreshClick(Sender: TObject);
begin
  // update everything
  Self.FkzProc.Refresh;
end;

procedure TfrmMain.FormActivate(Sender: TObject);
begin
  // initiate the class
  Self.FkzProc := TkzProcess.Create;
  // and assign event handler
  Self.FkzProc.OnGetProcesses := Self.DoOnProcesses;
end;

procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  // free the class
  Self.FkzProc.Free;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  // do nothing
  Application.ProcessMessages;
end;

procedure TfrmMain.lvProcessesDblClick(Sender: TObject);
var
  LV: TListView;
  Index: Integer;
begin
  // make method generic usable, no "ListView1.foo.bar"
  LV := (Sender as TListView);
  // precheck if retrieved data can be used
  if ((FHitInfo.Row >= 0) and (FHitInfo.Column >= 0) and (FHitInfo.Row < LV.Items.Count) and (FHitInfo.Column < LV.Columns.Count)) then
  begin
    // for testing set caption to clicked item
    Self.Caption := 'Row: ' + FHitInfo.Row.ToString + ' - Column: ' + FHitInfo.Column.ToString + ' = ' + GetHitTestInfoValueAt(LV, FHitInfo.Row, FHitInfo.Column);
    // react if column 1 was clicked
    if (FHitInfo.Column = 1) then
    begin
      // retrieve needed index to jump to, by searching for a value match
      Index := GetIndexFrom(LV, GetHitTestInfoValueAt(LV, FHitInfo.Row, FHitInfo.Column), 0);
      if ((Index >= 0) and (Index < LV.Items.Count)) then
      begin
        // bring item in visible range
        LV.Items[Index].MakeVisible(False);
        // select item
        LV.Items[Index].Selected := True;
      end;
    end;
  end;
end;

procedure TfrmMain.lvProcessesMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  LV: TListView;
begin
  // save local a copy of xy position
  FX := X;
  FY := Y;
  // make method generic usable, no "ListView1.foo.bar"
  LV := (Sender as TListView);
  // retrieve row and column of clicked item
  FHitInfo := GetSubItemHitTestInfoAt(LV.Handle, FX, FY);
  // if a line is selected, enable kill button
  Self.btnKill.Enabled := ((Sender as TListView).Selected <> nil);
end;

end.

worin liegt mein denkfehler?

Zitat:

Versuche mal an die Aufgabenstellung erst mal anders ranzugehen.

Ich würde auch diesen Quatsch mit DoIt weglassen. Geb den Dingern entweder richtige Namen oder lass die besser jetzt erstmal komplett weg.

Hallo zusammen,

ich habe mich seit gestern mal tiefer mit Threads beschäftigt und da kam das Beispiel von Stahli hier genau richtig.

Nun habe ich mal eine "Demo" erstellt, mit den 2 verschiedenen Varianten von Stahli und Haentschmann.
In meiner VM-Entwickler-Maschine laufen beide Thread-Varianten so wie erwartet. Man sieht wie das Label refresht wird und das Hochzählen der Zahlen anzeigt.
Auf meinem Haupt-PC läuft es nicht so wie ich es erwarten würde. Das Programm wird blockiert (evtl. selbes Problem wie bei KodeZwerg?), sobald das Programm den Fokus hat oder man mit der Maus nur über das Programm drüber gleitet. Wenn man ein anderes Programm in den Vordergrund holt, zeigt das Label wieder das Hochzählen an und die Blockade ist weg.
Ich hoffe, ich konnte ausdrücken was das Problem ist.

Hier die Hauptunit:

zusammenfalten · markieren

Delphi-Quellcode:

UNIT uMain;

INTERFACE

USES
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;

TYPE
  TOnChangeEvent = PROCEDURE( Sender: TObject; MaxValue: Integer; CurrentValue: Integer ) OF OBJECT; { mein Event-Hanlder für den 2. Thread }

  Tfrm_Main = CLASS( TForm )
    Btn_Start_Thread1: TButton;
    CounterLabel1: TLabel;
    Btn_End_Thread1: TButton;
    Label1: TLabel;
    Bevel1: TBevel;
    Btn_Start_Thread2: TButton;
    Btn_End_Thread2: TButton;
    Counterlabel2: TLabel;
    PROCEDURE FormClose( Sender: TObject; VAR Action: TCloseAction );
    PROCEDURE Btn_Start_Thread1Click( Sender: TObject );
    PROCEDURE Btn_End_Thread1Click( Sender: TObject );
    PROCEDURE DoOnChange( Sender: TObject; MaxValue: Integer; CurrentValue: Integer );
    PROCEDURE Btn_Start_Thread2Click( Sender: TObject );
    PROCEDURE Btn_End_Thread2Click( Sender: TObject );
    PROCEDURE FormCreate( Sender: TObject );

  PRIVATE
    { Private-Deklarationen }

  PUBLIC
    { Public-Deklarationen }
  VAR
    gb_ist_Thread1_aktiv, gb_ist_Thread2_aktiv: Boolean;

  END;

VAR
  frm_Main: Tfrm_Main;

IMPLEMENTATION

{$R *.dfm}


USES
  uThread_mit_Erzeugung_Controls_fuer_Zugriff_auf_VCL_im_Hauptthread, uThread_mit_Businesslogic_kennt_somit_nicht_den_HauptThread;


{ mein Event-Handler von dem 2. Thread }
PROCEDURE Tfrm_Main.DoOnChange( Sender: TObject; MaxValue: Integer; CurrentValue: Integer );
BEGIN
  frm_Main.CounterLabel2.Caption := CurrentValue.ToString;
END;

PROCEDURE Tfrm_Main.FormCreate( Sender: TObject );
BEGIN
  gb_ist_Thread1_aktiv := False;
  gb_ist_Thread2_aktiv := False;
END;

PROCEDURE Tfrm_Main.Btn_Start_Thread1Click( Sender: TObject );
BEGIN
  Btn_Start_Thread1.Enabled := False;
  Btn_Start_Thread2.Enabled := False;
  Btn_End_Thread2.Enabled := False;

  FMy_Thread1 := TTheThread.Create( CounterLabel1 );
END;

PROCEDURE Tfrm_Main.Btn_End_Thread1Click( Sender: TObject );
BEGIN
  IF frm_Main.gb_ist_Thread1_aktiv THEN FMy_Thread1.Terminate;
  Btn_Start_Thread1.Enabled := True;
  Btn_End_Thread1.Enabled := True;
  Btn_Start_Thread2.Enabled := True;
  Btn_End_Thread2.Enabled := True;
END;

PROCEDURE Tfrm_Main.Btn_Start_Thread2Click( Sender: TObject );
BEGIN
  Btn_Start_Thread1.Enabled := False;
  Btn_End_Thread1.Enabled := False;
  Btn_Start_Thread2.Enabled := False;

  FMy_Thread2 := TTheThread2.Create;
  FMy_Thread2.OnChange := DoOnChange; { ! }
END;

PROCEDURE Tfrm_Main.Btn_End_Thread2Click( Sender: TObject );
BEGIN
  IF frm_Main.gb_ist_Thread2_aktiv THEN FMy_Thread2.Terminate;
  Btn_Start_Thread1.Enabled := True;
  Btn_End_Thread1.Enabled := True;
  Btn_Start_Thread2.Enabled := True;
  Btn_End_Thread2.Enabled := True;
END;

PROCEDURE Tfrm_Main.FormClose( Sender: TObject; VAR Action: TCloseAction );
BEGIN
  IF frm_Main.gb_ist_Thread1_aktiv THEN FMy_Thread1.Terminate;
  IF frm_Main.gb_ist_Thread2_aktiv THEN FMy_Thread2.Terminate;
END;

END.

Und hier die Unit eines der beiden Thread-Beispiele:

zusammenfalten · markieren

Delphi-Quellcode:

UNIT uThread_mit_Businesslogic_kennt_somit_nicht_den_HauptThread;

INTERFACE

USES
  Winapi.Windows, Winapi.Messages, System.Classes, System.SysUtils, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, uMain;

TYPE

  TTheThread2 = CLASS( TThread )
  PRIVATE
    FOnChange: TOnChangeEvent; { Event-Handler in uMain }
  PUBLIC
    PROPERTY OnChange: TOnChangeEvent READ FOnChange WRITE FOnChange;
    PROCEDURE Execute; OVERRIDE;
  END;

VAR
  FMy_Thread2: TTheThread2;

IMPLEMENTATION

PROCEDURE TTheThread2.Execute;
VAR
  I1, I2: Cardinal;
BEGIN
  I1 := 0;
  I2 := 0;
  TRY
    frm_Main.gb_ist_Thread2_aktiv := True;
    TRY
      WHILE ( NOT Terminated ) DO
      BEGIN
        Inc( I1 );
        IF ( I1 >= 1000 ) THEN
        BEGIN
          Inc( I2 );

          Synchronize(
            PROCEDURE
            BEGIN
              IF Assigned( FOnChange ) THEN
              BEGIN
                FOnChange( Self, I1, I2 ); // Beispiel
              END;
            END );

          I1 := 0;
          IF I2 > 4200000000 THEN I2 := 0; // wegen Gefahr eines Überlaufs wenn jemand mal den Thread laufen lässt...

          // ================================= !!! um Fehler zu testen im(!) Thread ===============================
          // I2 := I2 DIV I1;
        END;
      END;
    FINALLY
      frm_Main.gb_ist_Thread2_aktiv := False;
    END;
  EXCEPT
    /// Wird benötigt, weil eine Exception im(!) Thread diesen Thread beendet und eine Exception im Hauptthread nicht "angezeigt" werden kann
    ON E: Exception DO
    BEGIN
      Queue(
        PROCEDURE
        BEGIN
          MessageBox( Application.MainFormHandle, PChar( Exception.Classname + ' : ' + E.Message ), 'Thread-Error!', MB_OK OR MB_ICONERROR );
        END );
    END;
  END;
END;

END.

Ich würde mich freuen wenn dieses Mysterium aufgeklärt werden könnte.
Vielen Dank schon mal vorab!

Also wenn ich TThread.Sleep(2) vor Synchronize() setze, dann funktioniert alles.

markieren

Delphi-Quellcode:

  IF ( I1 >= 1000 ) THEN
        BEGIN
          TThread.sleep(2);
          Inc( I2 );

          Synchronize(

Muss man das so machen, dass das Synchronize() genug Zeit bekommt?

Bei mir ist es halt lediglich 1x synchronize und zwar wenn der thread mit seiner Arbeit durch ist.

Also, MainThread erzeugt eine Klasse mit einem OnEvent für den MainThread, die Klasse erzeugt einen Thread mit einem OnEvent für die Klasse, das Klassen-Event gibt dem MainThread Event bescheid wenn es fertig ist.
Von der Logik her denke ich das es so korrekt ist.

Mit WinAPI Threads habe ich dieses Phänomen nicht, da wird nicht der MainThread blockiert obwohl es von der Sache her der gleiche ablauf ist (nur halt per PostMessage als ersatz für OnEvent).

Da ich wirklich nur 1x sync mache denke ich das dies bei mir nicht der Fehler ist, aber ich werde es später gerne mal testen.

Ich denke hier liegt das Problem:

markieren

Delphi-Quellcode:

  FMy_Thread2 := TTheThread2.Create;
  FMy_Thread2.OnChange := DoOnChange; { ! }

Der Thread wird erzeugt und läuft gleich los, aber das OnChange ist noch nicht gesetzt.

Versuch mal dies:

markieren

Delphi-Quellcode:

  FMy_Thread2 := TTheThread2.Create(False);
  FMy_Thread2.OnChange := DoOnChange; { ! }
  FMy_Thread2.Start;

BTW, die Zugriffe aus dem Thread auf frm_Main halte ich für gefährlich, während die Zugriffe auf frm_Main in den Methoden von Tfrm_Main lediglich kontraproduktiv sind.

DoOnChange als Parameter ans Create übergeben?

Kann OnChange zur Laufzeit des Threads sich ändern? (theoretisch ja, da public Property ohne abgesicherten Setter)
Und wenn, passiert das dann auch definitif immer nur im Hauptthreads?

Wenn es sich nicht ändern kann/soll, dann darf das nicht als Property ungesichert öffentlich zugänglich sein.

Und wenn es sich nie während der Threadlaufzeit ändern kann, dann IF-Assigned vor das Synchronize, da bei NIL sonst immer sinnlos Synchronize ausgeführt wird und bremst.

markieren

Delphi-Quellcode:

        IF Assigned( FOnChange ) THEN
          Synchronize(
            PROCEDURE
            BEGIN
              FOnChange( Self, I1, I2 ); // Beispiel
            END );

Das "IF Assigned(FOnChange)" vor dem Synchronize kann man zwar zusätzlich prüfen.
Verlassen kann man sich darauf allein aber nur, wenn FOnChange nicht von außen durch den Haupthread verändert werden kann.
Also kein Property dafür existiert, sondern der Wert z.B. als Parameter dem Constructor übergeben wurde.

Der Hauptthread führt die synchronisierte Prozedur erst beim nächsten Processmessages() aus.
Inzwischen könnte FOnChange aber durch den Hauptthread auf nil gesetzt worden sein, was dann zur Zugriffsverletzung führt.
Deshalb würde ich solche Property immer auch in der synchronisierten Prozedur prüfen und den Zugriff mit einer CriticalSection absichern.

Wurde zwar eigentlich bereits gesagt, aber ist leicht zu überlesen.

Auch wenn das dann irgendwie doppelt ist würde das dann helfen:

markieren

Delphi-Quellcode:

 
IF Assigned( FOnChange ) THEN
  Synchronize(
    PROCEDURE
    BEGIN
      if Assigned( FOnChange ) then
        FOnChange( Self, I1, I2 ); // Beispiel
    END );

Dein TTheThread2 hat uMain in den Uses.

Das ist nicht so gut. Sollte auch ohne gehen. Dann ist der Thread wirklich für sich.

Sonst könntest du Synchronize ganz weg lassen da du ja auch frm_Main.gb_ist_Thread2_aktiv := True; machst.

Könntest auch frm_Main.CounterLabel2.Caption := CurrentValue.ToString; direkt im tread machen.