禁止程序重复运行

阿杰

创建一个信号灯就可以了

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 Type
Dim Semaphore As String, Sema As Long, Security As SECURITY_ATTRIBUTES
Dim PrevSemaphore As Long, Turn As Long
Private Sub Form_Load()
   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 "管理系统已经运行！", vbOKOnly + vbCritical, "提示"
      End
   End If
End Sub

阿杰

vb有句经典的话，if app.previnstance=true then end 这样可以防止重复运行，但是有个缺点就是
如果别的目录有个相同的程序这句话就会没用了。
我这个代码是创建事件同步对象达到防止重复运行的
code：
Option Explicit
Private Declare Function OpenEvent Lib "kernel32" Alias "OpenEventA" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal lpName As String) As Long
Private Declare Function CreateEvent Lib "kernel32" Alias "CreateEventA" (lpEventAttributes As SECURITY_ATTRIBUTES, ByVal bManualReset As Long, ByVal bInitialState As Long, ByVal lpName As String) As Long

Private Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type

Private Sub Form_Load()
Dim Attrib As SECURITY_ATTRIBUTES
    If OpenEvent(2031619, False, "myappname") <> 0 Then End ' "myappname"可以是任何文本，但是最好要长一点以保证和系统中已有其他事件对象的名称不相冲突。
    Call CreateEvent(Attrib, False, False, "myappname")
End Sub
好不好使大家自己试试吧……

阿杰

使用互斥也可以：


转帖：

只容许运行“一次”程序实例（利用互斥体）

选择启动对象为sub main()

module:

Public Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" _ (lpMutexAttributes As SECURITY_ATTRIBUTES, ByVal bInitialOwner As Long, ByVal lpName _
As String) As Long
Public Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type
Public Const ERROR_ALREADY_EXISTS = 183&
Private Sub Main()
    Dim sa As SECURITY_ATTRIBUTES
    sa.bInheritHandle = 1
    sa.lpSecurityDescriptor = 0
    sa.nLength = Len(sa)
    Debug.Print CreateMutex(sa, 1, App.Title)  '这一行可千万不能删除啊
    Debug.Print Err.LastDllError
    If (Err.LastDllError = ERROR_ALREADY_EXISTS) Then
        MsgBox "More than one instance"
    Else
    Form1.Show
    End If
End Sub

只能启动一次，再启动都报错 :-(

阿杰

无论程序在何地,只能运行一个应用程序示例
模块中：

'程序实现功能：自动激活前一个实例


Public Declare Function ReleaseMutex Lib "kernel32" (ByVal hMutex As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" (lpMutexAttributes As SECURITY_ATTRIBUTES, ByVal bInitialOwner As Long, ByVal lpName As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function FlashWindowEx Lib "user32.dll" (ByRef pfwi As FLASHWINFO) As Long


Private Const FLASHW_STOP = 0 '停止闪烁，系统恢复窗体到她原始的状态.
Private Const FLASHW_CAPTION = &H1 '闪烁窗体的标题
Private Const FLASHW_TRAY = &H2 '闪烁任务栏
Private Const FLASHW_ALL = (FLASHW_CAPTION Or FLASHW_TRAY) '标题栏＆窗体标题一起闪烁
Private Const FLASHW_TIMER = &H4 '连续的闪烁，直到设置了FLASHW_STOP标志

Private Const ERROR_ALREADY_EXISTS = 183&
Private Const SW_RESTORE = 9
Private Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type

Private Type FLASHWINFO
    cbSize As Long   '结构大小
    hwnd As Long
    dwFlags As Long
    uCount As Long   '闪烁的次数
    dwTimeout As Long  '闪烁的时间
End Type


Public Mutex As Long

Private Sub Main()
    Dim sa As SECURITY_ATTRIBUTES
    Dim hwnd As Long
    Dim FlashInfo As FLASHWINFO

    sa.bInheritHandle = 1
    sa.lpSecurityDescriptor = 0
    sa.nLength = Len(sa)
    Mutex = CreateMutex(sa, 1, App.Title) '试着创建一个新的互斥体
    If (Err.LastDllError = ERROR_ALREADY_EXISTS) Then        '互斥体已经存在,表明已打开一个实例
        hwnd = GetSetting("AppName", "Section", "Key", 0)    '找到我们保存的前一个实例的句柄，这样避免了使用FindWindow函数等对变标题程序的无奈
        ShowWindow hwnd, SW_RESTORE         '显示窗口
        SetForegroundWindow hwnd            '激活窗体
        
        FlashInfo.cbSize = Len(FlashInfo)
        FlashInfo.dwFlags = FLASHW_ALL Or FLASHW_TIMER
        FlashInfo.dwTimeout = 0       '以毫秒为单位指定窗体闪烁的速率，如果为0，则使用默认的光标闪烁速率.
        FlashInfo.hwnd = hwnd
        FlashInfo.uCount = 3        '指定闪烁的次数.
        FlashWindowEx FlashInfo     '闪烁效果
    Else
        FrmMain.Show                        '显示主窗体
    End If
End Sub

窗体中：

Private Sub Form_Load()
    SaveSetting "AppName", "Section", "Key", Me.hwnd   '临时保存我们的窗体句柄
End Sub

Private Sub Form_Unload(Cancel As Integer)
    ReleaseMutex Mutex                                  '释放互斥体，没有这两句，你在VB环境下这可以运行一次，再次按F5的时候你会发现自动退出
    CloseHandle Mutex
    DeleteSetting "AppName", "Section", "Key"           '清除我们在注册表种存放的数据，绿色效果。
End Sub

Tesla.Angela

sub form_load()
    if dir("c:\xxx.tmp",vbDirectory)<>"" then
        msgbox "程序已经运行"
        end
    else
        mkdir "c:\xxx.tmp"
    end if

sub form_unload()
    rmdir "c:\xxx.tmp"
end sub