Option Explicit

'ルートキー
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003

Public Const STANDARD_RIGHTS_ALL = &H1F0000
Public Const SYNCHRONIZE = &H100000

'動作方法を指定する定数
Public Const KEY_CREATE_LINK = &H20         'キーオブジェクトとのリンク作成
Public Const KEY_ENUMERATE_SUB_KEYS = &H8   'サブキー列挙
Public Const KEY_QUERY_VALUE = &H1          'レジストリ値を設定
Public Const KEY_SET_VALUE = &H2            'レジストリ値を取得
Public Const KEY_CREATE_SUB_KEY = &H4       'サブキー作成
Public Const KEY_NOTIFY = &H10              'レジストリの内容変更通知を要求
Public Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))

'Registry Data Types
Public Const REG_BINARY = 3                 'バイナリデータ
Public Const REG_DWORD = 4                  '32ビット数値
Public Const REG_DWORD_LITTLE_ENDIAN = 4    '= RGE_DWORD
Public Const REG_DWORD_BIG_ENDIAN = 5
Public Const REG_EXPAND_SZ = 2
Public Const REG_LINK = 6                   '別のサブキーへのシンボリックリンク
Public Const REG_MULTI_SZ = 7               'Chr(0)で区切られた文字列(最後尾は Chr(0)が二つ)
Public Const REG_NONE = 0                   '未定義のタイプ
Public Const REG_RESOURCE_LIST = 8
Public Const REG_SZ = 1                     '文字列

'Registry Create Type Values
Public Const REG_OPTION_NON_VOLATILE = 0

Type SECURITY_ATTRIBUTES
  nLength As Long                           '構造体のバイト数
  lpSecurityDescriptor As Long              'セキュリティデスクリプタ（Windows98 では無効）
  bInheritHandle As Long                    '1 のとき、属性を継承する
End Type

'レジストリキーハンドルを開放
Declare Function RegCloseKey Lib "ADVAPI32" (ByVal hKey As Long) As Long

'指定のキーを作成。存在する場合はキーをオープン。
Declare Function RegCreateKeyEx Lib "ADVAPI32" Alias "RegCreateKeyExA" _
    (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, _
    ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, _
    lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long

'指定のキーを削除
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
    (ByVal hKey As Long, ByVal lpSubKey As String) As Long

'指定のキーをオープン
Declare Function RegOpenKeyEx Lib "ADVAPI32" Alias "RegOpenKeyExA" _
    (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
    ByVal samDesired As Long, phkResult As Long) As Long

'レジストリキーの値を設定
'（文字列）
Declare Function RegSetValueExStr Lib "ADVAPI32" Alias "RegSetValueExA" _
    (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
    ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
'（数値）
Declare Function RegSetValueExLong Lib "ADVAPI32" Alias "RegSetValueExA" _
    (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
    ByVal dwType As Long, ByVal lpData As Long, ByVal cbData As Long) As Long

'指定のキーの値名と値を削除
Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Const ERROR_SUCCESS = 0&

'エラーメッセージ取得
Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Const FORMAT_MESSAGE_FROM_STRING = &H400
Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF


Sub LsRegSetVal(lngRootKey As Long, strSubKey As String, strValueName As String, varValue As Variant, bolNumFlg As Boolean)
    Dim er As Boolean
    
    If Ls_RegCreateKeyEx(lngRootKey, strSubKey) Then
        If Ls_RegSetValueEx(lngRootKey, strSubKey, strValueName, varValue, bolNumFlg) Then
        Else
            er = True
        End If
    Else
        er = True
    End If
    If er = False Then
        MsgBox "　＼(^o^)／  ヤッター　＼(^o^)／", vbInformation
    End If
End Sub

Private Function Ls_RegCreateKeyEx(ByVal RootKey As Long, ByVal SubKey As String) As Boolean
    'レジストリのサブキーが存在しなければサブキーを作成
    '   RootKey    オープンするルートキー
    '   SubKey     サブキー
    '   結果       成功=true
    Dim rc As Long
    Dim lpSecurityAttributes As SECURITY_ATTRIBUTES
    Dim phkResult As Long, lpdwDisposition As Long
    
    rc = RegCreateKeyEx(RootKey, SubKey, 0, vbNullString, REG_OPTION_NON_VOLATILE, _
           KEY_CREATE_SUB_KEY, lpSecurityAttributes, phkResult, lpdwDisposition)
    
    Call RegCloseKey(phkResult)

    If rc <> ERROR_SUCCESS Then Exit Function
    Ls_RegCreateKeyEx = True
End Function

Private Function Ls_RegSetValueEx(ByVal RootKey As Long, ByVal SubKey As String, ByVal lpValName As String, ByVal strData As String, NumFlg As Boolean) As Boolean
    'レジストリに値を設定
    '   RootKey    オープンするルートキー
    '   SubKey     サブキー
    '   lpValName  値名
    '   strData    値
    '   NumFlg     数値データ（32ビット値）の場合True
    '   結果       成功=true
    '＊strData(値)をセットしなおせば書き換えられます。
    Dim rc As Long, phkResult As Long
    Dim Reserved As Long
    Dim cbData As Long
    Dim lpData As Long
    Dim lngData As Long
    
    'キーをオープンしてハンドル取得
    rc = RegOpenKeyEx(RootKey, SubKey, 0, KEY_SET_VALUE, phkResult)
    If rc <> ERROR_SUCCESS Then
        MsgBox "ハンドルを取得できません。" & vbCr & Ls_FormatMessage(rc), vbCritical
        Exit Function
    End If
    If NumFlg Then
        '数値の場合は、変数のポインタを取得
        'VarPtrは隠し関数で、ヘルプはありません。(VB4ではサポートされていません。VB5以上だと思います)
        lngData = Val(strData)
        lpData = VarPtr(lngData)
        cbData = 4 '4Byteデータ
        rc = RegSetValueExLong(phkResult, lpValName, Reserved, REG_DWORD, lpData, cbData)
    Else
        '文字列の場合は、文字列のバイト数 + 1
        cbData = LenB(StrConv(strData, vbFromUnicode)) + 1
        rc = RegSetValueExStr(phkResult, lpValName, Reserved, REG_SZ, strData, cbData)
    End If
    'ハンドルを開放
    Call RegCloseKey(phkResult)
    If rc <> ERROR_SUCCESS Then
        MsgBox "値名と値を設定できません。" & Ls_FormatMessage(rc), vbCritical
        Exit Function
    End If
    Ls_RegSetValueEx = True
End Function

Function Ls_RegDeleteKey(RootKey As Long, SubKey As String) As Boolean
    Dim rc As Long
    
    rc = RegDeleteKey(RootKey, SubKey)
    If rc = ERROR_SUCCESS Then
        Ls_RegDeleteKey = True
        MsgBox "　＼(^o^)／  ヤッター　＼(^o^)／", vbInformation
    Else
        MsgBox "値名と値を削除できません。" & vbCr & Ls_FormatMessage(rc), vbCritical
    End If
End Function

Function Ls_RegDelValue(RootKey As Long, SubKey As String, ValueName As String) As Boolean
    Dim rc As Long, phkResult As Long
    
    'レジストリへのアクセス用ハンドルを得る
    '(2002/08/17)動作方法を指定する定数が違っていました。Win XPでは KEY_ENUMERATE_SUB_KEYS の場合エラーになります。
    '    KEY_ENUMERATE_SUB_KEYS --> KEY_SET_VALUE
    rc = RegOpenKeyEx(RootKey, SubKey, 0, KEY_SET_VALUE, phkResult)
    
    If rc = ERROR_SUCCESS Then
        ValueName = ValueName
        rc = RegDeleteValue(phkResult, ValueName)
        If rc = ERROR_SUCCESS Then
            Ls_RegDelValue = True
            MsgBox "　＼(^o^)／  ヤッター　＼(^o^)／", vbInformation
        Else
            MsgBox "値名と値を削除できません。" & vbCr & Ls_FormatMessage(rc), vbCritical
        End If
        Call RegCloseKey(phkResult)
    Else
        MsgBox "ハンドルを取得できません。" & vbCr & Ls_FormatMessage(rc), vbCritical
    End If
End Function

Function Ls_FormatMessage(ByVal DllErr As Long) As String
    'Windowsのエラーコードに対応したエラーメッセージを返します。
    Dim strBuf As String * 1024
    Dim rc As Long
    Dim dwFlags As Long

    dwFlags = FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS
    rc = FormatMessage(dwFlags, ByVal vbNullString, DllErr, &H400, strBuf, Len(strBuf), 0)
    Ls_FormatMessage = Left$(strBuf, InStr(strBuf, vbNullChar) - 1)
End Function