如何判断程序是否运行

Question

如何判断程序是否运行?  我想实现的是如何判断程序本身是否运行   还有就是判断C盘的A.EXE是否运行

Answer 1

'程序启动时加上这段：
If App.PrevInstance Then
    MsgBox "本程序已经运行！", vbInformation
    End
End If

Answer 2

'以下代码在窗体中。请增加一个按扭控件
Private Sub Command1_Click()
 Dim objWMIService As Object
 Dim objProcess As Object
 Dim colproceaaes As Object
 
 Dim IsLoad As Boolean
 IsLoad = False
 Dim IsobjProcess As Object
 
 Const ABOVE_NORMAL = 32768
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
    & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcesses = objWMIService.ExecQuery _
    ("Select * from Win32_Process Where Name = 'A.exe'") '此处请用要查找的文件名称
For Each objProcess In colProcesses
    If objProcess.ExecutablePath = "C:\A.exe" Then  '此处用完整路径及文件名称
      IsLoad = True
      Set IsobjProcess = objProcess
    End If
NextIf IsLoad = True Then
   If MsgBox("C:\A.exe 已经运行,要不要结束此进程?", vbYesNo) = vbYes Then
      IsobjProcess.Terminate
   End If
End If
End Sub

Answer 3

If App.PrevInstance Then
    MsgBox "本程序已经运行！", vbInformation
    End
End If
上面很常用fvflove 的方法好象很优秀的

Answer 4

用fvflove的这段代码吧，不错
Private Sub Command1_Click()
 Dim objWMIService As Object
 Dim objProcess As Object
 Dim colproceaaes As Object
 
 Dim IsLoad As Boolean
 IsLoad = False
 Dim IsobjProcess As Object
 
 Const ABOVE_NORMAL = 32768
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
    & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcesses = objWMIService.ExecQuery _
    ("Select * from Win32_Process Where Name = 'A.exe'") '此处请用要查找的文件名称
For Each objProcess In colProcesses
    If objProcess.ExecutablePath = "C:\A.exe" Then  '此处用完整路径及文件名称
      IsLoad = True
      Set IsobjProcess = objProcess
    End If
NextIf IsLoad = True Then
   If MsgBox("C:\A.exe 已经运行,要不要结束此进程?", vbYesNo) = vbYes Then
      IsobjProcess.Terminate
   End If
End If
End Sub

Answer 5

判断某个exe文件是否已运行，下面的方法不错：
Private Declare Function CreateFile Lib "KERNEL32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As String, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "KERNEL32" (ByVal hObject As Long) As Long
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const INVALID_HANDLE_VALUE = -1
Private Function IsFileRun(ByVal pFile As String) As Boolean
    Dim ret As Long
    ret = CreateFile(pFile, GENERIC_READ Or GENERIC_WRITE, 0&, vbNullString, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0&)
    IsFileRun = (ret = INVALID_HANDLE_VALUE)
    CloseHandle ret
End Function'用法：
'if dir("c:\myfile.exe")<>"" and IsFileRun("c:\myfile.exe") then msgbox "文件c:\myfile.exe已运行！"
'由于这个函数在文件不存在的情况下也会返回true，所以要先用dir检查一下文件是否存在。

Answer 6

那就用互斥体吧，可以识别是不是同一个exe的不同副本。
在论坛上或者任何一个搜索引擎搜互斥体，有很多VB的例子。

Answer 7

Private Sub Form_Load()
       If App.PrevInstance Then
         Unload Me
       End If
End Sub
这是最基本的也是一般常用的防止多个实例运行的方法。但该方法有个缺陷，就是不同路径下的程序能重复运行。
下面介绍几种能够弥补上面方法中存在缺陷的2种方法:
 第一种:通过读取和修改注册表的值
    Dim isFirstOne As Boolean   '只有第一个运行的实例退出时才修改注册表值
Private Sub Form_Load()
      Dim rKey As String
      isFirstOne = False
   
     rKey = GetSetting(App.Title, "Test", "isRun", "")      '从注册表中读取值
     If rKey = "Run" Then          '如果已经运行，则卸载窗体
        Unload Me
        Exit Sub                   '这句话不能省，不然程序会继续执行
     End If
     isFirstOne = True             '第一个实例运行，标志为true
   
    Call SaveSetting(App.Title, "Test", "isRun", "Run")    '在注册表中注册值
End Sub
Private Sub Form_Unload(Cancel As Integer)
    If isFirstOne Then
      Call SaveSetting(App.Title, "Test", "isRun", "NotRun")  '在注册表中注册值
    End If
End Sub
第二种：这种方法比较复杂，由于该方法涉及的API很多，应用到子类，windows消息处理的基本知识，所以理解起来也有一定的难度。
    实现原理:
        通过创建互斥事件(类似线程),通过自定义消息，发送给所有顶级窗体，在自己的窗体里接收该自定义消息。然后处理，从而达到一个实例的运行。
注意:
     加了该代码后无法进行调试。且关闭时必须卸载互斥事件。并且非exe文件运行时，必须从窗体里关闭，不能点停止按钮。
     另:需要在登陆窗体和主窗体中各加一段代码。(如果登陆窗体和主窗体没有完全衔接，则在中间窗体上也需要加上该代码，防止专漏洞，运行出现错误)
    Private Sub Form_Initialize()
      WindowMsg = RegisterWindowMessage(Unique)
      hMutex = OpenMutex(MUTEX_ALL_ACCESS, False, Unique)
      If hMutex = 0 Then
         hMutex = CreateMutex(sa, False, Unique)         '创建消息互斥事件
       Else
        Ret=BroadcastSystemMessage(BSF_IGNORECURRENTTASKOr BSF_POSTMESSAGE, BSM_APPLICATIONS,WindowMsg, 0, 0)   '向所有顶级窗体发送自定一消息事件，并要求返回是否接收
        If Ret > 0 Then   ‘大于0表示已经运行了该实例
           Set frmLogin = Nothing
           UnWindowHook Me.hwnd   ‘这句不能省，经过试验，发现少了这句，有时会出错
           End   ‘退出窗体(因为Initialize事件在Load之前)       
        End If
    End If
End SubPrivate Sub Form_Load()
   WindowHook Me.hwnd         '设定窗体消息先经过自定义窗体消息处理程序处理
End SubPrivate Sub Form_Unload(Cancel As Integer)
   UnWindowHook Me.hwnd       '还原原窗体消息处理程序，关闭互斥事件
End Sub模块中：
Public Declare Function OpenMutex Lib "kernel32" Alias "OpenMutexA" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal lpName As String) As Long
Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const SYNCHRONIZE = &H100000
Public Const MUTANT_QUERY_STATE = &H1
Public Const MUTANT_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or MUTANT_QUERY_STATE)
Public Const MUTEX_ALL_ACCESS = MUTANT_ALL_ACCESS
Public Const BSF_IGNORECURRENTTASK = &H2
Public Const BSF_POSTMESSAGE = &H10
Public Const BSM_APPLICATIONS = &H8Public Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End TypePublic Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" (lpMutexAttributes As SECURITY_ATTRIBUTES, ByVal bInitialOwner As Long, ByVal lpName As String) As Long
Public Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Public Declare Function BroadcastSystemMessage Lib "user32" (ByVal dw As Long, pdw As Long, ByVal un As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPublic Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As LongPublic Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Const SW_HIDE = 0
Public Const SW_SHOWNORMAL = 1Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetForegroundWindow Lib "user32" () As LongPrivate Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_WNDPROC = (-4)
Public lPrevWndProc As Long                 '前一窗体过程
Public hMutex As Long                       '互斥事件句柄
Public WindowMsg As Long                    '自定义消息
Public sa As SECURITY_ATTRIBUTES            '安全属性Public Const Unique = "msg1"             '自定义消息名Public Function NewWindowProc(ByVal hwnd As Long, ByVal Msg As Long, _
                              ByVal wParam As Long, ByVal lParam As Long) As Long       '自定义窗体消息处理过程(子类)
    Select Case Msg
        Case WindowMsg              '自定义窗体消息处理
            ShowWindow hwnd, SW_SHOWNORMAL
            If GetForegroundWindow() <> hwnd Then
                SetForegroundWindow hwnd                    '窗体提到前台
            End If
        Case Else
            NewWindowProc = CallWindowProc(lPrevWndProc, hwnd, Msg, wParam, lParam)  '消息交由原窗体消息处理程序处理
    End Select
End Function
Public Sub WindowHook(ByVal hwnd As Long)           '设置窗体钩子
    lPrevWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf NewWindowProc)
End Sub
Public Sub UnWindowHook(ByVal hwnd As Long)                 '卸载窗体钩子
    If lPrevWndProc <> GetWindowLong(hwnd, GWL_WNDPROC) Then
        SetWindowLong hwnd, GWL_WNDPROC, lPrevWndProc
        CloseHandle hMutex
    End If
End Sub