Content Supported by Sourcelens Consulting
VERSION 5.00
Begin VB.Form frmSplashDemo
BorderStyle = 3 'Fixed Dialog
Caption = "Using a Splash Screen"
ClientHeight = 1710
ClientLeft = 1515
ClientTop = 1470
ClientWidth = 5565
ClipControls = 0 'False
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
PaletteMode = 1 'UseZOrder
ScaleHeight = 114
ScaleMode = 3 'Pixel
ScaleWidth = 371
ShowInTaskbar = 0 'False
Begin VB.CommandButton cmdAppStartup
Caption = "With&out Splash"
Height = 500
Index = 1
Left = 3015
TabIndex = 1
Top = 1080
Width = 1395
End
Begin VB.CommandButton cmdAppStartup
Caption = "&With Splash"
Height = 500
Index = 0
Left = 915
TabIndex = 0
Top = 1080
Width = 1215
End
Begin VB.Label Label1
BorderStyle = 1 'Fixed Single
Caption = "Using a splash screen provides the user with feedback while your application is loading."
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00800000&
Height = 720
Left = 30
TabIndex = 2
Top = 45
Width = 5490
End
End
Attribute VB_Name = "frmSplashDemo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_TemplateDerived = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub cmdAppStartup_Click(Index As Integer)
Dim dStartTime As Double
dStartTime = Timer
Select Case Index
Case 0 'With Splash
ShowSplash
Case 1 'No Splash
NoSplash
End Select
MsgBox "Startup Time = " & Format$(Timer - dStartTime, "##.##") & " secs.", _
vbInformation, _
"App Startup Time"
End Sub
Private Sub NoSplash()
' Now load a bunch of forms.
Dim foo1 As New frmImages
foo1.Caption = "Foo1"
foo1.Left = 0
foo1.Top = 0
Dim foo2 As New frmImages
foo2.Caption = "Foo2"
foo2.Left = 200
foo2.Top = 100
Dim foo3 As New frmImages
foo3.Caption = "Foo3"
foo3.Left = 300
foo3.Top = 150
Dim foo4 As New frmImages
foo4.Caption = "Foo4"
foo4.Left = 400
foo4.Top = 200
End Sub
Private Sub ShowSplash()
Dim success%
Dim iStatusBarWidth As Integer
On Error GoTo SplashLoadErr
iStatusBarWidth = 4575
Screen.MousePointer = vbHourglass
Load Splash
Splash.Show
DoEvents
' Set the splash screen to stay on top.
success% = SetWindowPos(Splash.hWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS)
' Now load a bunch of forms.
Dim foo1 As New frmImages
'Splash.Refresh
foo1.Caption = "Foo1"
foo1.Move 0, 0
DoEvents
Splash.rctStatusBar.Width = iStatusBarWidth * 0.25
Dim foo2 As New frmImages
'Splash.Refresh
foo2.Caption = "Foo2"
foo2.Move 0, 0
DoEvents
Splash.rctStatusBar.Width = iStatusBarWidth * 0.5
Dim foo3 As New frmImages
'Splash.Refresh
foo3.Caption = "Foo3"
foo3.Move 0, 0
DoEvents
Splash.rctStatusBar.Width = iStatusBarWidth * 0.75
Dim foo4 As New frmImages
'Splash.Refresh
foo4.Caption = "Foo4"
foo4.Move 0, 0
DoEvents
Splash.rctStatusBar.Width = iStatusBarWidth
' Turn off the top most window flag.
success% = SetWindowPos(Splash.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS)
Unload Splash
Screen.MousePointer = vbDefault
Exit Sub
SplashLoadErr:
success% = SetWindowPos(Splash.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS)
Unload Splash
Screen.MousePointer = vbDefault
MsgBox Error$ & " - " & Str$(Err), vbExclamation, "Application Load Error"
Exit Sub
End Sub
Private Sub Form_Load()
Me.Left = frmExplore.Width + 400
Me.Top = (Screen.Height - Me.Height) * 0.9
End Sub