Вот полный код модуля с этой функцией:
- Код: Выделить всё
'функции API
'информация о памяти
Public Declare Function GetProcessMemoryInfo Lib "PSAPI.DLL" (ByVal hProcess As Long, ppsmemCounters As PROCESS_MEMORY_COUNTERS, ByVal cb As Long) As Long
'уничтожение манипулятора
Public Declare Function CloseHandle Lib "Kernel32.dll" (ByVal Handle As Long) As Long
'открытие процесса
Public Declare Function OpenProcess Lib "Kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
'список процессов
Public Declare Function EnumProcesses Lib "PSAPI.DLL" (ByRef lpidProcess As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
'имя модуля
Public Declare Function GetModuleFileNameExA Lib "PSAPI.DLL" (ByVal hProcess As Long, ByVal hModule As Long, ByVal ModuleName As String, ByVal nSize As Long) As Long
'список модулей
Public Declare Function EnumProcessModules Lib "PSAPI.DLL" (ByVal hProcess As Long, ByRef lphModule As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
'создание "моментального снимка" системы
Public Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long
'получение версии
Public Declare Function GetVersionExA Lib "kernel32" (lpVersionInformation As OSVERSIONINFO) As Integer
'установка таймера
Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
'снятие таймера
Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
'состояние памяти
Public Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
'первый процесс в снимке
Public Declare Function Process32First Lib "kernel32" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
'следующий процесс в снимке
Public Declare Function Process32Next Lib "kernel32" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
'константы API
Public Const PROCESS_QUERY_INFORMATION = 1024
Public Const PROCESS_VM_READ = 16
Public Const MAX_PATH = 260
Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const SYNCHRONIZE = &H100000
Public Const PROCESS_ALL_ACCESS = &H1F0FFF
Public Const TH32CS_SNAPPROCESS = &H2&
Public Const hNull = 0
Public Const WIN95_System_Found = 1
Public Const WINNT_System_Found = 2
Public Const Default_Log_Size = 10000000
Public Const Default_Log_Days = 0
Public Const SPECIFIC_RIGHTS_ALL = &HFFFF
Public Const STANDARD_RIGHTS_ALL = &H1F0000
Public Const TH32CS_SNAPHEAPLIST = &H1
Public Const TH32CS_SNAPTHREAD = &H4
Public Const TH32CS_SNAPMODULE = &H8
Public Const TH32CS_SNAPALL = (TH32CS_SNAPHEAPLIST Or TH32CS_SNAPPROCESS Or TH32CS_SNAPTHREAD Or TH32CS_SNAPMODULE)
Public Const TH32CS_INHERIT = &H80000000
'структуры API
Type MEMORYSTATUS
dwLength As Long
dwMemoryLoad As Long
dwTotalPhys As Long
dwAvailPhys As Long
dwTotalPageFile As Long
dwAvailPageFile As Long
dwTotalVirtual As Long
dwAvailVirtual As Long
End Type
Type PROCESS_MEMORY_COUNTERS
cb As Long
PageFaultCount As Long
PeakWorkingSetSize As Long
WorkingSetSize As Long
QuotaPeakPagedPoolUsage As Long
QuotaPagedPoolUsage As Long
QuotaPeakNonPagedPoolUsage As Long
QuotaNonPagedPoolUsage As Long
PagefileUsage As Long
PeakPagefileUsage As Long
End Type
Public 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 * 260
End Type
Public Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long '1 = Windows 95.
'2 = Windows NT
szCSDVersion As String * 128
End Type
Private Function getVersion() As Long
Dim osinfo As OSVERSIONINFO
Dim RetValue As Integer
osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = Space$(128)
RetValue = GetVersionExA(osinfo)
getVersion = osinfo.dwPlatformId
End Function
Private Function StrZToStr(s As String) As String
StrZToStr = Left$(s, Len(s) - 1)
End Function
Public Function GetProcesses(ByVal EXEName As String) As Long
Dim booResult As Boolean
Dim lngLength As Long
Dim lngProcessID As Long
Dim strProcessName As String
Dim lngSnapHwnd As Long
Dim udtProcEntry As PROCESSENTRY32
Dim lngCBSize As Long
Dim lngCBSizeReturned As Long
Dim lngNumElements As Long
Dim lngProcessIDs() As Long
Dim lngCBSize2 As Long
Dim lngModules(1 To 200) As Long
Dim lngReturn As Long
Dim strModuleName As String
Dim lngSize As Long
Dim lngHwndProcess As Long
Dim lngLoop As Long
Dim b As Long
Dim c As Long
Dim e As Long
Dim d As Long
Dim pmc As PROCESS_MEMORY_COUNTERS
Dim lret As Long
Dim strProcName2 As String
Dim strProcName As String
On Error GoTo Error_handler
booResult = False
EXEName = UCase$(Trim$(EXEName))
lngLength = Len(EXEName)
Dim lngCount As Long
lngCount = 0
Select Case getVersion()
Case WIN95_System_Found
GetProcesses = GetProcesses9x(EXEName)
Exit Function
Case Else
lngCBSize = 8
lngCBSizeReturned = 96
Do While lngCBSize <= lngCBSizeReturned
DoEvents
lngCBSize = lngCBSize * 2
ReDim lngProcessIDs(lngCBSize / 4) As Long
lngReturn = EnumProcesses(lngProcessIDs(1), lngCBSize, lngCBSizeReturned)
Loop
lngNumElements = lngCBSizeReturned / 4
For lngLoop = 1 To lngNumElements
DoEvents
lngHwndProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, lngProcessIDs(lngLoop))
If lngHwndProcess <> 0 Then
lngReturn = EnumProcessModules(lngHwndProcess, lngModules(1), 200, lngCBSize2)
If lngReturn <> 0 Then
strModuleName = Space(MAX_PATH)
lngSize = 500
lngReturn = GetModuleFileNameExA(lngHwndProcess, lngModules(1), strModuleName, lngSize)
strProcessName = Left(strModuleName, lngReturn)
strProcessName = UCase$(Trim$(strProcessName))
strProcName2 = GetElement(Trim(Replace(strProcessName, Chr$(0), "")), "\", 0, 0, GetNumElements(Trim(Replace(strProcessName, Chr$(0), "")), "\") - 1)
If UCase(strProcName2) = UCase(EXEName) Then
pmc.cb = LenB(pmc)
lret = GetProcessMemoryInfo(lngHwndProcess, pmc, pmc.cb)
lngCount = lngCount + 1
End If
End If
End If
lngReturn = CloseHandle(lngHwndProcess)
DoEvents
Next
End Select
GetProcesses = lngCount
IsProcessRunning_Exit:
Exit Function
Error_handler:
Resume Next
End Function
Public Function GetProcesses9x(EXEName As String) As Long
On Error Resume Next
Dim hSnapShot As Long, uProcess As PROCESSENTRY32
Dim strNm As String, lngCount As Long
hSnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0&)
uProcess.dwSize = Len(uProcess)
r = Process32First(hSnapShot, uProcess)
lngCount = 0
Do While r
DoEvents
strNm = Left$(uProcess.szExeFile, IIf(InStr(1, uProcess.szExeFile, Chr$(0)) > 0, InStr(1, uProcess.szExeFile, Chr$(0)) - 1, 0))
If UCase(strNm) = UCase(EXEName) Then lngCount = lngCount + 1
r = Process32Next(hSnapShot, uProcess)
Loop
CloseHandle hSnapShot
GetNumberOfProcesses = lngCount
End Function
Public Function GetElement(ByVal strList As String, ByVal strDelimiter As String, ByVal lngNumColumns As Long, ByVal lngRow As Long, ByVal lngColumn As Long) As String
Dim lngCounter As Long
strList = strList & strDelimiter
lngColumn = IIf(lngRow = 0, lngColumn, (lngRow * lngNumColumns) + lngColumn)
For lngCounter = 0 To lngColumn - 1
strList = Mid$(strList, InStr(strList, strDelimiter) + Len(strDelimiter), Len(strList))
If Len(strList) = 0 Then
GetElement = ""
Exit Function
End If
Next lngCounter
GetElement = Left$(strList, InStr(strList, strDelimiter) - 1)
End Function
Public Function GetNumElements(ByVal strList As String, ByVal strDelimiter As String) As Integer
Dim intElementCount As Integer
If Len(strList) = 0 Then
GetNumElements = 0
Exit Function
End If
strList = strList & strDelimiter
While InStr(strList, strDelimiter) > 0
intElementCount = intElementCount + 1
strList = Mid$(strList, InStr(strList, strDelimiter) + 1, Len(strList))
Wend
GetNumElements = intElementCount
End Function
Также прилагается программа-пример:
http://amelso.narod.ru/testing/appinstances.zip