防止程序重复运行.frm

Windows API函数,希望大伙有用哦

VERSION 5.00
Begin VB.Form Form1 
   BackColor       =   &H80000018&
   Caption         =   "Form1"
   ClientHeight    =   1935
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   Icon            =   "防止程序重复运行.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   1935
   ScaleWidth      =   4680
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command1 
      Caption         =   "退   出"
      Height          =   345
      Left            =   3060
      TabIndex        =   0
      Top             =   1350
      Width           =   1305
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "欢迎使用本程序 ！"
      BeginProperty Font 
         Name            =   "华文行楷"
         Size            =   24
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FF0000&
      Height          =   495
      Left            =   480
      TabIndex        =   1
      Top             =   510
      Width           =   3960
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
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 As Long
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 As Long
    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