pbthreadedsplashscreenu.pas

Threaded Splash Form on Screen in Delphi, show an example on how to make a threaded splashscreen

      Show
    Else
      Hide;
  End; { If }
end;

procedure TPBThreadedSplashscreen.Show;
begin
  If not Visible Then Begin
    FVisible := true;
    try
      FShowThread := TPBSplashThread.Create( self );
    except
      FVisible := false;
      raise
    end;
  End; { If }
end;

procedure TPBThreadedSplashscreen.ShowStatusMessage(const msg: String);
begin
  If UseStatusbar and Visible Then
    TPBSplashThread( FShowThread ).ShowStatusMessage( msg );
end;

{棗 TPBSplashThread 棗棗棗棗棗棗棗棗棗棗棗棗棗棗棗棗棗棗棗棗棗棗棗棗棗梷

{ This is a helper function that will be used as window proc for the
 splash screen class. Its only reason for existence is the sad fact
 that the TMessage record passed to the threads WndProc does not contain
 the window handle of the splash screen. This is a problem for all
 messages that are send during the windows creation (the call to
 CreateWindowEx), since for those the thread objects FWnd field will not
 have a value yet. We need the handle during WM_CREATE processing, however.

 This function only handles WM_NCCREATE, the very first message a window
 will receive. We store the window handle into the thread object and then
 subclass the window to use the threads WindowProc for any further
 messages. The thread objects reference is handed to CreateWIndowEx as
 user parameter, so we can retrieve it from the createstruct passed via
 lparam here. }
Function CreateWndProc( wnd: HWND; msg: Cardinal; wparam: WPARAM; lparam: LPARAM ): LRESULT; stdcall;
  Var
    thread: TPBSplashThread;
  Begin
    If msg = WM_NCCREATE Then Begin
      thread := TPBSplashThread( PCreateStruct( lparam )^.lpCreateParams );
      thread.FWnd := wnd;
      SetWindowLong( wnd, GWL_WNDPROC, Integer( thread.FCallstub ));
      result := 1;
    End
    Else // will actually never get here, but better safe than sorry
      result := DefWindowProc( wnd, msg, wparam, lparam );
  End;

procedure TPBSplashThread.CenterSplashScreen;
var
  r, workarea: TRect;
  x, y: Integer;
begin
  Win32Check( GetWindowRect( FWnd, r ));
  SystemParametersInfo( SPI_GETWORKAREA, sizeof( workarea ), @workarea, 0 );
  x:= ((workarea.Right - workarea.Left) - (r.Right - r.Left )) div 2;
  y:= ((workarea.Bottom - workarea.Top) - (r.Bottom - r.Top )) div 2;
  SetWindowPos( FWnd, 0, x, y, 0, 0, SWP_NOSIZE or SWP_NOZORDER );
end;

constructor TPBSplashThread.Create(aSplashScreen: TPBThreadedSplashscreen);
begin
  Assert( Assigned( aSplashscreen ) );
  inherited Create( true );
  FSplash := aSplashScreen;
  FCallstub:= MakeObjectInstance( WndProc );
  FGuardian:= TCriticalSection.Create;
  Init;
  CreateWindowclass;
  Resume;
end;

procedure TPBSplashThread.CreateSplashWindow;
const
  TopmostStyle: Array [Boolean] of DWORD = (0, WS_EX_TOPMOST );
  NoActivateStyle : Array [Boolean] of DWORD = (0, WS_EX_NOACTIVATE );
var
  wsize: TSize;
begin
  wsize.cx := FSurface.Width + GetSystemMetrics( SM_CXEDGE ) * 2;
  wsize.cy := FSurface.Height + GetSystemMetrics( SM_CYEDGE ) * 2;
  FWnd := CreateWindowEx(
            TopmostStyle[ FTopmost ] or WS_EX_TOOLWINDOW
            or WS_EX_STATICEDGE or WS_EX_CLIENTEDGE
            or NoActivateStyle[ Win32MajorVersion >= 5 ],
            MakeIntResource( FWndClass ),
            nil,
            WS_POPUP or WS_BORDER,
            Forigin.x, Forigin.y,
            wsize.cx, wsize.cy,
            0, 0, hInstance, self );
  If FWnd = 0 Then
    raise exception.create('TPBSplashThread.CreateSplashWindow: CreateWindowEx failed');
    // RaiseLastOSError;
end;

procedure TPBSplashThread.CreateStatusBar;
var
  initrec: TInitCommonControlsEx;
  ncInfo: TNonClientMetrics;
  h: Integer;
  r: TRect;
begin
  initrec.dwSize := sizeof( initrec );
  initrec.dwICC  := ICC_BAR_CLASSES;
  Win32Check( InitCommonControlsEx( initrec ));
  ncInfo.cbSize := sizeof( ncInfo );
  SystemParametersInfo( SPI_GETNONCLIENTMETRICS, ncinfo.cbsize,
                        @ncinfo, 0 );
  h:= Abs(ncinfo.lfStatusFont.lfHeight)+ ncinfo.iBorderWidth * 2 + 4;
  Win32Check( GetWindowRect( FWnd, r ));
  SetWindowPos( Fwnd, 0, 0, 0, r.Right-r.left,
               r.Bottom-r.top+h,
               SWP_NOMOVE or SWP_NOZORDER );
  FStatusbar := CreateWindow(
              STATUSCLASSNAME,
              nil,
              WS_CHILD or WS_VISIBLE,
              0, FSurface.Height,
              FSurface.Width, h,
              FWnd, 0, hInstance, nil );
  If FStatusbar = 0 THen
    RaiseLastOSError;

  SendMessage( FStatusbar, SB_SIMPLE, 1, 0 );
  FGuardian.Acquire;
  try
    If FStatusMessage <> '' Then
      SendMessage( FStatusbar,
                   SB_SETTEXT,
                   255,
                   Integer( Pchar( FStatusMessage )));
  finally
    FGuardian.Release;
  end;
end;

procedure TPBSplashThread.CreateWindowclass;
var
  wndclass: TWndClass;
  S: String;
begin
  fillchar( wndclass, sizeof( wndclass ), 0 );
  wndclass.style := CS_NOCLOSE or CS_OWNDC or CS_VREDRAW or CS_HREDRAW;
  wndclass.lpfnWndProc := @CreateWndProc;
  wndclass.hInstance := hInstance;
  wndclass.hCursor := LoadCursor( 0, IDC_WAIT );
  wndclass.hbrBackground := HBRUSH( COLOR_WINDOW );
  S:= Format( '%s_wnd_%x',[ classname, getcurrentthreadid() ] );
  wndclass.lpszClassName := Pchar( S );
  FWndClass:= Windows.Registerclass( wndclass );
  If FWndClass = 0 Then
    RaiseLastOSError;
end;

procedure TPBSplashThread.DefaultHandler(var Message);
begin
  With TMessage( Message ) Do
    Result := DefWindowProc( FWnd, Msg, wparam, lparam );
end;

destructor TPBSplashThread.Destroy;
begin
  If FWnd <> 0 Then
    PostMessage( FWnd, WM_CLOSE, 0, 0 );
  inherited;
  FreeObjectInstance( FCallstub );
  FGuardian.Free;
  FSurface.Free;
  DestroyWindowClass;
end;

procedure TPBSplashThread.DestroyWindowClass;
begin
  If FWndClass <> 0 Then
    Windows.UnregisterCLass( MakeIntResource( FWndClass ), hInstance );
end;

procedure TPBSplashThread.Execute;
var
  msg: TMsg;
begin
  // create the threads message queue
  PeekMessage( msg, 0, 0, 0, PM_NOREMOVE );
  Try
    CreateSplashWindow;
    ShowWindow( FWnd, SW_SHOWNORMAL );
    While GetMessage( msg, 0, 0, 0 ) Do Begin
      TranslateMessage( msg );
      DispatchMessage( msg );
    End; { While }
  Except
    On E: Exception Do
      ReportException( E );
  End; { Except }
end;

procedure TPBSplashThread.Init;
begin
  FUseStatusbar := FSplash.UseStatusbar;
  FCenter       := FSplash.Center;
  FOrigin       := Point( FSplash.Left, FSplash.Top );
  If not Assigned( FSurface ) Then
    FSurface  := TBitmap.Create;
  FSurface.Assign( FSplash.Image );
  FTopmost      := FSplash.FTopmost;
end;

procedure TPBSplashThread.ReportException(E: Exception);
var
  s: String;
begin
  S:= Format( 'Error in TPBSplashThread, class %s:'#13#10'%s',
              [E.classname, E.Message] );
  Messagebox( 0,Pchar(S), 'Error', MB_OK or MB_ICONHAND );
end;

procedure TPBSplashThread.ShowStatusMessage(const msg: String);
begin
  If FStatusbar <> 0 Then
    SendMessage( FStatusbar,
                 SB_SETTEXT,
                 255,
                 Integer( Pchar( msg )))
  Else Begin
    FGuardian.Acquire;
    try
      FStatusMessage := msg;
    finally
      Fguardian.Release;
    end
  End; { Else }
end;

procedure TPBSplashThread.UpdateContent(sender: Tobject);
begin
  FGuardian.Acquire;
  Try
    FSurface.Assign( FSplash.Image );
    { We could provide for changes of the image size as well here,
      but since that will be rarely needed let's skip it for now. }
  Finally
    FGuardian.Release;
  End; { Finally }
  InvalidateRect( FWnd, nil, true );
end;

procedure TPBSplashThread.WMCreate(var msg: TWMCreate);
begin
  msg.result := 1;
  If FUseStatusbar Then
    CreateStatusbar;
  If FCenter Then
    CenterSplashScreen;
end;

procedure TPBSplashThread.WMEraseBkGnd(var msg: TWMEraseBkGnd);
begin
  msg.Result := 1;
  FGuardian.Acquire;
  try
    FSurface.Canvas.Lock;
    Bitblt( msg.DC, 0, 0, Fsurface.Width, FSurface.Height,
            FSurface.Canvas.Handle, 0, 0, SRCCOPY );
    FSurface.Canvas.UnLock;
  finally
    FGuardian.Release;
  end;
end;

procedure TPBSplashThread.WMNCHittest(var msg: TWMNCHITTEST);
begin
  inherited;
  If msg.Result = HTCLIENT Then
    msg.Result := HTCAPTION;
end;

procedure TPBSplashThread.WndProc(var msg: TMessage);
begin
  try
    msg.result := 0;
    Case msg.Msg Of
      WM_CLOSE   : DestroyWindow( FWnd );
      WM_DESTROY : PostQuitMessage( 0 );
      WM_NCDESTROY: FWnd := 0;
    Else
      Dispatch( msg );
    End;
  except
    On E:Exception Do
      ReportException( E );
  end;
end;

End.