如何控制程式运行的唯一性!

[wensnow]

我要做到一个程序在一台pda中只能有一个处于击活状态,也就是说已经有一个程序在运行的话,不能再次启动,如何控制?还有如何在启动时作一个动态画面,让人感觉程序正在启动,而不是死机?

[道素]

1.保证唯一很好实现
让你的应用程序启动项目设为 sub main
然后再sub main加上
If App.PrevInstance Then End即可
2。动画的也好实现
做一个启动界面窗体用timer控件显示动画
然后这个窗体显示时开始用load加载 主窗体
当主窗体加载完成，在主窗体显示完成后调用unload 启动界面窗体即可

[wensnow]

app没有previnstance这个属性啊

[dofly]

App.PrevInstance 有這個屬性呀

[wea1978]

Private Sub Form_Load()
If App.PrevInstance Then '检视前一版本
MsgBox "此程式已经在执行中！", 48, "警告！"
End
End If
End Sub

[rainstormmaster]

在evb中，app确实没有没有previnstance这个属性

可以试试用互斥体解决

[online]

evb中,不清楚
关注

[wensnow]

rainstormmaster:互斥体解决，能不能详细点，我不太明白，谢谢！

[rainstormmaster]

'This code must be pasted into a module
'Set the project's startup object to 'Sub Main' (-> Project -> Project Properties -> General Tab -> Startup Object)
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()
' -> code by Raist Lin
Dim sa As SECURITY_ATTRIBUTES
sa.bInheritHandle = 1
sa.lpSecurityDescriptor = 0
sa.nLength = Len(sa)
'Try to create a new Mutex
Debug.Print CreateMutex(sa, 1, App.Title)
Debug.Print Err.LastDllError
'Check if the function was succesfull
If (Err.LastDllError = ERROR_ALREADY_EXISTS) Then
'More than one instance detected
MsgBox "More than one instance"
Else
'No other instance detected...
'Your program-load code here
End If
End Sub

[wensnow]

To:rainstormmaster(rainstormmaster)
错误提示：cann't use a reserved word as a variable,const,sub,function,or a declare names
可是我不知道哪个名字又冲突

[rainstormmaster]

'设置工程 -工程属性的通用选项卡的启动对象为Sub Main
'模块部分
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()
' -> code by Raist Lin
Dim sa As SECURITY_ATTRIBUTES
sa.bInheritHandle = 1
sa.lpSecurityDescriptor = 0
sa.nLength = Len(sa)
'Try to create a new Mutex
Debug.Print CreateMutex(sa, 1, App.Title)
Debug.Print Err.LastDllError
'Check if the function was succesfull
If (Err.LastDllError = ERROR_ALREADY_EXISTS) Then
'More than one instance detected
MsgBox "More than one instance"
End
Else
Dim Newfrm As New Form1
Newfrm.Show
End If
End Sub

记得编译为exe文件后再执行

没有出现你说的问题呀

[Gelim]

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()
' -> code by Raist Lin
Dim sa As SECURITY_ATTRIBUTES
sa.bInheritHandle = 1
sa.lpSecurityDescriptor = 0
sa.nLength = Len(sa)
'Try to create a new Mutex
Debug.Print CreateMutex(sa, 1, App.Title)
Debug.Print Err.LastDllError
'Check if the function was succesfull
If (Err.LastDllError = ERROR_ALREADY_EXISTS) Then
'More than one instance detected
MsgBox "More than one instance"
End
Else
Dim Newfrm As New Form1
Newfrm.Show
End If
End Sub

没办法，我也是这个答案！

[yaowei81237]

Option Explicit
' API函数声明
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
' 字符常数说明
Const REG_SZ = 1
Const HKEY_CURRENT_USER = &H80000001
Dim hKey
Private Sub Form_Load()
On Error GoTo A1
Dim FileName As String
' 读入保存在注册表中的数据
FileName = GetString(HKEY_CURRENT_USER, "RegData\RunFile", "AS1")
' 如果作为程序运行标志的数据存在则显示提示信息，单击确认按钮后停止本程序的运行
If FileName = "X1" Then
MsgBox " 本程序正在运行 ！ "
Unload Me
End If
Exit Sub
' 如果注册表中没有需要的数据项则创建这个数据项并将程序运行标志写入其中
A1:
RegCreateKey HKEY_CURRENT_USER, "RegData\RunFile", hKey
FileName = "X1"
RegSetValueEx hKey, "AS1", 0&, REG_SZ, FileName, 2 * Len(FileName)
End Sub
' 窗体卸载，删除 AS1
Private Sub Form_Unload(Cancel As Integer)
RegDeleteValue hKey, "AS1"
End Sub
' 单击命令按钮，删除 AS1
Private Sub Command1_Click()
RegDeleteValue hKey, "AS1"
Unload Me
End
End Sub
' 读取注册表指定数据的过程
Function GetString(hKey As Long, strPath As String, strValue As String)
Dim Ret
RegOpenKey hKey, strPath, Ret
GetString = RegQueryStringValue(Ret, strValue)
RegCloseKey Ret
Exit Function
End Function
Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String) As String
Dim lValueType As Long, strBuf As String, lDataBufSize As Long
RegQueryValueEx hKey, strValueName, 0, lValueType, ByVal 0, lDataBufSize
strBuf = String(lDataBufSize, Chr$(0))
RegQueryValueEx hKey, strValueName, 0, 0, ByVal strBuf, lDataBufSize
RegQueryStringValue = Left$(strBuf, InStr(1, strBuf, Chr$(0)) - 1)
Exit Function
End Function