vb6进程的个数

Treenewbee 2014-07-08 02:10:31

假设编译后的程序文件为“player.exe",
如果需要在打开程序时，窗口标题为player-n，n为当前打开的player.exe进程的个数，该如何写代码？

...全文

366 15 打赏收藏转发到动态举报

写回复

用AI写文章

15 条回复

切换为时间正序

请发表友善的回复…

发表回复

码之魂 2014-07-18

打赏
举报

....问题是... 1.程序意外终止了,那其他的标题是否要变? 2.任何外部统计的都不可取,意外终止了,谁去更新他们? 定时刷新进程,然后相应的进行自增自减

一如既往哈 2014-07-15

打赏
举报

引用 13 楼 Previouspage 的回复:

[quote=引用 11 楼 Topc008 的回复:] 嘿，还没贴代码就回复了..... 记得引用Microsoft Scripting Runtime 并添加一个listbox控件且打开排序功能.....


Option Explicit
Private Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long ''0为非法窗口
Private fFile As String, fFold As String, loadTime As String
'''''''引用Microsoft Scripting Runtime
'''''''添加一个开启排序的listbox控件
Private Sub Form_Load()
    On Error Resume Next
    fFold = Replace(App.Path & "\", "\\", "\", 1, , vbTextCompare) & "tmp\"
    MkDir fFold ''创建目录
    fFile = fFold & Me.hWnd & ".txt" ''设置文件名
    loadTime = Format$(Now(), "yyyy-mm-dd hh:nn:ss") ''保存启动时间
    WriteText fFile, loadTime & "," & Me.hWnd
    Test ''检测序号
    Timer1.Interval = 5000 ''设置定时器
    Timer1.Enabled = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    Kill fFile ''删除文件
End Sub
Private Sub Timer1_Timer()
    On Error Resume Next
    ''每隔5s写一次文件
    WriteText fFile, loadTime & "," & Me.hWnd
    Test ''检测序号
End Sub
Sub Test()
    ''检测所有实例并根据时间判断次序
    On Error Resume Next
    Dim fso As New FileSystemObject, bFile As File
    Dim bTr As Boolean, w1 As String, i As Long, ww
    List1.Clear
    ''获取所有实例并利用listbox排序
    For Each bFile In fso.GetFolder(fFold).Files
        w1 = Trim(bFile.OpenAsTextStream.ReadAll) ''得到内容
        ww = Split(w1, ",") ''time,hwnd
        bTr = False
        If UBound(ww) = 1 Then
            If IsNumeric(ww(1)) Then
                If IsWindow(CLng(ww(1))) Then bTr = True
            End If
        End If
        If bTr Then
            ''添加到listbox中自动排序
            List1.AddItem w1
        Else
            bFile.Delete True ''删除非法的文件
        End If
    Next
    With List1
        For i = 0 To .ListCount - 1
            ww = Split(.List(i), ",")
            If Me.hWnd = CLng(ww(1)) Then Me.Caption = "Player-" & CStr(i + 1): Exit For
        Next
    End With
End Sub
Sub WriteText(ByVal FullNames As String, ByVal Strs As String)
    On Error GoTo errs
    Dim fso As New FileSystemObject
    fso.CreateTextFile(FullNames, True).Write Strs
errs:
    Set fso = Nothing
End Sub

感谢回复。这个方法可行，最多只用一个外部文件该如何修改？[/quote] 只用一个外部文件，情况就会复杂的........

Treenewbee 2014-07-14

打赏
举报

引用 11 楼 Topc008 的回复:

嘿，还没贴代码就回复了..... 记得引用Microsoft Scripting Runtime 并添加一个listbox控件且打开排序功能.....


Option Explicit
Private Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long ''0为非法窗口
Private fFile As String, fFold As String, loadTime As String
'''''''引用Microsoft Scripting Runtime
'''''''添加一个开启排序的listbox控件
Private Sub Form_Load()
    On Error Resume Next
    fFold = Replace(App.Path & "\", "\\", "\", 1, , vbTextCompare) & "tmp\"
    MkDir fFold ''创建目录
    fFile = fFold & Me.hWnd & ".txt" ''设置文件名
    loadTime = Format$(Now(), "yyyy-mm-dd hh:nn:ss") ''保存启动时间
    WriteText fFile, loadTime & "," & Me.hWnd
    Test ''检测序号
    Timer1.Interval = 5000 ''设置定时器
    Timer1.Enabled = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    Kill fFile ''删除文件
End Sub
Private Sub Timer1_Timer()
    On Error Resume Next
    ''每隔5s写一次文件
    WriteText fFile, loadTime & "," & Me.hWnd
    Test ''检测序号
End Sub
Sub Test()
    ''检测所有实例并根据时间判断次序
    On Error Resume Next
    Dim fso As New FileSystemObject, bFile As File
    Dim bTr As Boolean, w1 As String, i As Long, ww
    List1.Clear
    ''获取所有实例并利用listbox排序
    For Each bFile In fso.GetFolder(fFold).Files
        w1 = Trim(bFile.OpenAsTextStream.ReadAll) ''得到内容
        ww = Split(w1, ",") ''time,hwnd
        bTr = False
        If UBound(ww) = 1 Then
            If IsNumeric(ww(1)) Then
                If IsWindow(CLng(ww(1))) Then bTr = True
            End If
        End If
        If bTr Then
            ''添加到listbox中自动排序
            List1.AddItem w1
        Else
            bFile.Delete True ''删除非法的文件
        End If
    Next
    With List1
        For i = 0 To .ListCount - 1
            ww = Split(.List(i), ",")
            If Me.hWnd = CLng(ww(1)) Then Me.Caption = "Player-" & CStr(i + 1): Exit For
        Next
    End With
End Sub
Sub WriteText(ByVal FullNames As String, ByVal Strs As String)
    On Error GoTo errs
    Dim fso As New FileSystemObject
    fso.CreateTextFile(FullNames, True).Write Strs
errs:
    Set fso = Nothing
End Sub

感谢回复。这个方法可行，最多只用一个外部文件该如何修改？

舉杯邀明月 2014-07-13

打赏
举报

尽在瞎操心！
楼主都没说清楚具体需求，五花八门的代码就来了。
-_-!!!

赵4老师 2014-07-12

打赏
举报

引用 8 楼 Topc008 的回复:

[quote=引用 7 楼 zhao4zhong1 的回复:] [quote=引用 5 楼 Topc008 的回复:] 没那么复杂吧？用注册表或一个公有文件，每启动一个实例，写入本窗口的hwnd并读入已有几个实例了，然后修改相应的标题即可。如果加一个定时器，还可以动态修改编号呢！（比如中间某个实例关闭了，后面的编号自动更新...）

风险是某个进程意外退出了，……[/quote] 这有啥风险？用一个iswindow就可以排除意外退出的进程.......[/quote] 意外退出的那个进程不会去减文件或注册表中的计数器的。

一如既往哈 2014-07-12

打赏
举报

嘿，还没贴代码就回复了..... 记得引用Microsoft Scripting Runtime 并添加一个listbox控件且打开排序功能.....


Option Explicit
Private Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long ''0为非法窗口
Private fFile As String, fFold As String, loadTime As String
'''''''引用Microsoft Scripting Runtime
'''''''添加一个开启排序的listbox控件
Private Sub Form_Load()
    On Error Resume Next
    fFold = Replace(App.Path & "\", "\\", "\", 1, , vbTextCompare) & "tmp\"
    MkDir fFold ''创建目录
    fFile = fFold & Me.hWnd & ".txt" ''设置文件名
    loadTime = Format$(Now(), "yyyy-mm-dd hh:nn:ss") ''保存启动时间
    WriteText fFile, loadTime & "," & Me.hWnd
    Test ''检测序号
    Timer1.Interval = 5000 ''设置定时器
    Timer1.Enabled = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    Kill fFile ''删除文件
End Sub
Private Sub Timer1_Timer()
    On Error Resume Next
    ''每隔5s写一次文件
    WriteText fFile, loadTime & "," & Me.hWnd
    Test ''检测序号
End Sub
Sub Test()
    ''检测所有实例并根据时间判断次序
    On Error Resume Next
    Dim fso As New FileSystemObject, bFile As File
    Dim bTr As Boolean, w1 As String, i As Long, ww
    List1.Clear
    ''获取所有实例并利用listbox排序
    For Each bFile In fso.GetFolder(fFold).Files
        w1 = Trim(bFile.OpenAsTextStream.ReadAll) ''得到内容
        ww = Split(w1, ",") ''time,hwnd
        bTr = False
        If UBound(ww) = 1 Then
            If IsNumeric(ww(1)) Then
                If IsWindow(CLng(ww(1))) Then bTr = True
            End If
        End If
        If bTr Then
            ''添加到listbox中自动排序
            List1.AddItem w1
        Else
            bFile.Delete True ''删除非法的文件
        End If
    Next
    With List1
        For i = 0 To .ListCount - 1
            ww = Split(.List(i), ",")
            If Me.hWnd = CLng(ww(1)) Then Me.Caption = "Player-" & CStr(i + 1): Exit For
        Next
    End With
End Sub
Sub WriteText(ByVal FullNames As String, ByVal Strs As String)
    On Error GoTo errs
    Dim fso As New FileSystemObject
    fso.CreateTextFile(FullNames, True).Write Strs
errs:
    Set fso = Nothing
End Sub

一如既往哈 2014-07-12

打赏
举报

好吧，上完整代码吧，可以根据启动时间自动排序号，即使某个进程退出了，也能在5s内自动调整编号。

一如既往哈 2014-07-11

打赏
举报

引用 7 楼 zhao4zhong1 的回复:

[quote=引用 5 楼 Topc008 的回复:] 没那么复杂吧？用注册表或一个公有文件，每启动一个实例，写入本窗口的hwnd并读入已有几个实例了，然后修改相应的标题即可。如果加一个定时器，还可以动态修改编号呢！（比如中间某个实例关闭了，后面的编号自动更新...）

风险是某个进程意外退出了，……[/quote] 这有啥风险？用一个iswindow就可以排除意外退出的进程.......

一如既往哈 2014-07-11

打赏
举报

没那么复杂吧？用注册表或一个公有文件，每启动一个实例，写入本窗口的hwnd并读入已有几个实例了，然后修改相应的标题即可。如果加一个定时器，还可以动态修改编号呢！（比如中间某个实例关闭了，后面的编号自动更新...）

赵4老师 2014-07-11

打赏
举报

引用 5 楼 Topc008 的回复:

没那么复杂吧？用注册表或一个公有文件，每启动一个实例，写入本窗口的hwnd并读入已有几个实例了，然后修改相应的标题即可。如果加一个定时器，还可以动态修改编号呢！（比如中间某个实例关闭了，后面的编号自动更新...）

风险是某个进程意外退出了，……

专注VB编程开发20年 2014-07-11

打赏
举报

findwindow就可以了，找一下现成的窗口，找到标题一致的前缀，比方有player-1,player-2了，那新出来的就用player-3，很简单的事，如果player-1也关了，还有一个player-2，新出来的也用player-3

Tiger_Zhao 2014-07-10

打赏
举报

哪有每次都有现成代码可用的！
要么给出例子自己提取相关功能，要么三言两语描述一下方法自己写代码。

舉杯邀明月 2014-07-09

打赏
举报

赵老虎的这个方法，是不是弄得太复杂了？这么大的一片代码……

Tiger_Zhao 2014-07-08

打赏
举报

Public Function GetProcesses(ByVal EXEName As String)



    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 'Specifies the size, In bytes, of the lpidProcess array

    Dim lngCBSizeReturned As Long 'Receives the number of bytes returned

    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



    'Turn on Error handler

    On Error GoTo Error_handler



   booResult = False



    EXEName = UCase$(Trim$(EXEName))

    lngLength = Len(EXEName)



    'ProcessInfo.bolRunning = False



    Select Case getVersion()

        'I'm not bothered about windows 95/98 becasue this class probably wont be used on it anyway.

        Case WIN95_System_Found 'Windows 95/98



        Case WINNT_System_Found 'Windows NT



            lngCBSize = 8 ' Really needs To be 16, but Loop will increment prior to calling API

            lngCBSizeReturned = 96



            Do While lngCBSize <= lngCBSizeReturned

                DoEvents

                'Increment Size

                lngCBSize = lngCBSize * 2

                'Allocate Memory for Array

                ReDim lngProcessIDs(lngCBSize / 4) As Long

                'Get Process ID's

                lngReturn = EnumProcesses(lngProcessIDs(1), lngCBSize, lngCBSizeReturned)

            Loop



            'Count number of processes returned

            lngNumElements = lngCBSizeReturned / 4

            'Loop thru each process



            For lngLoop = 1 To lngNumElements

            DoEvents



            'Get a handle to the Process and Open

            lngHwndProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, lngProcessIDs(lngLoop))



            If lngHwndProcess <> 0 Then

                'Get an array of the module handles for the specified process

                lngReturn = EnumProcessModules(lngHwndProcess, lngModules(1), 200, lngCBSize2)



                'If the Module Array is retrieved, Get the ModuleFileName

                If lngReturn <> 0 Then



                    'Buffer with spaces first to allocate memory for byte array

                    strModuleName = Space(MAX_PATH)



                    'Must be set prior to calling API

                    lngSize = 500



                    'Get Process Name

                    lngReturn = GetModuleFileNameExA(lngHwndProcess, lngModules(1), strModuleName, lngSize)



                    'Remove trailing spaces

                    strProcessName = Left(strModuleName, lngReturn)



                    'Check for Matching Upper case result

                    strProcessName = UCase$(Trim$(strProcessName))



                    strProcName2 = GetElement(Trim(Replace(strProcessName, Chr$(0), "")), "\", 0, 0, GetNumElements(Trim(Replace(strProcessName, Chr$(0), "")), "\") - 1)



                    If strProcName2 = EXEName Then



                        'Get the Site of the Memory Structure

                        pmc.cb = LenB(pmc)



                           lret = GetProcessMemoryInfo(lngHwndProcess, pmc, pmc.cb)



                            Debug.Print EXEName & "::" & CStr(pmc.WorkingSetSize / 1024)



                    End If

                End If

            End If

            'Close the handle to this process

            lngReturn = CloseHandle(lngHwndProcess)

            DoEvents

        Next



    End Select



IsProcessRunning_Exit:



'Exit early to avoid error handler

Exit Function

Error_handler:

    Err.Raise Err, Err.Source, "ProcessInfo", Error

    Resume Next

End Function





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 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



    ' Append delimiter text to the end of the list as a terminator.

    strList = strList & strDelimiter



    ' Calculate the offset for the item required based on the number of columns the list

    ' 'strList' has i.e. 'lngNumColumns' and from which row the element is to be

    ' selected i.e. 'lngRow'.

    lngColumn = IIf(lngRow = 0, lngColumn, (lngRow * lngNumColumns) + lngColumn)



    ' Search for the 'lngColumn' item from the list 'strList'.

    For lngCounter = 0 To lngColumn - 1



        ' Remove each item from the list.

        strList = Mid$(strList, InStr(strList, strDelimiter) + Len(strDelimiter), Len(strList))



        ' If list becomes empty before 'lngColumn' is found then just

        ' return an empty string.

        If Len(strList) = 0 Then

            GetElement = ""

            Exit Function

        End If



    Next lngCounter



    ' Return the sought list element.

    GetElement = Left$(strList, InStr(strList, strDelimiter) - 1)



End Function





''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Function GetNumElements (ByVal strList As String,

'                         ByVal strDelimiter As String)

'                         As Integer

'

'  strList      = The element list.

'  strDelimiter = The delimiter by which the elements in

'                 'strList' are seperated.

'

'  The function returns an integer which is the count of the

'  number of elements in 'strList'.

'

'  Author: Roger Taylor

'

'  Date:26/12/1998

'

'  Additional Information:

'

'  Revision History:

'

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



Public Function GetNumElements(ByVal strList As String, ByVal strDelimiter As String) As Integer



    Dim intElementCount As Integer



    ' If no elements in the list 'strList' then just return 0.

    If Len(strList) = 0 Then

        GetNumElements = 0

        Exit Function

    End If



    ' Append delimiter text to the end of the list as a terminator.

    strList = strList & strDelimiter



    ' Count the number of elements in 'strlist'

    While InStr(strList, strDelimiter) > 0

        intElementCount = intElementCount + 1

        strList = Mid$(strList, InStr(strList, strDelimiter) + 1, Len(strList))

    Wend



    ' Return the number of elements in 'strList'.

    GetNumElements = intElementCount



End Function

Tiger_Zhao 2014-07-08

打赏
举报

下面是 API-Guide 中的例子，把原先的 Debug.Print 改为计数。

'In a form

Private Sub Form_Load()

    'Code submitted by Roger Taylor

    'enumerate all the different explorer.exe processes

    GetProcesses "explorer.exe"

End Sub



'In a module



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 Process32First Lib "kernel32" (ByVal hSnapshot As Long, lppe As PROCESSENTRY32) As Long

Public Declare Function Process32Next Lib "kernel32" (ByVal hSnapshot As Long, lppe As PROCESSENTRY32) 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 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





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 ' This process

    th32DefaultHeapID As Long

    th32ModuleID As Long ' Associated exe

    cntThreads As Long

    th32ParentProcessID As Long ' This process's parent process

    pcPriClassBase As Long ' Base priority of process threads

    dwFlags As Long

    szExeFile As String * 260 ' MAX_PATH

    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