Ersatz für Sleep?

[PeterPanino]

Hallo und schönen Abend!

Ich verwende diesen Code, um den Windows CHM-Viewer in mein Programm einzubetten und eine CHM-Datei darin anzuzeigen:

Formular-Definition:

Delphi-Quellcode:

object Form1: TForm1
  Left = 1838
  Top = 468
  Caption = 'Form1'
  ClientHeight = 681
  ClientWidth = 656
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  DesignSize = (
    656
    681)
  PixelsPerInch = 96
  TextHeight = 13
  object Button1: TButton
    Left = 24
    Top = 24
    Width = 177
    Height = 25
    Caption = 'Embed Viewer App'
    TabOrder = 0
    OnClick = Button1Click
  end
  object Panel1: TPanel
    Left = 8
    Top = 64
    Width = 640
    Height = 609
    Anchors = [akLeft, akTop, akRight, akBottom]
    TabOrder = 1
    OnResize = Panel1Resize
    ExplicitWidth = 448
    ExplicitHeight = 321
  end
  object Button2: TButton
    Left = 216
    Top = 24
    Width = 177
    Height = 25
    Caption = 'Release Viewer App'
    TabOrder = 2
    OnClick = Button2Click
  end
end

Form-Unit:

Delphi-Quellcode:

unit MainForm;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Panel1: TPanel;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Panel1Resize(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
    FAppWnd: DWORD;
    procedure PADoEmbeddApp(APanel: TPanel; const AAppToExec, AParam: string);
    procedure PADoReleaseEmbeddedApp;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  Winapi.ShellAPI;

procedure TForm1.PADoEmbeddApp(APanel: TPanel; const AAppToExec, AParam: string);
// App starten und einbetten
// uses Winapi.ShellAPI;
var
  ExecuteFile: string;
  SEInfo: TShellExecuteInfo;
  RetryCount: Integer;
begin
  FillChar(SEInfo, SizeOf(SEInfo), 0);
  SEInfo.cbSize := SizeOf(TShellExecuteInfo);
  with SEInfo do
  begin
    fMask := SEE_MASK_NOCLOSEPROCESS;
    Wnd := APanel.Handle;
    lpFile := PChar(AAppToExec);
    lpParameters := PChar(AParam);
    nShow := SW_HIDE;
  end;

  if ShellExecuteEx(@SEInfo) then // wenn Programm erfolgreich gestartet wurde
  begin
    RetryCount := 0;
    repeat
      FAppWnd := FindWindow(PChar('HH Parent'), nil);
      Sleep(100);
      Inc(RetryCount);
    until (FAppWnd <> 0) or (RetryCount > 10);

    if FAppWnd <> 0 then // wenn das Fenster der ViewerApp gefunden wurde
    begin
      Winapi.Windows.SetParent(FAppWnd, SEInfo.Wnd);
      SetWindowLong(FAppWnd, GWL_STYLE, GetWindowLong(Handle, GWL_STYLE)
        and not WS_BORDER
        and not WS_THICKFRAME
        and not WS_DLGFRAME
        );

      SetWindowPos(FAppWnd, 0, 0, 0, APanel.Width, APanel.Height, SWP_ASYNCWINDOWPOS);

      Sleep(1000); // das Gelbe vom Ei?

      APanel.Repaint;
      Application.ProcessMessages;

      ShowWindow(FAppWnd, SW_SHOWMAXIMIZED);
    end;
  end;
end;

procedure TForm1.PADoReleaseEmbeddedApp;
// Eingebettetes Programm beenden
begin
  if FAppWnd <> 0 then
  begin
    PostMessage(FAppWnd, WM_Close, 0, 0);
    FAppWnd := 0;
  end;
end;

procedure TForm1.Panel1Resize(Sender: TObject);
// Größe von Embedded App zusammen mit Fenster verändern
begin
  if IsWindow(FAppWnd) then
    SetWindowPos(FAppWnd, 0, 0, 0, Panel1.Width, Panel1.Height, SWP_ASYNCWINDOWPOS);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  PADoEmbeddApp(Panel1, 'hh.exe', 'R:\Example.chm');
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  PADoReleaseEmbeddedApp;
end;

end.

Das funktioniert auch sehr gut. Nur stört mich das Sleep(1000); nach SetWindowPos. Oder auch das Sleep(100); in der repeat-Schleife davor. Gibt es dafür keine elegantere Lösung?

[BenjaminH]

Wenn du meinst, dass dein Fenster währenddessen nicht reagiert, dann ist das eine Lösung: http://www.delphipraxis.net/6620-delay.html

[PeterPanino]

Danke, Benjamin. Das funktioniert!

Noch eleganter wäre es allerdings, wenn die Delay-Schleife sofort verlassen würde, sobald das HH-Fenster fertig eingebettet ist. Denn zur Zeit ist die Zeit nur eine VERMUTUNG:

1000 ms: Funktioniert, das eingebettete HH-Fenster wird angezeigt.

500 ms: Das eingebettete HH-Fenster wird nicht angezeigt.

Könnte aber auf anderen Computern anders sein.

[BenjaminH]

Das kannst du ja selbst bei jedem
 if Application.Terminated OR WINDOWVISIBLE(bla) then Exit; überprüfen.

[PeterPanino]

IsWindowVisible(FAppWnd) geht leider nicht, da es gleich True zurückgibt, ohne dass es fertig eingebettet ist:

Delphi-Quellcode:

if ShellExecuteEx(@SEInfo) then // wenn Programm erfolgreich gestartet wurde
  begin
    RetryCount := 0;
    repeat
      FAppWnd := FindWindow(PChar('HH Parent'), nil);
      Sleep(100);
      Inc(RetryCount);
    until (FAppWnd <> 0) or (RetryCount > 10);

    if FAppWnd <> 0 then // wenn das Fenster der ViewerApp gefunden wurde
    begin
      Winapi.Windows.SetParent(FAppWnd, SEInfo.Wnd);
      SetWindowLong(FAppWnd, GWL_STYLE, GetWindowLong(Handle, GWL_STYLE) and not WS_BORDER and not WS_THICKFRAME and
        not WS_DLGFRAME);

      SetWindowPos(FAppWnd, 0, 0, 0, APanel.Width, APanel.Height, SWP_ASYNCWINDOWPOS);

      Delay(1000);

      ShowWindow(FAppWnd, SW_SHOWMAXIMIZED);
    end;
  end;

[PeterPanino]

Ich habe jetzt folgendes versucht, aber es funktioniert leider auch nicht:

Delphi-Quellcode:

procedure TForm1.Delay(Milliseconds: Integer);
var
  Tick: DWORD;
  Event: THandle;
  WindRect, OldRect: TRect;
begin
  Event := CreateEvent(nil, False, False, nil);
  try
    Tick := GetTickCount + DWORD(Milliseconds);
    GetWindowRect(FAppWnd, OldRect);
    while (Milliseconds > 0) and (MsgWaitForMultipleObjects(1, Event, False, Milliseconds, QS_ALLINPUT) <> WAIT_TIMEOUT) do
    begin
      Application.ProcessMessages;
      if Application.Terminated then EXIT;

      GetWindowRect(FAppWnd, WindRect);
      if OldRect <> WindRect then EXIT;
      OldRect := WindRect;

      Milliseconds := Tick - GetTickCount;
    end;
  finally
    CloseHandle(Event);
  end;
end;

[PeterPanino]

So funktioniert es jetzt perfekt:

Delphi-Quellcode:

object Form1: TForm1
  Left = 1846
  Top = 421
  Caption = 'Form1'
  ClientHeight = 681
  ClientWidth = 656
  Color = clBtnFace
  DoubleBuffered = True
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  DesignSize = (
    656
    681)
  PixelsPerInch = 96
  TextHeight = 13
  object Button1: TButton
    Left = 24
    Top = 24
    Width = 177
    Height = 25
    Caption = 'Embed Viewer App'
    TabOrder = 0
    OnClick = Button1Click
  end
  object Panel1: TPanel
    Left = 8
    Top = 64
    Width = 640
    Height = 609
    Anchors = [akLeft, akTop, akRight, akBottom]
    TabOrder = 1
    OnResize = Panel1Resize
    object Panel2: TPanel
      Left = 1
      Top = 1
      Width = 638
      Height = 607
      Align = alClient
      BevelOuter = bvNone
      TabOrder = 0
      ExplicitLeft = 96
      ExplicitTop = 200
      ExplicitWidth = 185
      ExplicitHeight = 41
    end
  end
  object Button2: TButton
    Left = 216
    Top = 24
    Width = 177
    Height = 25
    Caption = 'Release Viewer App'
    TabOrder = 2
    OnClick = Button2Click
  end
end

Delphi-Quellcode:

unit MainForm;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Panel1: TPanel;
    Button2: TButton;
    Panel2: TPanel;
    procedure Button1Click(Sender: TObject);
    procedure Panel1Resize(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
    FAppWnd: DWORD;
    procedure PADoEmbeddApp(APanel: TPanel; const AAppToExec, AParam: string);
    procedure PADoReleaseEmbeddedApp;
    procedure PADelay(Milliseconds: Integer; APanel: Tpanel);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  Winapi.ShellAPI;

procedure SimplePADelay(Milliseconds: Integer);
var
  Tick: DWORD;
  Event: THandle;
begin
  Event := CreateEvent(nil, False, False, nil);
  try
    Tick := GetTickCount + DWORD(Milliseconds);
    while (Milliseconds > 0) and (MsgWaitForMultipleObjects(1, Event, False, Milliseconds, QS_ALLINPUT) <> WAIT_TIMEOUT) do
    begin
      Application.ProcessMessages;
      if Application.Terminated then
        EXIT;
      Milliseconds := Tick - GetTickCount;
    end;
  finally
    CloseHandle(Event);
  end;
end;

procedure TForm1.PADelay(Milliseconds: Integer; APanel: Tpanel);
var
  Tick: DWORD;
  Event: THandle;
  WindRect, OldRect: TRect;
begin
  Event := CreateEvent(nil, False, False, nil);
  try
    Tick := GetTickCount + DWORD(Milliseconds);
    GetWindowRect(FAppWnd, OldRect);
    while (Milliseconds > 0) and (MsgWaitForMultipleObjects(1, Event, False, Milliseconds, QS_ALLINPUT) <> WAIT_TIMEOUT) do
    begin
      Application.ProcessMessages;
      if Application.Terminated then
        EXIT;

      GetWindowRect(FAppWnd, WindRect);
      if OldRect <> WindRect then
      begin
        APanel.Repaint;
        APanel.Update;
        Application.ProcessMessages;
        EXIT;
      end;
      OldRect := WindRect;

      Milliseconds := Tick - GetTickCount;
    end;
  finally
    CloseHandle(Event);
  end;
end;

procedure TForm1.PADoEmbeddApp(APanel: TPanel; const AAppToExec, AParam: string);
// App starten und einbetten
// uses Winapi.ShellAPI;
var
  ExecuteFile: string;
  SEInfo: TShellExecuteInfo;
  RetryCount: Integer;
begin
  FillChar(SEInfo, SizeOf(SEInfo), 0);
  SEInfo.cbSize := SizeOf(TShellExecuteInfo);
  with SEInfo do
  begin
    fMask := SEE_MASK_NOCLOSEPROCESS;
    Wnd := APanel.Handle;
    lpFile := PChar(AAppToExec);
    lpParameters := PChar(AParam);
    nShow := SW_HIDE;
  end;

  if ShellExecuteEx(@SEInfo) then // wenn Programm erfolgreich gestartet wurde
  begin
    RetryCount := 0;
    CodeSite.Send('VOR repeat');
    repeat
      FAppWnd := FindWindow(PChar('HH Parent'), nil);
      //Sleep(100);
      SimplePADelay(100);
      Inc(RetryCount);
    until (FAppWnd <> 0) or (RetryCount > 10);
    CodeSite.Send('NACH until');

    if FAppWnd <> 0 then // wenn das Fenster der ViewerApp gefunden wurde
    begin
      APanel.Visible := False;
      try
        Screen.Cursor := crHourGlass;
        try
          Winapi.Windows.SetParent(FAppWnd, SEInfo.Wnd);
          SetWindowLong(FAppWnd, GWL_STYLE, GetWindowLong(Handle, GWL_STYLE) and not WS_BORDER and not WS_THICKFRAME and not WS_DLGFRAME);
          SetWindowPos(FAppWnd, 0, 0, 0, APanel.Width, APanel.Height, SWP_ASYNCWINDOWPOS);

          CodeSite.Send('VOR PADelay');
          PADelay(2000, APanel);
          CodeSite.Send('NACH PADelay');

          ShowWindow(FAppWnd, SW_SHOWMAXIMIZED);
          ShowWindow(FAppWnd, SW_SHOWMAXIMIZED);
        finally
          Screen.Cursor := crDefault;
        end;
      finally
        APanel.Visible := True;
      end;
    end;
  end;
end;

procedure TForm1.PADoReleaseEmbeddedApp;
// Eingebettetes Programm beenden
begin
  if FAppWnd <> 0 then
  begin
    PostMessage(FAppWnd, WM_Close, 0, 0);
    FAppWnd := 0;
  end;
end;

procedure TForm1.Panel1Resize(Sender: TObject);
// Größe von Embedded App zusammen mit Fenster verändern
begin
  if IsWindow(FAppWnd) then
  begin
    SetWindowPos(FAppWnd, 0, 0, 0, Panel1.Width, Panel1.Height, SWP_ASYNCWINDOWPOS);
    ShowWindow(FAppWnd, SW_SHOWMAXIMIZED);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  PADoEmbeddApp(Panel2, 'hh.exe', 'R:\Example.chm');
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  PADoReleaseEmbeddedApp;
end;

end.

Was jetzt noch nervt, ist das lästige Flackern beim Ändern der Fenstergröße.

[Faxe]

Was passiert wenn GetTickCount nach gut 41 Tagen wieder bei 0 anfängt?

[Neutral General]

Zitat von Faxe:

Was passiert wenn GetTickCount nach gut 41 Tagen wieder bei 0 anfängt?

Man nimmt einen Kredit für die Stromrechnung auf.