Просмотр исходного текста страницы IBSQL WaitWindow.pas

  unit IBSQL_WaitWindow;
 
  interface
 
  uses
    Classes, Windows, Messages;
 
  type
    TIBSQL_WaitWindowThread = class(TThread)
    private
      FWnd, FLabel: hWnd;
      FStartTime: DWORD;
      FShow: Boolean;
      FScreenWidth, FScreenHeight: Integer;
 
      procedure CreateWinAPIForm;
      procedure RegisterWindowClass;
      procedure UnRegisterWindowClass;
 
    protected
      procedure Execute; override;
 
    public
      procedure StartSQL;
      procedure FinishSQL;
    end;
 
  var
    IBSQL_WaitWindowThread: TIBSQL_WaitWindowThread;
 
  implementation
 
  uses
    SysUtils, Forms;
 
  const
    WindowClassName = 'IBSQL_WaitWindowClass';
    idLabel = 1;
    idTimer = 2;
    InitialDelay = 2000;
    RefreshRate = 1000;
 
  function WindowProc(Wnd: HWnd; Msg: Integer; WParam: WParam; LParam: LParam): LResult; stdcall;
  begin
    Result := DefWindowProc(Wnd, Msg, WParam, LParam);
  end;
 
  { TIBSQL_WaitWindowThread }
 
  procedure TIBSQL_WaitWindowThread.CreateWinApiForm;
  const
    WindowHeight = 80;
    WindowWidth = 232;
  begin
    FWnd := CreateWindowEx(
      WS_EX_DLGMODALFRAME or WS_EX_TOPMOST,
      WindowClassName,
      'Идет выполнение SQL запроса...',
      WS_DLGFRAME or WS_VISIBLE,
      (FScreenWidth - WindowWidth) div 2,
      (FScreenHeight - WindowHeight) div 2,
      WindowWidth,
      WindowHeight,
      0, 0,
      hInstance,
      nil);
 
    FLabel := CreateWindow(
      'static',
      '',
      WS_VISIBLE or WS_CHILD or BS_TEXT,
      12, 18,
      WindowWidth - 20, 20,
      FWnd,
      idLabel,
      hInstance,
      nil);
 
    SetTimer(FWnd, idTimer, RefreshRate, nil);
 
    ShowWindow(FWnd, SW_SHOW);
  end;
 
  procedure TIBSQL_WaitWindowThread.Execute;
  var
    Msg: TMsg;
    T: DWORD;
  begin
    RegisterWindowClass;
    try
      while not Terminated do
      begin
        if not FShow then
          Suspend
        else begin
          T := 0;
          FStartTime := GetTickCount;
          Sleep(InitialDelay);
          if not FShow then
            continue;
          CreateWinApiForm;
          try
            while (not Terminated) and FShow
              and GetMessage(Msg, 0, 0, 0) do
            begin
              TranslateMessage(Msg);
              DispatchMessage(Msg);
              if GetTickCount - T >= RefreshRate then
              begin
                T := GetTickCount;
                SetWindowText(FLabel,
                  PChar('Время выполнения: ' + IntToStr((GetTickCount - FStartTime) div 1000) + ' сек.'));
              end;
            end;
          finally
            KillTimer(FWnd, idTimer);
            DestroyWindow(FWnd);
          end;
        end;
      end;
    finally
      UnRegisterWindowClass;
    end;
  end;
 
  procedure TIBSQL_WaitWindowThread.FinishSQL;
  begin
    FShow := False;
  end;
 
  procedure TIBSQL_WaitWindowThread.RegisterWindowClass;
  var
    WC: TWndClassEx;
  begin
    WC.cbsize := SizeOf(WC);
    WC.style := cs_bytealignwindow or cs_hredraw or cs_vredraw or cs_noclose or cs_savebits;
    WC.lpfnwndproc := @WindowProc;
    WC.cbclsextra := 0;
    WC.cbwndextra := 0;
    WC.hInstance := hInstance;
    WC.hIcon := LoadIcon(0, idi_application);
    WC.hCursor := LoadCursor(0, idc_arrow);
    WC.hbrBackground := 1;
    WC.lpszMenuName := nil;
    WC.lpszClassName := WindowClassName;
    WC.hIconSm := 0;
    Windows.RegisterClassEx(WC);
  end;
 
  procedure TIBSQL_WaitWindowThread.StartSQL;
  begin
    if Suspended and (not FShow) then
    begin
      FScreenWidth := Screen.Width;
      FScreenHeight := Screen.Height;
      FShow := True;
      Resume;
    end;
  end;
 
  procedure TIBSQL_WaitWindowThread.UnRegisterWindowClass;
  begin
    Windows.UnregisterClass(WindowClassName, hInstance);
  end;
 
  initialization
    IBSQL_WaitWindowThread := TIBSQL_WaitWindowThread.Create(True);
    IBSQL_WaitWindowThread.Priority := tpLowest;
    IBSQL_WaitWindowThread.FreeOnTerminate := False;
 
  finalization
    FreeAndNil(IBSQL_WaitWindowThread);
  end.