IBSQL WaitWindow.pas

Текущая версия на 18:10, 23 мая 2008

 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.