Here's the code I am currently using.
Form has 4 buttons and a listbox.
' Author: Howard Kaikow
' Author URL:
http://www.standards.com/
' Date: 7 June 2005
Option Explicit
Private Const LB_SETHORIZONTALEXTENT = &H194
Private Const MAX_PATH As Long = 260
Private Const PROCESS_ALL_ACCESS As Long = &H1F0FFF
Private Const TH32CS_SNAPPROCESS As Long = &H2
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * MAX_PATH
End Type
Private Declare Function CloseHandle Lib "KERNEL32.dll" _
(ByVal hObject As Long) As Long
Private Declare Function CreateToolhelp32Snapshot Lib "KERNEL32.dll" _
(ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long
Private Declare Function EnableWindow Lib "user32.dll" _
(ByVal hWnd As Long, ByVal fEnable As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
Private Declare Function OpenProcess Lib "KERNEL32.dll" _
(ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function Process32First Lib "KERNEL32.dll" _
(ByVal hSnapshot As Long, ByRef lppe As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "KERNEL32.dll" _
(ByVal hSnapshot As Long, ByRef lppe As PROCESSENTRY32) As Long
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 Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private appPPT As PowerPoint.Application
Private hWndDesktop As Long
Private intFile As Integer
Private InitialThreadCount As Long
Private Sub btnGetThreadCount_Click()
Dim NowThreadCount As Long
NowThreadCount = DetectPPT()
Print #intFile, "PowerPoint: Current tread count = " &
CStr(NowThreadCount)
lstActions.AddItem "PowerPoint: Current tread count = " &
CStr(NowThreadCount)
End Sub
Private Sub btnStart_Click()
Dim status As Boolean
On Error Resume Next
'Check if PowerPoint is running
Do
Set appPPT = 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
DoEvents
' Disable keyboard and mouse.
EnableWindow hWndDesktop, False
' Verify that PowerPoint is still not running
Set appPPT = GetObject(, "PowerPoint.Application")
If Err.Number = 0 Then
MsgBox "PowerPoint is still running", vbInformation + vbOK, "Test
cancelled"
Unload Me
Else
intFile = FreeFile
Open "PPTTest.txt" For Output As #intFile
Set appPPT = New PowerPoint.Application
Print #intFile, "PowerPoint: New instance was created."
lstActions.AddItem "PowerPoint: New instance was created."
DoEvents
Sleep 5000
InitialThreadCount = DetectPPT()
Print #intFile, "PowerPoint: Current tread count = " &
CStr(InitialThreadCount)
lstActions.AddItem "PowerPoint: Current tread count = " &
CStr(InitialThreadCount)
End If
' Enable keyboard and mouse.
EnableWindow hWndDesktop, True
On Error GoTo 0
End Sub
Private Sub Form_Load()
' Get handle for Desktop
hWndDesktop = GetDesktopWindow()
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()
QuitPPT
On Error Resume Next
Close #intFile
On Error GoTo 0
Unload Me
End Sub
Private Sub QuitPPT()
Dim CurrentThreadCount As Long
If TypeName(appPPT) = "Application" Then
With appPPT
DoEvents
' Disable keyboard and mouse.
EnableWindow hWndDesktop, False
Sleep 60000
CurrentThreadCount = DetectPPT()
Print #intFile, "PowerPoint: Current tread count = " &
CStr(CurrentThreadCount)
lstActions.AddItem "PowerPoint: Current tread count = " &
CStr(CurrentThreadCount)
If .Presentations.Count = 0 Then
If CurrentThreadCount = InitialThreadCount Then
.Quit
Print #intFile, "PowerPoint: New instance was Quit."
lstActions.AddItem "PowerPoint: New instance was Quit."
Else
Print #intFile, "PowerPoint: New instance was NOT Quit."
lstActions.AddItem "PowerPoint: New instance was NOT
Quit."
End If
Else
Print #intFile, "PowerPoint: New instance was NOT Quit."
lstActions.AddItem "PowerPoint: New instance was NOT Quit."
End If
' Enable keyboard and mouse.
EnableWindow hWndDesktop, True
End With
Set appPPT = Nothing
Else
Print #intFile, "PowerPoint: Invalid application object, instance,
if valid, was not Quit."
lstActions.AddItem "PowerPoint: Invalid application object,
instance, if valid, was not Quit."
End If
End Sub
Private Sub btnClearList_Click()
lstActions.Clear
End Sub
Private Function DetectPPT() As Long
Const powerpnt As String = "POWERPNT.EXE"
Dim hProcessSnap As Long
Dim hProcess As Long
Dim pe32 As PROCESSENTRY32
' Take a snapshot of all processes in the system.
hProcessSnap = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
If hProcessSnap = 0 Then
lstActions.AddItem "Error: CreateToolhelp32Snapshot"
DetectPPT = 0
Exit Function
End If
pe32.dwSize = Len(pe32)
If Process32First(hProcessSnap, pe32) = 0 Then
lstActions.AddItem "Error: Process32First"
DetectPPT = 0
Else
' Walk the snapshot of processes, and
' display information about each process
Do
If InStr(UCase$(pe32.szExeFile), powerpnt) <> 0 Then
hProcess = OpenProcess(PROCESS_ALL_ACCESS, 0,
pe32.th32ProcessID)
If hProcess = 0 Then
lstActions.AddItem "Error: OpenProcess"
DetectPPT = 0
Else
DetectPPT = pe32.cntThreads
End If
Exit Do
End If
Loop While (Process32Next(hProcessSnap, pe32) <> 0)
End If
CloseHandle (hProcessSnap)
End Function
