关于防止程序多重运行的问题

Question

在写程序时有一个问题解决不了，特来求教高手指点。 
此程序需要在后台做一些操作，并且程序中窗体的Visible和ShowInTaskbar属性都已经设为False，程序将来运行时，可以放到任何一个目录中。 
我现在想做到，此程序的一个实例启动后（任意目录中的），先判断是否有其它的实例正在运行，如果有就循环等待其它程序实例结束后再继续执行。 
程序的其它功能能已经做好了，现在就在这一个功能上卡壳了。 
试过几个方法都不太理想： 
1、用CreateFile 带FILE_FLAG_DELETE_ON_CLOSE创建临时文件。 
2、用CreateMutex创建约定名称的互斥体。 
3、用BroadcastSystemMessage或PostMessage传递自定义消息。 
这几种方法都试了一下，好像都存在先前实例非正常结束，没有正确关闭某句柄，导致后面运行的实例不能正常判断先前的程序已经结束。 
也许是我对这几个函数的用法不太了解，希望高手给个解决方案。不甚感谢！App.PrevInstance 属性只能判断同一位置的实例。如果两个程序在不同的文件夹就不行了。

Answer 1

使用CreateFile创建一个知名文件，并且使用eXclusive Lock，完全可以达到应用。除非程序进程没有完全退出，否则即便是非正常退出，系统也会帮你把文件句柄给关闭掉，相比之下，这个就可以做到按用户来保证单一实例，也可以是全局，关键看文件放在什么地方去。包括MSDN当中关闭CreateMutex的Res当中也有提到：
If you are using a named mutex to limit your application to a single instance, a malicious user can create this mutex before you do and prevent your application from starting. To prevent this situation, create a randomly named mutex and store the name so that it can only be obtained by an authorized user. Alternatively, you can use a file for this purpose. To limit your application to one instance per user, create a locked file in the user's profile directory.

Answer 2

你也可以用   FindWindow   (lpszYourWndClassName,   NULL)   来判断。

Answer 3

DECLARE INTEGER FindWindow IN Win32API STRING,STRING 
*Declare integer FindWindow IN USER32.DLL STRING,STRING &&或用此句 
LOCAL cTitle 
cTitle="窗体的Caption" 
IF FindWindow(0,cTitle)<>0 
MESSAGEBOX("程序已运行！",48,"信息提示") 
RETURN 
*QUIT 
ENDIF 
CLEAR DLLS 

Answer 4

最好的办法就是unsigned所说的方法
说通俗点就是这样
sub form_load()
on error goto errhandler
if not fileexist("C:\windows\temp\applock.tmp") then
filecreate "C:\windows\temp\applock.tmp"
end if
open "C:\windows\temp\applock.tmp" for binary as #1
'占用此文件
'在进程结束时windows会自动释放
errhandler:
'说明程序正在使用
end sub

Answer 5

貌似互斥体在宿主挂了后也会消失?不知道有没有记错.不过我检查了一下我以前的一个代码,好象没这现象:http://www.m5home.com/blog2/blogview.asp?logID=466&cateID=2测试过程:先启动一个实例,再启动另一复制的EXE,先启动的实例会提示已经启动.然后结束先启动的实例(用任务管理器),再启动复制的或原EXE,均正常启动.....

Answer 6

晕，写注册表或写文件来判断，不就得了.
具体是:
Option Explicit
Private iCount As Integer                       '记录实例个数Private Sub Form_Load()
        Open "C:\Windows\System32\Data.ini" For Binary As #1
        If LOF(1) Then                          '文件长度不为0(说明已记录)
           Get #1, , iCount                     '获取实例个数
           iCount = iCount + 1                  '实例个数加1
           Seek #1, 1                           '定位到文件开头
           Put #1, , iCount                     '写入当前实例个数
        Else                                    '文件长度为0(说明没有记录)
           Put #1, , 1                          '表示是第一个实例
        End If
        Close #1
End SubPrivate Sub Form_Unload(Cancel As Integer)
        Open "C:\Data.ini" For Binary As #1
        Get #1, , iCount
        iCount = iCount - 1                     '实例个数减1
        Seek #1, 1
        Put #1, , iCount                        '写入当前实例个数
        Close #1
End Sub

Answer 7

写错了
Option Explicit
Private iCount As Integer                       '记录实例个数Private Sub Form_Load()
        Open "C:\Windows\System32\Data.ini" For Binary As #1
        If LOF(1) Then                          '文件长度不为0(说明已记录)
           Get #1, , iCount                     '获取实例个数
           iCount = iCount + 1                  '实例个数加1
           Seek #1, 1                           '定位到文件开头
           Put #1, , iCount                     '写入当前实例个数
        Else                                    '文件长度为0(说明没有记录)
           Put #1, , 1                          '表示是第一个实例
        End If
        Close #1
End SubPrivate Sub Form_Unload(Cancel As Integer)
        Open "C:\Windows\System32\Data.ini" For Binary As #1
        Get #1, , iCount
        iCount = iCount - 1                     '实例个数减1
        Seek #1, 1
        Put #1, , iCount                        '写入当前实例个数
        Close #1
End Sub

Answer 8

option explicit
Private Sub Timer1_Timer()
        Dim iCount As Integer
        Open "c:\Windows\System32\data.ini" For Binary Access Read As #1
        Get #1, , iCount
        Close #1
        if iCount <> 0 then Msgbox "有实例在运行","提示"
End Sub

Answer 9

To jy497759649,如果两个程序同一时间运行呢？虽然这种可能性很低，但是如果是通过程序一调用就大不一样了。

Answer 10

To jy497759649
如果你的程序非正常退出，比如被任务管理器关了，你的计数不就不对了？

Answer 11

额 form_unload里面的代码在非正常退出时是不会执行的

Answer 12

这个问题我也曾经考虑过，想法到有，但未经过测试，今天正好说说，如果楼主试成功了，可以在此大家共享：方案一，使用互斥体，CreateMutex 
　　因为进程中止前，如不慎未采取删除措施，就会将这个互斥体标记为废弃，并自动释放所有权。共享这个互斥体的其他应用程序也许仍然能够用它，但会接收到一个废弃状态信息，指出上一个所有进程未能正常关闭。这种状况是否会造成影响取决于涉及到的具体应用程序。方案二：使用两个比较古老的API，SetProp和GetProp，以桌面为窗口写入/读取信息。当然这可能不利于“环保”^_^首先, 这两个方案都是全局的，因此不同的程序也可以读取或修改它。这在程序正常启动和停止时都没有任何问题。关键点在于它们的命名，我考虑除了加一个有特点的前缀外，还要加入窗口的hwnd和进程ID，这样，如果没有得到数据，说明没有前一个实例在运行，通常这是程序正常运行时的状态。另外，在读取这个值后，可以通过API来判断这个窗口或进程的状态，这样就可以知道窗口是否已关闭或进程是否仍在正常运行中了。

Answer 13

很简单,试试这个就可以了
Private Sub Form_Load()
If App.PrevInstance Then MsgBox "程序已经启动了，": End
End Sub

Answer 14

很简单,试试这个就可以了,在不同的文件夹全可以 Private Sub Form_Load()
On Error GoTo aa
If VB.App.PrevInstance Then MsgBox "程序已经启动了，": End
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.Createfolder("c:\" & "tt")
Exit Sub
aa: MsgBox "程序已经启动了，": End
End SubPrivate Sub Form_Unload(Cancel As Integer)
Set fs = CreateObject("Scripting.FileSystemObject")
 fs.Deletefolder "c:\" & "tt"
End Sub

Answer 15

分别有一下几种方法
1.查找窗口法
    用Findwindow函数查找窗口类名和标题的窗口，然后在去判断是否执行程序。如果找到了说明程
序已经运行，不运行程序。如果没有找到，则启动当前程序。Findwindow的API函数声明如下：
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long具体实现：调用Findwindow函数，得到一个返回值，把此值赋给句柄变量，
用IF语句判断句柄变量等于0时启动程序，否则结束程序，提示程序已运行演示代码如下：Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long 'Findwindow的API声明Private Sub Form_Initialize()
Dim Frmhwnd As Long '定义一个变量接收Findwindow返回的句柄
Frmhwnd = FindWindow(vbNullString, "运行的窗口") '调用Findwindow查找"运行的窗口"标题的窗口
If hwnd = 0 Then '没有找到返回0
FrmMain.Show '创建并显示窗口
Else
MsgBox "程序已经运行，不能再次装载", vbExclamation, "提示" '返回句柄不为0，找到窗口提示程序运行
End '软件不运行，退出程序
End If
End Sub
2.使用互斥对象
    互斥对象：能够确保多个线程对单个资源的互斥访问，即一起运行的任何线程对某资源的访问都是排他的。
该资源不会同时被两个或两个以上的线程所访问。利用互斥对象就可以限制进程的启动。Createmutex的API函数声明如下
Private Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" (ByVal lpMutexAttributes As Long, _
ByVal bInitialOwner As Long, ByVal lpName As String) As Long具体实现：通过调用API函数Createmutex创建一个互斥对象，如果成功并同时调用GetlasError函数返回的值
ERROR_ALREADY_EXISTS比较，若相等，那么说明当前进程不是应用程序的第一个实例，直接结束掉程序并提示
程序已运行。若不相等，则说明是应用程的第一个实例。演示代码如下：Private Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" (ByVal lpMutexAttributes As Long, _
ByVal bInitialOwner As Long, ByVal lpName As String) As Long
Private Declare Function ReleaseMutex Lib "kernel32" (ByVal hMutex As Long) As Long '释放由线程拥有的一个互斥体
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long '关闭一个互斥体对象
Public ret As LongPrivate Sub Form_Load()
ret = CreateMutex(ByVal 0, 1, "互斥对象") '调用CreateMutex创建一个名为“互斥对象”的互斥对象
If Err.LastDllError = 183 Then '判断程序是不是第一个实例
MsgBox "程序只能运行一次!", vbExclamation, "提示" '不是第一个实例提示
End '软件不执行，程序退出
End If
End SubPrivate Sub Form_Unload(Cancel As Integer)
Call ReleaseMutex(ret) '释放互斥对象
Call CloseHandle(ret) '关闭互斥对象
End Sub注意：在软件关闭之时应该要释放和关闭互斥对象，否则在下次运行程序将无法打开程序，原因是互斥对象还存在。
3.全局原子法
全局原子：由Windows系统负责维持的，它能保证其中的每个原子都是唯一的，管理其引用计数，
并且当该全局原子的引用计数为0时，系统就会从该内存将该原子清除掉。添加全局原子用API函数GlobalAddatom
Public Declare Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomA" (ByVal lpString As String) As Integer
查找全局原子用API函数GlobalFindAtomA
Public Declare Function GlobalFindAtom Lib "kernel32" Alias "GlobalFindAtomA" (ByVal lpString As String) As Integer
删除全局原子用API函数GlobalDeleteAtom
Public Declare Function GlobalDeleteAtom Lib "kernel32" Alias "GlobalDeleteAtom" (ByVal nAtom As Integer) As Integer具体实现：利用GlobalAddatom函数向系统添加全局原子，然后利用GlobalFindAtomA函数查找是否存在该原子，
若村子结束运行并提示程序已运行，否则启动程序。在进程退出时记得使用GlobalDeleteAtom函数删除之前添加
的全局原子，否则下次程序将无法启动。利用全局原子的引用计数规则，还可以判断当前共运行了该程序的多少个实例。4.利用App对象的PrevInstance属性这个比较简单一点，利用VB自带的利用App对象的PrevInstance属性的真假就可以判断程序有没有运行了
当App.PrevInstance为True说明程序已经运行了，此时在运行程序将提示程序已经运行了，不可以在运再
次装在，否则App.PrevInstance为False则可以运行程序。演示代码如下：Private Sub Form_Load()
If App.PrevInstance = True Then
MsgBox "程序已经运行，不能再次装载", vbExclamation, "提示"
Unload Me
End If
End Sub

Answer 16

楼主说"我现在想做到，此程序的一个实例启动后（任意目录中的），先判断是否有其它的实例正在运行，如果有就循环等待其它程序实例结束后再继续执行。 "
可以判断楼主不是想简单的判断是否有其他实例在运行，而是每次运行程序时先判断是否有其他实例在运行，如果有的话就做一个循环等待直到没有任何其他实例运行时在继续执行下面的代码，那这就需要一个执行队列。假设用注册表的键值来保存实例执行队列的pid值（用字符隔开好拆分）程序运行后从头检测pid队列中各值是否有效，如存在有效pid则将本实例pid添加至队列末尾，然后循环检测pid队列，直到队列为空或者pid队列中值全部无效，跳出循环继续执行代码。退出程序时将pid队列中本实例的pid移除。

Answer 17

记得不要重复添加同一实例pid

Answer 18

Option ExplicitPublic Const SYNCHRONIZE = &H100000
Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public cpid As LongPublic Sub Main()
    Dim st As String
    Dim et As String
    Dim pidQueue As String
    Dim pid As Long
    Dim apid() As String
    Dim i As Integer
    
    st = Format(Time, "HH:MM:SS")
    cpid = GetCurrentProcessId
    pidQueue = GetSetting("multiapp", "pid", "queue", "NONE")
    If pidQueue = "NONE" Or pidQueue = "" Then
        SaveSetting "multiapp", "pid", "queue", CStr(cpid)
    Else
        AddQueue
        Do While Not SelfTurn
            Sleep 100
            DoEvents
        Loop
    End If
    et = Format(Time, "HH:MM:SS")
    MsgBox "启动时间：" & st & vbCrLf & "运行时间：" & et
    RemoveQueue
End SubPublic Function isPID(pid As Long) As Boolean
    Dim Handle As Long
    
    Handle = OpenProcess(SYNCHRONIZE, 0, pid)
    
    If Handle = 0 Then Exit Function
    CloseHandle Handle
    isPID = True
End FunctionPublic Function SelfTurn() As Boolean
    Dim pqueue As String
    Dim pid() As String
    
    SelfTurn = True
    Do While True
        pqueue = GetSetting("multiapp", "pid", "queue")
        If pqueue = "" Then Exit Function
        pid = Split(pqueue, "|", , vbTextCompare)
        If isPID(Val(pid(0))) Then
            SelfTurn = cpid = Val(pid(0))
            Exit Function
        Else
            If Not RemoveQueue Then Exit Function
        End If
        DoEvents
    Loop
    SelfTurn = False
End FunctionPublic Sub AddQueue()
    Dim pqueue As String
    
    pqueue = GetSetting("multiapp", "pid", "queue")
    SaveSetting "multiapp", "pid", "queue", pqueue & "|" & CStr(cpid)
End SubPublic Function RemoveQueue() As Boolean
    Dim i As Integer
    Dim pqueue As String
    
    pqueue = GetSetting("multiapp", "pid", "queue")
    If pqueue = "" Then Exit Function
    i = InStr(1, pqueue, "|", vbTextCompare)
    If i = 0 Then
        SaveSetting "multiapp", "pid", "queue", ""
    Else
        SaveSetting "multiapp", "pid", "queue", Right(pqueue, Len(pqueue) - i)
    End If
    RemoveQueue = True
End Function
给分吧老大。

Answer 19

我看有必要在显要位置给出CSDN分值运作系统的原理.....不然总有人不知道结帖......

Answer 20

这几句都中了
Private Sub Form_Load() 
If App.PrevInstance Then
End
End If
End Sub

Answer 21

无论程序放在任何地方，程序只能运行一次。
Option Explicit'防止程序重复执行Private Declare Function ReleaseSemaphore Lib "kernel32" (ByVal hSemaphore As Long, ByVal lReleaseCount As Long, lpPreviousCount As Long) As Long
Private Declare Function CreateSemaphore Lib "kernel32" Alias "CreateSemaphoreA" (lpSemaphoreAttributes As SECURITY_ATTRIBUTES, ByVal lInitialCount As Long, ByVal lMaximumCount As Long, ByVal lpName As String) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End TypePrivate Sub Form_Load()
On Error Resume Next
'让程序在不同地点只能运行一次
'用此程序段的原因：因为App.PrevInstance 只能影响同目录的同一程序
'但不能影响其它目录的同一程序。
'--------------------------------------------------------------
Dim MdiMenuHwnd As Long
Dim hMenu As Long
Dim Semaphore As String, Sema As Long, Security As SECURITY_ATTRIBUTES
Dim PrevSemaphore As Long, Turn As Long
Security.bInheritHandle = True
'默认的安全值
Security.lpSecurityDescriptor = 0
Security.nLength = Len(Security)
Semaphore = "第一个"   '此处的值每个程序都不能一样，否则凡是此处写第一个的程序都不能运行二次
'创建或打开一个Semaphore记数信号，设资源空闲使用量为1
Sema = CreateSemaphore(Security, 1, 1, Semaphore)
'申请一个权限，并立即返回
Turn = WaitForSingleObject(Sema, 0)
'如果不是正常返回，则表示没有申请到资源的使用权限
If Turn <> 0 Then
       MsgBox "此程序已经在运行了！", vbExclamation Or vbOKOnly, Me.Caption
       End
End If
End Sub源文件下载地址:http://hi.baidu.com/icecept/blog/item/2d357dd10e7f1e3b9a502743.html

Answer 22

LS的代码应该标准一点   虽然最后都会被销毁  但感觉还是按套路出牌好点Private Sub Form_Unload(Cancel As Integer)
ReleaseSemaphore Sema, 1, ByVal 0
CloseHandle Sema
End Sub
也可以用GlobalAddAtom GlobalFindAtom  GlobalDeleteAtom
warcraftmgq  的方法有点离谱个人感觉
Findwindow 是简单并实用的方法  如果找到 直接SHOWWINDOW  多方便 

Answer 23

'好办
Set wlclass=Nothing  

Answer 24

大家的方法都很好，不过我有一个想法更简单的，不知道可行不，现在提出来。
由于套接字的端口都是独占的，
所以我建议程序启动后监听一个端口，
如果另外一个程序发现该端口有人开着，证明这个程序还在执行，
所以就建立一个Timer等待它的结束，同时，您还可以和开着的程序对话，例如，叫它退出来，该轮到自己（当前程序）工作了。

Answer 25

这贴老老了，估计LZ都失踪了~~呵呵~~感觉文件独占法~~ACTIVE部件法比较实用~~REG法用过，不太理想~~INI配置文件法，其实中REG法类似~

Answer 26

CreateMutex还有vb自带的一个apint的属性都可以做CreateMutex 不知道你跟过代码没有getlasterror值如果是废弃的话不妨碍判断的，因为如果有这个互斥体的话那么getlasterror就是ERROR_ALREADY_EXISTS你不需要对这个互斥体进行操作 废弃不会影响你使用

Answer 27

Private Sub Form_Load()
    If App.PrevInstance Then End
End Sub

Answer 28

用CreateMutex可以。自动释放。