mdlregister.bas

一个把自己的东西刻成光盘后自动查询和启动的原代码

Attribute VB_Name = "MdlRegister"
'####################################################################
'API函数
'系统注册表
'获取机器名
'####################################################################
'API函数声明
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Public Declare Function RegConnectRegistry Lib "advapi32.dll" Alias "RegConnectRegistryA" (ByVal lpMachineName As String, ByVal hKey As Long, phkResult As Long) As Long

Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long

Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long

Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long

Public Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, lpcbValue As Long) As Long

Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lp_Type As Long, lpData As Any, lpcbData As Long) As Long         ' Note that if you declare the lpData parameter as String, you must pass it By Value.

Public Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long

Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long         ' Note that if you declare the lpData parameter as String, you must pass it By Value.

Public Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Public Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
'API函数声明
'####################################################################

'####################################################################
'常量声明
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_DYN_DATA = &H80000006
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const HKEY_USERS = &H80000003
Public Const REG_SZ = 1                         ' Unicode nul terminated string
Public Const REG_DWORD = 4                      ' 32-bit number
Public Const ERROR_SUCCESS = 0&
'常量声明
'####################################################################

'####################################################################
' 得到注册表中某字符串值
Public Function RegGetString(ByVal key As Long, ByVal SubKey As String, ByVal ValueName As String, ByRef Result As String) As Boolean
On Error GoTo Err

    Dim hKey As Long, hSubKey As Long
    Dim lType As Long, lLen As Long
    Dim s(100) As Byte
    gErrDescription = ""
        
    lLen = 100
    RegGetString = False
    Result = ""
    
    If RegConnectRegistry(Empty, key, hKey) <> ERROR_SUCCESS Then
        gErrDescription = "无法连接注册表"
        GoTo Err
    End If
    
    If RegOpenKey(hKey, SubKey, hSubKey) <> ERROR_SUCCESS Then
        gErrDescription = "打开注册表失败"
        GoTo Err
    Else
        If RegQueryValueEx(hSubKey, ValueName, 0, lType, s(1), lLen) <> ERROR_SUCCESS Then
            gErrDescription = "得到字符串失败"
            GoTo Err
        Else
            Result = ByteArrayToString(s)
            RegGetString = True
        End If
        RegCloseKey hSubKey
    End If
    RegCloseKey hKey
    Exit Function
Err:
    MsgErr "查询注册表", "1005", gErrDescription, False, LXGLY, Err.Description
    RegGetString = False
End Function

'####################################################################
' 设置注册表中某字符串值
Public Function RegSetString(ByVal key As Long, ByVal SubKey As String, ByVal ValueName As String, ByVal Value As String) As Boolean
On Error GoTo Err

    Dim hKey As Long, hSubKey As Long
    Dim lType As Long, lLen As Long
    Dim s(100) As Byte
    gErrDescription = ""
    
    RegSetString = False
    
    lLen = StringToByteArray(s, Value)
    
    If RegConnectRegistry(Empty, key, hKey) <> ERROR_SUCCESS Then
       gErrDescription = "无法连接注册表"
       GoTo Err
    End If
    
    If RegOpenKey(hKey, SubKey, hSubKey) <> ERROR_SUCCESS Then
       Call CreateRegKey(SubKey)
       If RegOpenKey(hKey, SubKey, hSubKey) <> ERROR_SUCCESS Then
          gErrDescription = "打开注册表失败"
          GoTo Err
       End If
    End If
    
    If RegSetValueEx(hSubKey, ValueName, 0, REG_SZ, s(1), lLen) <> ERROR_SUCCESS Then
       gErrDescription = "设置字符串失败"
       GoTo Err
    Else
       RegSetString = True
    End If
        
    RegCloseKey hSubKey
    RegCloseKey hKey
    Exit Function
Err:
    MsgErr "设置注册表", "1002", gErrDescription, False, LXGLY, Err.Description
    RegSetString = False
End Function

'--------------------------------------------------------------------
' 得到注册表中某整数值
Public Function RegGetLong(ByVal key As Long, ByVal SubKey As String, ByVal ValueName As String, ByRef Result As Long) As Boolean
On Error GoTo Err

    Dim hKey As Long, hSubKey As Long
    Dim lType As Long, lLen As Long
    Dim lRet As Long
    gErrDescription = ""
    
    lLen = 100
    RegGetLong = False
    
    If RegConnectRegistry(Empty, key, hKey) <> ERROR_SUCCESS Then
       gErrDescription = "无法连接注册表"
       GoTo Err
    End If
    
    If RegOpenKey(hKey, SubKey, hSubKey) <> ERROR_SUCCESS Then
       gErrDescription = "打开注册表失败"
       GoTo Err
    Else
       If RegQueryValueEx(hSubKey, ValueName, 0, lType, lRet, 4) <> ERROR_SUCCESS Then
          gErrDescription = "得到整数值失败"
          GoTo Err
       Else
          Result = lRet
          RegGetLong = True
       End If
        
       RegCloseKey hSubKey
    End If
    RegCloseKey hKey
    Exit Function
Err:
    MsgErr "设置注册表", "1003", gErrDescription, False, LXGLY, Err.Description
    RegGetLong = False
End Function

'--------------------------------------------------------------------
' 设置注册表中某整数值
Public Function RegSetLong(ByVal key As Long, ByVal SubKey As String, ByVal ValueName As String, ByVal Value As Long) As Boolean
On Error GoTo Err
    Dim hKey As Long, hSubKey As Long
    gErrDescription = ""
    RegSetLong = False
    
    If RegConnectRegistry(Empty, key, hKey) <> ERROR_SUCCESS Then
       gErrDescription = "无法连接注册表"
       GoTo Err
    End If
    
    If RegOpenKey(hKey, SubKey, hSubKey) <> ERROR_SUCCESS Then
       Call CreateRegKey(SubKey)
       If RegOpenKey(hKey, SubKey, hSubKey) <> ERROR_SUCCESS Then
          gErrDescription = "打开注册表失败"
          GoTo Err
       End If
    End If
        
    If RegSetValueEx(hSubKey, ValueName, 0, REG_DWORD, Value, 4) <> ERROR_SUCCESS Then
       gErrDescription = "设置整数值失败"
       GoTo Err
    Else
        RegSetLong = True
    End If
    
    RegCloseKey hSubKey
    RegCloseKey hKey
Exit Function
Err:
    MsgErr "设置注册表", "1004", gErrDescription, False, LXGLY, Err.Description
    RegSetLong = False
End Function

'####################################################################
' 创建注册表子键
Public Sub CreateRegKey(SubKey As String)
Dim Reg_Result As Long
Reg_Result = RegCreateKey(HKEY_LOCAL_MACHINE, SubKey, 0)
If Reg_Result <> 0 Then
   Exit Sub
End If
End Sub

'--------------------------------------------------------------------
' 得到计算机名
Public Function GetComPuter() As String
On Error GoTo Err
Dim lngResult As Long
Dim lpBuffer$
Dim StrGetWin As String
lpBuffer = Space$(2048)
lngResult = GetComputerName(lpBuffer, Len(lpBuffer))
StrGetWin = Left(Trim(lpBuffer), Len(Trim(lpBuffer)) - lngResult)
GetComPuter = StrGetWin
Exit Function
Err:
    MsgErr "系统初始化", "1005", "获取机器名出错", True, LXGLY, Err.Description
End Function

'--------------------------------------------------------------------
' 将 BYTE 数组转化为字符串，支持中文
Public Function ByteArrayToString(ByteArray() As Byte) As String
    Dim i As Integer
    Dim L As Long
    i = 1
    While ByteArray(i) <> 0
        If ByteArray(i) > 127 Then
            L = ByteArray(i)
            L = L * 256 + ByteArray(i + 1)
            ByteArrayToString = ByteArrayToString + Chr(L)
            i = i + 2
        Else
            ByteArrayToString = ByteArrayToString + Chr(ByteArray(i))
            i = i + 1
        End If
    Wend
End Function

'--------------------------------------------------------------------
' 将字符串转化为 BYTE 数组，支持中文，返回 BYTE 的长度（含结束符）
Public Function StringToByteArray(ByteArray() As Byte, ByVal s As String) As Long
    Dim i As Integer, j As Integer
    Dim L As Long

    j = 1
    For i = 1 To Len(s)
        L = Asc(Mid(s, i, 1))
        If L < 0 Then L = L + 65536
        If L > 255 Then
            ByteArray(j) = Int(L / 256)
            ByteArray(j + 1) = L Mod 256
            j = j + 2
        Else
            ByteArray(j) = L
            j = j + 1
        End If
    Next
    ByteArray(j) = 0
    StringToByteArray = j
End Function

'###################################################################################
'获取IE路径
'###################################################################################
Public Function GetIEPath(r_IE_Path As String) As Boolean
On Error GoTo Err
Dim i
gErrDescription = ""

r_IE_Path = ""

If RegGetString(HKEY_LOCAL_MACHINE, "Software\Microsoft\IE4\Setup", "Path", r_IE_Path) = False Then GoTo Err
r_IE_Path = Replace(LCase(r_IE_Path), "%programfiles%", "c:\program files")

If Dir(r_IE_Path + "\Iexplore.exe") = "" Then GoTo Err
r_IE_Path = r_IE_Path + "\Iexplore.exe"
GetIEPath = True
Exit Function
Err:
   r_IE_Path = ""
   GetIEPath = False
End Function

' "Software\方正奥德计算机系统有限公司\SystemManage\"
Public Function GetRegVal(SubKey As String, RtnString As String) As Boolean
On Error GoTo Err
Dim Reg_Size As Long
Dim Reg_buffer As String
Dim Reg_Result As Long
Reg_buffer = String$(1024, 0)
Reg_Size = 1024
Reg_Result = RegQueryValue(HKEY_LOCAL_MACHINE, SubKey, Reg_buffer, Reg_Size)
If Reg_Result <> 0 And Reg_Result <> 13 Then GoTo Err
If InStr(1, Reg_buffer, ";") <= 1 Then
   RtnString = Left(Trim(Reg_buffer), Reg_Size - 1)
Else
   RtnString = Left(Trim(Reg_buffer), InStr(1, Reg_buffer, ";") - 1)
End If
GetRegVal = True
Exit Function
Err:
   GetRegVal = False
End Function

Public Function GetSysPath() As String
On Error GoTo ErrHandle
Dim lngResult As Long
Dim lpBuffer$
Dim StrGetWin As String
lpBuffer = Space$(2048)
lngResult = GetWindowsDirectory(lpBuffer, Len(lpBuffer))
StrGetWin = Left(Trim(lpBuffer), Len(Trim(lpBuffer)) - 1)
GetSysPath = StrGetWin
Exit Function
ErrHandle:
   MsgBox "系统错误" + Chr(10) + "错误描述：" + Err.Description
End Function