' Author: Howard Kaikow
' Author URL: http://www.standards.com/
' Date: 12 June 2005
Option Explicit
Private Const LB_SETHORIZONTALEXTENT = &H194
Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private appPPTOriginal As PowerPoint.Application
Private appPPTVisible As PowerPoint.Application
Private appPPTNonVisible As PowerPoint.Application
Private appPPTNonVisibleWithPresentation As PowerPoint.Application
Private intFile As Integer
Private Sub btnPPTNonVisibleWithPresentation_Click()
Dim presPPT As PowerPoint.Presentation
On Error Resume Next
Set appPPTNonVisibleWithPresentation = GetObject(, "PowerPoint.Application")
If Err.Number = 0 Then
Print #intFile, "PowerPoint: Another non-Visible, with presentation, instance was created."
lstActions.AddItem "PowerPoint: Another non-Visible, with presentation, instance was created."
Debug.Print "PowerPoint: Another non-Visible, with presentation, instance was created."
Set presPPT = appPPTNonVisibleWithPresentation.Presentations.Add
Else
Print #intFile, "PowerPoint: Another non-Visible, with presentation, Huh!"
lstActions.AddItem "PowerPoint: Another non-Visible, with presentation, Huh!"
Debug.Print "PowerPoint: Another non-Visible, with presentation, Huh!"
End If
On Error GoTo 0
btnPPTNonVisibleWithPresentation.Visible = False
End Sub
Private Sub btnPPTNew_Click()
On Error Resume Next
'Check if PowerPoint is running
Do
Set appPPTOriginal = GetObject(, "PowerPoint.Application")
If Err.Number = 0 Then
If vbCancel = MsgBox("Stop all running instances of PowerPoint, and then choose Retry to continue this test." _
& vbCrLf & vbCrLf & "Or choose Cancel to cancel this test.", vbInformation + vbRetryCancel, "PowerPoint is currently running") Then
Unload Me
Exit Sub
End If
Else
Err.Clear
Exit Do
End If
Loop
' Verify that PowerPoint is still not running
Set appPPTOriginal = GetObject(, "PowerPoint.Application")
If Err.Number = 0 Then
MsgBox "PowerPoint is still running", vbInformation + vbOK, "Test cancelled"
Unload Me
Else
Set appPPTOriginal = New PowerPoint.Application
Print #intFile, "PowerPoint: New non-visible instance was created."
lstActions.AddItem "PowerPoint: New non-visible instance was created."
Debug.Print "PowerPoint: New non-visible instance was created."
btnPPTNew.Visible = False
btnPPTVisible.Visible = True
btnPPTNonVisible.Visible = True
btnPPTNonVisibleWithPresentation.Visible = True
btnQuitNewPPT.Visible = True
End If
On Error GoTo 0
btnClearList.Visible = True
End Sub
Private Sub btnPPTVisible_Click()
On Error Resume Next
Set appPPTVisible = GetObject(, "PowerPoint.Application")
If Err.Number = 0 Then
Print #intFile, "PowerPoint: Visible instance was created."
lstActions.AddItem "PowerPoint: Visible instance was created."
Debug.Print "PowerPoint: Visible instance was created."
appPPTVisible.Visible = True
Else
Print #intFile, "PowerPoint: Visible Huh!"
lstActions.AddItem "PowerPoint: Visible Huh!"
Debug.Print "PowerPoint: Visible Huh!"
End If
On Error GoTo 0
btnPPTVisible.Visible = False
End Sub
Private Sub btnPPTNonVisible_Click()
On Error Resume Next
Set appPPTNonVisible = GetObject(, "PowerPoint.Application")
If Err.Number = 0 Then
Print #intFile, "PowerPoint: Another non-Visible instance was created."
lstActions.AddItem "PowerPoint: Another non-Visible instance was created."
Debug.Print "PowerPoint: Another non-Visible instance was created."
Else
Print #intFile, "PowerPoint: Another non-Visible Huh!"
lstActions.AddItem "PowerPoint: Another non-Visible Huh!"
Debug.Print "PowerPoint: Another non-Visible Huh!"
End If
On Error GoTo 0
btnPPTNonVisible.Visible = False
End Sub
Private Sub btnQuitNewPPT_Click()
If TypeName(appPPTOriginal) = "Application" Then
With appPPTOriginal
If .Presentations.Count = 0 Then
Print #intFile, "PowerPoint: (0)New non-visible instance was Quit."
lstActions.AddItem "PowerPoint: (0)New non-visible instance was Quit."
Debug.Print "PowerPoint: (0)New non-visible instance was Quit."
Else
Print #intFile, "PowerPoint: (not 0)New non-visible instance was Quit."
lstActions.AddItem "PowerPoint: (not 0)New non-visible instance was Quit."
Debug.Print "PowerPoint: (not 0)New non-visible instance was Quit."
End If
.Quit
Set appPPTOriginal = Nothing
End With
btnQuitNewPPT.Visible = False
Unload Me
End If
End Sub
Private Sub Form_Load()
btnClearList.Visible = False
btnPPTVisible.Visible = False
btnPPTNonVisible.Visible = False
btnPPTNonVisibleWithPresentation.Visible = False
btnQuitNewPPT.Visible = False
intFile = FreeFile
Open "PPTTest.txt" For Output As #intFile
End Sub
Private Sub Form_Activate()
With lstActions
SendMessage .hWnd, LB_SETHORIZONTALEXTENT, _
ScaleX(.Width, vbTwips, vbPixels) + 150, ByVal 0&
End With
End Sub
Private Sub btnByeBye_Click()
Dim PPTCount As Long
QuitPPT
Unload Me
End Sub
Private Sub QuitPPT()
If TypeName(appPPTOriginal) = "Application" Then
With appPPTOriginal
' Non-visible uses of PowerPoint added AFTER this code created NEW non-visible
' instance get killed if there is no VISIBLE use of PowerPoint.
If .Presentations.Count = 0 Then
Print #intFile, "PowerPoint: (0)New non-visible instance was NOT Quit."
lstActions.AddItem "PowerPoint: (0)New non-visible instance was NOT Quit."
Debug.Print "PowerPoint: (0)New non-visible instance was NOT Quit."
Else
Print #intFile, "PowerPoint: (not 0)New non-visible instance was NOT Quit."
lstActions.AddItem "PowerPoint: (not 0)New non-visible instance was NOT Quit."
Debug.Print "PowerPoint: (not 0)New non-visible instance was NOT Quit."
End If
End With
End If
End Sub
Private Sub btnClearList_Click()
lstActions.Clear
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
Close #intFile
On Error GoTo 0
End Sub