VBAのレジストリ操作の拡張クラス

kccFuncArray_Partial.bas

Rem --------------------------------------------------
Rem FuncArray
Rem  配列／コレクション／辞書操作系
Rem  から切り出したもの
Rem
Rem --------------------------------------------------

Option Explicit

Rem 配列変数の次元数を返す
Rem 旧名 GetDim
Rem 旧名 GetDimension
Rem 別名 ArrRank By Ariawase
Public Function GetArrayDimension(ByRef ArrayData As Variant) As Long
 
    Dim retVal As Long
    
    On Error Resume Next
    Do While Err.Number = 0
        retVal = retVal + 1
        Dim tmp As Variant
        tmp = UBound(ArrayData, retVal)
    Loop
    On Error GoTo 0
    
    GetArrayDimension = retVal - 1
    
End Function

Rem 二次元配列をCSV等の文字列に変換する。
Public Function Join2(arr As Variant, _
                        Optional ByVal Delimiter1 As String = vbTab, _
                        Optional ByVal Delimiter2 As String = vbCrLf) As Variant
    Dim i As Long, j As Long
    Dim arr1() As Variant
    Dim arr2() As Variant
    
    If GetArrayDimension(arr) <> 2 Then Err.Raise 9999, "Join2", "Join2 : 入力変数Arrが二次元配列ではありません。"
    
    ReDim arr1(LBound(arr, 1) To UBound(arr, 1))
    ReDim arr2(LBound(arr, 2) To UBound(arr, 2))
    
    For i = LBound(arr, 1) To UBound(arr, 1)
        For j = LBound(arr, 2) To UBound(arr, 2)
            arr2(j) = arr(i, j)
        Next
        arr1(i) = Join(arr2, Delimiter1)
    Next
    Join2 = Join(arr1, Delimiter2)
End Function

RegApp.cls

'RegApp 1.レジストリアプリケーション管理
'HKEY_CURRENT_USER\Software\VB and VBA Program Settings\[AppName]
Option Explicit

Public AppName As String

Public Function section(Section_ As String) As RegSec
    Set section = New RegSec
    Set section.App = Me
    section.section = Section_
End Function

Public Function Delete()
    DeleteSetting Me.AppName
End Function

Property Get Name(AppName) As RegApp
    Me.AppName = AppName
    Set Name = Me
End Property

Property Get Self() As RegApp
    Set Self = Me
End Property

RegKey.cls

'RegSec 3.レジストリキー管理
Option Explicit

Public App As RegApp
Public Sec As RegSec
Public Key As String

'デフォルト値を指定して値を取得する
Public Property Get GetValue(default_value)
    GetValue = GetSetting(Me.App.AppName, Me.Sec.section, Me.Key, default_value)
    If GetValue = "Null" Then Value = Null
End Property

Public Property Get Value()
    Value = GetSetting(Me.App.AppName, Me.Sec.section, Me.Key, Empty)
    If Value = "Null" Then Value = Null
End Property

Public Property Let Value(ByVal saveValue)
    If IsNull(saveValue) Then saveValue = "Null"
    SaveSetting Me.App.AppName, Me.Sec.section, Me.Key, saveValue
End Property

Public Function Delete()
    DeleteSetting Me.App.AppName, Me.Sec.section, Me.Key
End Function

Property Get Self() As RegKey
    Set Self = Me
End Property

RegSec.cls

'RegSec 2.レジストリセクション管理
Option Explicit

Public App As RegApp
Public section As String

Public Function Key(Key_ As String) As RegKey
    Set Key = New RegKey
    Set Key.App = Me.App
    Set Key.Sec = Me
    Key.Key = Key_
End Function

Property Get AllSettings()
    AllSettings = GetAllSettings(Me.App.AppName, Me.section)
End Property

Property Get Keys() As Collection
    Set Keys = New Collection
    Dim KeyValue: KeyValue = GetAllSettings(Me.App.AppName, Me.section)
    Dim i As Long
    For i = LBound(KeyValue) To UBound(KeyValue)
        Dim k As RegKey
        Set k = New RegKey
        Set k.App = Me.App
        Set k.Sec = Me
        k.Key = KeyValue(i, 0)
        Keys.Add k
    Next
End Property

Public Function Delete()
    DeleteSetting Me.App.AppName, Me.section
End Function

Property Get Self() As RegSec
    Set Self = Me
End Property

Test_Reg.bas

Option Explicit

'
'                .Value = "あたい"
'            End With
'            With .Key("きいいいい")
'                .Value = "あったいいい"
'            End With
'            .Key("キキキキキ").Value = "値値値値値"
'        End With
'        With .Section("せくしょ～～んつ～～～")
'            .Key("キッキッキ").Value = "あいうえお"
'            .Key("キリキリ").Value = "ほへふひは"
'        End With
'    End With
'    RegApp("アプリ名").Section("せくしょん").Key("キー") = "あ"

Sub Test_SaveSetting()
    SaveSetting "アプリ名", "セクション", "キー1", "書き込む値1"
    SaveSetting "アプリ名", "セクション", "キー2", "書き込む値2"
    SaveSetting "アプリ名", "セクション", "キー3", "書き込む値3"
End Sub

Sub Test_GetAllSettings()
    Debug.Print Join2(GetAllSettings("アプリ名", "セクション"))
End Sub

Sub Test_GetSetting()
    Debug.Print GetSetting("アプリ名", "セクション", "キー1", "存在しないときの値")
    Debug.Print GetSetting("アプリ名", "セクション", "キー2", "存在しないときの値")
    Debug.Print GetSetting("アプリ名", "セクション", "キー3", "存在しないときの値")
End Sub

Sub Test_DeleteKey()
    DeleteSetting "アプリ名", "セクション", "キー1"
    DeleteSetting "アプリ名", "セクション", "キー2"
    DeleteSetting "アプリ名", "セクション", "キー3"
End Sub

Sub Test_DeleteSec()
    DeleteSetting "アプリ名", "セクション"
End Sub

Sub Test_DeleteApp()
    DeleteSetting "アプリ名"
End Sub

'----------------------------------------------------------------------------------------------------

Sub Test_With_SaveSetting()
    With RegApp("アプリ名")
        With .section("セクション")
            .Key("キー1").Value = "書き込む値1"
            .Key("キー2").Value = "書き込む値2"
            .Key("キー3").Value = "書き込む値3"
        End With
    End With
End Sub

Sub Test_With_GetAllsettings()
    With RegApp("アプリ名")
        With .section("セクション")
            '二次元配列出力
            Debug.Print Join2(.AllSettings)
        End With
    End With
End Sub

Sub Test_With_GetAllsettings_RegKey()
    With RegApp("アプリ名")
        With .section("セクション")
            'KeyValue出力
            Dim rk As RegKey
            For Each rk In .Keys
                Debug.Print rk.Key, rk.Value
            Next
        End With
    End With
End Sub

Sub Test_With_GetSetting()
    With RegApp("アプリ名")
        With .section("セクション")
            Debug.Print .Key("キー1").Value
            Debug.Print .Key("キー2").Value
            Debug.Print .Key("キー3").Value
        End With
    End With
End Sub

Sub Test_With_Delete()
    With RegApp("アプリ名")
        With .section("セクション")
            'キー削除
            .Key("キー1").Delete
            .Key("キー2").Delete
            .Key("キー3").Delete
            
            'セクション削除
            .Delete
        End With
        
        'アプリ名削除
        .Delete
    End With
End Sub

'----------------------------------------------------------------------------------------------------

'メソッドチェーン風に1行で書く
Sub Test_With_Single_SaveSetting()
    RegApp("アプリ名").section("セクション").Key("キー1").Value = "書き込む値1"
End Sub

'セクションを一時的に変数にして受け渡す
Sub Test_With_Main()
    '入れ子で呼び出し
    Call Test_With_Func(RegApp("アプリ名").section("セクション"))
    
    'Withからの自己参照（Self）で呼び出し
    With RegApp("アプリ名").section("セクション")
        Call Test_With_Func(.Self)
    End With
End Sub

'サブルーチン
Sub Test_With_Func(section As RegSec)
    section.Key("キー2").Value = 2
End Sub

Sub Test_PredeclaredId()
    Dim instRegApp As RegApp
    Set instRegApp = New RegApp
    Set instRegApp = instRegApp.Name("アプリ名")
    
    Set instRegApp = RegApp.Name("アプリ名")
    
    Set instRegApp = RegApp("アプリ名")
End Sub

Sub Test_With_Parent()
    With RegApp("アプリ名")
        With .section("セクション")
            'セクション　→　アプリ名
            Debug.Print .App.AppName
            'キー　→　アプリ名
            Debug.Print .Key("キー1").App.AppName
            'キー　→　セクション名
            Debug.Print .Key("キー1").Sec.section
        End With
    End With
End Sub

'RegKey.cls デフォルトプロシージャと、デフォルト値の指定について
Sub Test_With_DefaultValue()
    RegApp("アプリ名").section("セクション").Key("キー1").Value = "書き込む値1"
    RegApp("アプリ名").section("セクション").Key("キー1") = "書き込む値1"
    Debug.Print RegApp("アプリ名").section("セクション").Key("キー1").Value
    Debug.Print RegApp("アプリ名").section("セクション").Key("キー1")
    Debug.Print RegApp("アプリ名").section("セクション").Key("キー1").GetValue("キーが存在しません")
End Sub