040102

タイトル	レジストリキーの値を保存する
対象言語	VB4.0, Access95以降
動作確認ＯＳ	Windows95,98,NT4.0
使用関数	RegSetValueEx RegOpenKeyEx RegCloseKey
改築日	1999/06/22(1998/06/18)
Source Download

レジストリに文字列、数値、バイナリ値
を保存します。

HKEY_CURRENT_USERキーの
サブキー　Software\VB and VBA Program Settings\TEST
にあるキー値、StringTest,DWordTest,BinaryTest
に各値を保存します。

注意！！
レジストリを操作するのは大変危険です。へたにいじるとWindowsが起動
しなくなるかもしれません。ご注意下さい！！

1. フォームを作成しコマンドボタン（Command1）、を貼り付けてください。

Option Explicit

Private Sub Command1_Click()

　　Dim RootKey As Long
　　Dim KeyPth As String
　　Dim KeyNm As String
　　Dim strdata As String
　　Dim lngdata As Long
　　Dim bytdata(10) As Byte
　　Dim i As Integer

　　RootKey = HKEY_CURRENT_USER
　　KeyPth = "Software\VB and VBA Program Settings\TEST"

'文字列を保存
　　If Y_SetRegValue(RootKey, KeyPth, "StringTest", "文字列データですぅ") = False Then
　　　　Call MsgBox("レジストリの保存に失敗したよぉ (ToT)")
　　Else
　　　　Call MsgBox("文字列の保存に成功しました (^_^)v")
　　End If

'DWORD値を保存
　　If Y_SetRegValue(RootKey, KeyPth, "DWordTest", 12345678) = False Then
　　　　Call MsgBox("レジストリの保存に失敗したよぉ (ToT)")
　　Else
　　　　Call MsgBox("DWORD値の保存に成功しました (^_^)v")
　　End If

'バイナリ値を保存
　　KeyNm = "ByteTest"
　　For i = 0 To 10
　　　　bytdata(i) = &H61 + i
　　Next
　　If Y_SetRegValue(RootKey, KeyPth, "BinaryTest", bytdata) = False Then
　　　　Call MsgBox("レジストリの保存に失敗したよぉ (ToT)")
　　Else
　　　　Call MsgBox("バイナリ値の保存に成功しました (^_^)v")
　　End If

End Sub

2.モジュールウインドウを作成し、下のソースを入力してください。

Option Explicit

'サブキーを作成する
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 RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long

'レジストリキーに値を保存する
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

Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006

Public Const REG_OPTION_NON_VOLATILE = 0
Public Const KEY_ALL_ACCESS = &HF003F
Public Const ERROR_SUCCESS = 0

Public Const REG_SZ = 1 '文字列
Public Const REG_BINARY = 3 'バイナリ
Public Const REG_DWORD = 4 'DWORD値

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

Public Function Y_SetRegValue(hKey As Long, SubKey As String, KeyName As String, DataValue As Variant) As Boolean
'***********************************************************
'機能 : レジストリに値を保存する
'引数 :　 hKey　　　= 保存先サブキーの親キー
'　　　　　SubKey　　= 保存先サブキーのパス
'　　　　　KeyName 　= 保存先の値の名前
'　　　　　DataValue = 保存する値
'戻り値:　 True = 保存成功
'　　　　　False = 保存失敗
'備考　: 保存する値が DoubleやSingle型なら一旦文字型に
'　　　　　変換して保存します。
'***********************************************************

　　Dim longret As Long
　　Dim phKey As Long
　　Dim disposition As Long
　　Dim attr As SECURITY_ATTRIBUTES
　　Dim LongBuf As Long
　　Dim StrBuf As String
　　Dim ByteBuf() As Byte
　　Dim flg As Boolean

　　flg = False

'サブキーを作成します。
　　If RegCreateKeyEx(hKey, SubKey, 0&, "", REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, attr, phKey, disposition) = ERROR_SUCCESS Then

'データのタイプ別にレジストリに書き込みます。
　　　　Select Case TypeName(DataValue)

　　　　　　Case "Integer", "Long", "Boolean"
　　　　　　　　LongBuf = DataValue
　　　　　　　　longret = RegSetValueEx(phKey, KeyName, 0, REG_DWORD, LongBuf, 4)

　　　　　　Case "Byte()"
　　　　　　　　ReDim ByteBuf(UBound(DataValue))
　　　　　　　　ByteBuf = DataValue
　　　　　　　　longret = RegSetValueEx(phKey, KeyName, 0, REG_BINARY, ByteBuf(0), UBound(ByteBuf) + 1)

　　　　　　Case Else 'その他の型なら、文字列型で保存
　　　　　　　　StrBuf = CStr(DataValue)
　　　　　　　　longret = RegSetValueEx(phKey, KeyName, 0, REG_SZ, ByVal StrBuf, LenB(StrBuf) + 1)
　　　　End Select

　　　　If longret = ERROR_SUCCESS Then
　　　　　　flg = True
　　　　End If

'レジストリキーを閉じます。
　　　　If RegCloseKey(phKey) <> ERROR_SUCCESS Then
　　　　　　flg = False
　　　　End If
　　End If

　　Y_SetRegValue = flg

End Function