ヘッダー行から変数作成 ～まとめ～

前回は、よく使用するCreate Objectを宣言・初期化する文字列を
簡単に作成することに挑戦した。
infoment.hatenablog.com

今日は、今までのまとめを掲載。

ユーザーフォーム

今までに作成した内容を業務などに使用してみた。結果はおおむね順調だったが、幾つか微修正を施した個所もある。

そこで今回は、今までのコードを纏めて掲載する。
今後何か改修する場合は、こちらを更新するとしよう。

◆ソースコード（クリックで展開）◆

Option Explicit

' バインディング書式。
Enum BindingType
    btEarlyBinding
    btLateBinding
    [_eLast]
End Enum

' CreateObject用辞書に用いるID。
Enum CreateObjectID
    idFileSystemObject
    idDictionary
    idRegExp
    [_eLast]
End Enum

' CreateObjectセット用項目名。
Enum CreateObjectItemName
    ' 参照設定名などのコメント。
    incomment
    ' 宣言ステートメント。
    inDeclarate
    ' 初期化またはCreateObject
    inInitialize
    [_eLast]
End Enum

Private Sub ObjectNameComboBox_Change()
    VariableNameTextBox = CreateObjectVariableName(ObjectID)
    CopyButton.Enabled = True
End Sub

Private Sub UserForm_Initialize()

    ' 選択範囲が１列の場合、このツールを使用する条件不成立とする。
    If UBound(HeaderList) = -1 Then Exit Sub
    
    ' 選択範囲のヘッダー部をリスト表示。
    ItemListBox.List = HeaderList
    
    ' 宣言変更用コンボボックス。
    DeclarationComboBox.List = DeclarationArray

    ' 変数の型変更用コンボボックス。
    TypeComboBox.List = TypeArray

    ' CreateObject選択用コンボボックス。
    ObjectNameComboBox.List = ObjectNameArray
    
    ' CreateObjectの書式選択初期値。
    OB_EarlyBinding.Value = True
    
    ' 文字修正ボタンを無効化。
    ' ※現時点でListBox未選択のため。
    RenameButton.Enabled = False
    
    ' クリップボードへのコピーボタン無効化
    ' ※リストボックスが４列の場合に特化しているため。
    ' 　（ユーザーフォーム起動時は複数行１列）。
    CopyButton.Enabled = False
    
    ' Enum作成ボタンを無効化。
    ' ※現時点でEnum名称など未記入のため。
    EnumButton.Enabled = False
    
End Sub

' 変数宣言ボタン。
Private Sub DeclarationButton_Click()
    Dim arr As Variant
        Select Case ItemListBox.ColumnCount
            Case 1
                arr = ItemListBox.List
                ItemListBox.ColumnCount = 4
                ItemListBox.ColumnWidths = ColumnWidth
                ItemListBox.MultiSelect = fmMultiSelectMulti
            Case Else
                Exit Sub
        End Select
        
        DeclarationComboBox.Value = vbNullString
        TypeComboBox.Value = vbNullString
        
    ReDim Preserve arr(ItemListBox.ListCount - 1, 3)
    Dim i As Long
        For i = 0 To UBound(arr)
            arr(i, 1) = arr(i, 0)
            arr(i, 0) = "Dim"
            arr(i, 2) = "As"
            arr(i, 3) = "String"
        Next
        
        ItemListBox.List = arr
        
        CopyButton.Enabled = True
End Sub

' 全選択ボタン。
Private Sub AllSelectButton_Click()
    Dim i As Long
        For i = 0 To ItemListBox.ListCount - 1
            ItemListBox.Selected(i) = True
        Next
End Sub

' 全解除ボタン。
Private Sub AllUnselectButton_Click()
    ' 複数選択の可否を切り替えると、選択が解除されることを利用。
    ItemListBox.MultiSelect = fmMultiSelectSingle
    ItemListBox.MultiSelect = fmMultiSelectMulti
    
    ' 名前変更用テキストボックスをクリア。
    NewNameTextBox.Value = vbNullString
End Sub

' 宣言子を選択したときの処理。
Private Sub DeclarationComboBox_Change()
    ' 空欄なら処理不要。
        If DeclarationComboBox = vbNullString Then Exit Sub
    ' リストボックスが１列なら、つまり変数宣言ボタンを押す前なら処理不要。
        If ItemListBox.ColumnCount = 1 Then Exit Sub

    Dim i As Long
        For i = 0 To ItemListBox.ListCount - 1
            If ItemListBox.Selected(i) Then
                ItemListBox.List(i, 0) = DeclarationComboBox.Value
            End If
        Next
End Sub

' 変数の型を選択したときの処理。
Private Sub TypeComboBox_Change()
    ' 空欄なら処理不要。
        If TypeComboBox = vbNullString Then Exit Sub
    ' リストボックスが１列なら、つまり変数宣言ボタンを押す前なら処理不要。
        If ItemListBox.ColumnCount = 1 Then Exit Sub

    Dim i As Long
        For i = 0 To ItemListBox.ListCount - 1
            If ItemListBox.Selected(i) Then
                ItemListBox.List(i, 3) = TypeComboBox.Value
            End If
        Next
End Sub

' Enum作成ボタンクリック。
Private Sub EnumButton_Click()
    
    ' Enum ～ End Enumまでの全行を格納する配列。
    Dim arr() As Variant
        Select Case ItemListBox.ColumnCount
            Case 1
                ItemListBox.ColumnCount = 4
                ItemListBox.ColumnWidths = ColumnWidth
                EnumButton.Enabled = False
            Case Else
                Exit Sub
        End Select
    
    ' (1)Enum (2) [_eLast] (3) End Enum を追加するため、
    ' Redim時の要素数を＋３としている。
    ' (2)は、Enum内の要素数を得るためなどに使用する。
    ' 例. [_eLast] = 10 の場合、Enumは直前まで 0 ～ 9 で
    ' 　　10個の要素を持つことになる。
    ' ※変数宣言と揃えるために、列方向の要素は０～３とする。
    ReDim arr(0 To ItemListBox.ListCount - 1 + 3, 3)
        arr(0, 0) = "Public "
        arr(0, 1) = "Enum " & EnumNameTextBox
    Dim i As Long
        For i = 1 To UBound(arr) - 2
            arr(i, 0) = Chr(9) & PrefixEnumCharacterTextBox.Value
            arr(i, 1) = ItemListBox.List(i - 1, 0)
        Next
        
        If From1CheckBox.Value Then
            arr(1, 2) = "=1"
        End If
        
        arr(i, 0) = Chr(9)
        arr(i, 1) = "[_eLast]"
        
        i = i + 1
        arr(i, 0) = "End "
        arr(i, 1) = "Enum"
               
        ItemListBox.List = arr
        CopyButton.Enabled = True
End Sub

' 本ツールの既定値をセットするチェックボックス。
' ※既定値は、ユーザーで任意に変更して構わない。
Private Sub EnumDefaultCheckBox_Click()
    Select Case EnumDefaultCheckBox.Value
        Case True
            EnumNameTextBox = "列名"
            PrefixEnumCharacterTextBox = "en"
            From1CheckBox.Value = True
        Case False
            EnumNameTextBox = vbNullString
            PrefixEnumCharacterTextBox = vbNullString
            From1CheckBox.Value = False
    End Select
End Sub

' 「Enum名称」入力用テキストボックス。
' 未入力の場合、Enum作成ボタンを無効化する。
Private Sub EnumNameTextBox_Change()
    If EnumNameTextBox = vbNullString Then
        EnumButton.Enabled = False
    Else
        EnumButton.Enabled = True
    End If
End Sub

' 表のラベルは、そのままの使用に適さない場合がある。
' これを修正するために、リストボックスで一旦選択し、
' その値をテキストボックスに表示させている。
Private Sub ItemListBox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Select Case ItemListBox.MultiSelect
        Case fmMultiSelect.fmMultiSelectSingle
            NewNameTextBox = ItemListBox.Value
        Case fmMultiSelect.fmMultiSelectMulti
            Dim i As Long
            Dim SelectedIndex As Long
            Dim Counter As Long
                For i = 0 To ItemListBox.ListCount - 1
                    If ItemListBox.Selected(i) Then
                        Counter = Counter + 1
                        SelectedIndex = i
                    End If
                    
                    ' 複数選択が判明した時点で、処理を抜ける。
                    If Counter >= 2 Then
                        RenameButton.Enabled = False
                        Exit Sub
                    End If
                Next
                
                RenameButton.Enabled = True
                Select Case ItemListBox.ColumnCount
                    Case 1
                        NewNameTextBox = ItemListBox.List(SelectedIndex, 0)
                    Case Else
                        NewNameTextBox = ItemListBox.List(SelectedIndex, 1)
                End Select
    End Select
End Sub

' 「選択行の変更後文字」入力用テキストボックス。
' 未入力の場合、文字修正ボタンを無効化する。
Private Sub NewNameTextBox_Change()
    If NewNameTextBox = vbNullString Then
        RenameButton.Enabled = False
    Else
        ' 一括での名前変更不可（同名の変数ができてしまうため）。
        If Not MultiSelected Then
            RenameButton.Enabled = True
        End If
    End If
End Sub

' 文字修正ボタン。
' 「選択行の変更後文字」テキストボックスに入力された値を、
' リストボックスの表示に反映させている。
Private Sub RenameButton_Click()
        If MultiSelected Then
            RenameButton.Enabled = False
            Exit Sub
        End If

    Dim i As Long
        For i = 0 To ItemListBox.ListCount - 1
            Select Case i
                ' 名称を変更しない場合、自分自身と重複することを回避。
                Case ItemListBox.ListIndex
                
                ' リストボックスで選択されていない項目について確認。
                ' 全角／半角の影響を受けないよう、vbBinaryCompareを引数に充てている。
                ' ※StrCompで両者が一致した場合の戻り値＝０。
                Case Else
                    If StrComp(ItemListBox.List(i), NewNameTextBox.Value, vbBinaryCompare) = 0 Then
                        MsgBox "変更後の名称が既存名称と重複しています。"
                        Exit Sub
                    End If
            End Select
        Next
        Select Case ItemListBox.ColumnCount
            Case 1
                ItemListBox.List(ItemListBox.ListIndex, 0) = NewNameTextBox.Value
            Case Else
                ItemListBox.List(ItemListBox.ListIndex, 1) = NewNameTextBox.Value
        End Select
End Sub

' 選択範囲のラベル行をリストボックスにセット。
Private Sub ResetButton_Click()
    With ItemListBox
        .List = HeaderList
        .ColumnCount = 1
    End With
    
    NewNameTextBox.Value = vbNullString
    CopyButton.Enabled = False
    
    EnumDefaultCheckBox.Value = False
    
    DeclarationComboBox.Value = vbNullString
    TypeComboBox.Value = vbNullString
    
End Sub

' 作成結果をクリップボードにコピー。
Private Sub CopyButton_Click()
        With CreateObject("Forms.TextBox.1")
            .MultiLine = True
            .Text = CopyText
            .SelStart = 0
            .SelLength = .TextLength
            .Copy
        End With
End Sub

Private Sub EndButton_Click()
    Unload Me
End Sub

' 選択範囲からラベル行を取得して配列化。
Private Property Get HeaderList() As Variant
        
    ' 一列しかないなら、このツールは使わなくてもＯＫ。
        If Selection.Columns.Count = 1 Then
            HeaderList = Array()
            Exit Property
        End If
    
    ' 表全体を選択されているかもしれないので、
    ' 一行目だけ配列に入れたうえで縦横入れ替え。
    Dim arr As Variant
        arr = Selection.Rows(1)
        arr = WorksheetFunction.Transpose(arr)
    
    ' 変数名などは重複が許されないため、辞書で重複確認。
    ' 重複した場合、後ろに数字を付す（重複毎カウントアップ）。
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    Dim temp As String
    Dim i As Long
        For i = 1 To UBound(arr)
            ' 一旦全て全角にし、禁則文字の処理を簡素化する。
            ' （半角と全角で二回処理することを回避）。
            ' ※VBEに貼り付けた時点で、英数字は半角化する。
            temp = StrConv(arr(i, 1), vbWide)
            ' 禁則文字除去。
            temp = CheckNGCharacter(temp)
            If Not Dict.Exists(temp) Then
                Dict(temp) = 1
            Else
                Dict(temp) = Dict(temp) + 1
                Dict(temp & Dict(temp)) = 1
            End If
        Next
        HeaderList = WorksheetFunction.Transpose(Dict.Keys)
End Property

Private Property Get CopyText() As String
    Dim SourceArray As Variant
        SourceArray = ItemListBox.List
    Dim arr() As Variant
    Dim temp As Variant
    Dim myDelimiter As String
        If MultiPage.SelectedItem.Name = "pg変数" Then
            myDelimiter = " "
        End If
    Dim i As Long
    
        Select Case MultiPage.SelectedItem.Name
        
            Case "pg変数", "pgEnum"
            
                ReDim arr(ItemListBox.ListCount - 1)
                For i = 0 To ItemListBox.ListCount - 1
                    ' index関数による配列のスライスは、配列のindexではなく
                    ' 「ｉ番目」の切り出しであることに注意。
                    ' （０行目を指定すると配列の全てが返ってくる）。
                    temp = WorksheetFunction.Index(SourceArray, i + 1, 0)
                    ' 空白行があっても半角スペースで結合してしまうが、
                    ' VBEに貼り付けた時点で消してくれる。
                    ' なお、Enumの場合は半角を挟まず、そのまま結合する。
                    ' ※字下げなどレイアウトの都合による。
                    arr(i) = Join(temp, myDelimiter)
                Next
            
            Case "pgCreateObject"
                ReDim arr(CreateObjectItemName.[_eLast] - 1)
                    arr(incomment) = CreateObjectArray(TypeID, ObjectID, incomment)
                    arr(inDeclarate) = CreateObjectArray(TypeID, ObjectID, inDeclarate)
                    arr(inInitialize) = CreateObjectArray(TypeID, ObjectID, inInitialize)
        
        End Select
                
        CopyText = Join(arr, vbNewLine)
End Property

' 禁則文字の除去。
' とりあえず、よく登場するのだけ。
Private Function CheckNGCharacter(source_character As Variant) As String
    Dim temp As String
        temp = StrConv(CStr(source_character), vbWide)
    
    Dim NGCharacter As String
        NGCharacter = "，（）／．"
    
    Dim str As String
    Dim i As Long
        For i = 1 To Len(NGCharacter)
            str = Mid(NGCharacter, i, 1)
            Select Case str
                Case "）", "．"
                    temp = Replace(temp, str, vbNullString)
                Case Else
                    temp = Replace(temp, str, "_")
            End Select
        Next
        CheckNGCharacter = temp
End Function

' リストボックスの列数に合わせて列幅変更。
Private Property Get ColumnWidth() As String
    Select Case ItemListBox.ColumnCount
        Case 1
            ColumnWidth = "280pt"
        Case Else
            ColumnWidth = "40pt;120pt;20pt"
    End Select
End Property

' 宣言子の選択肢。
Private Property Get DeclarationArray() As Variant
    DeclarationArray = Array("Dim", _
                             "Private", _
                             "Public", _
                             "Static")
End Property

' 変数の型の選択肢。
Private Property Get TypeArray() As Variant
    TypeArray = Array("Variant", _
                      "String", _
                      "Long", _
                      "Double", _
                      "Date", _
                      "Currency")
End Property

' リストボックスの選択数。
Private Property Get MultiSelected() As Boolean
    Dim i As Long
    Dim Counter As Long
        For i = 0 To ItemListBox.ListCount - 1
            If ItemListBox.Selected(i) Then
                Counter = Counter + 1
            End If
            If Counter >= 2 Then
                MultiSelected = True
                Exit Property
            End If
        Next
End Property

' CreateObject用配列
Private Property Get CreateObjectArray() As Variant
    Dim arr() As Variant
    ReDim arr(BindingType.[_eLast] - 1, _
              CreateObjectID.[_eLast] - 1, _
              CreateObjectItemName.[_eLast] - 1)

        ' ファイルシステムオブジェクト。
        arr(btEarlyBinding, idFileSystemObject, incomment) = _
            "' 参照設定：Microsoft Scripting Runtime"
        arr(btEarlyBinding, idFileSystemObject, inDeclarate) = _
            "Dim " & CreateObjectVariableName(idFileSystemObject) & " As Scripting.FileSystemObject"
        arr(btEarlyBinding, idFileSystemObject, inInitialize) = _
            "Set " & CreateObjectVariableName(idFileSystemObject) & "=New Scripting.FileSystemObject"

        arr(btLateBinding, idFileSystemObject, incomment) = vbNullString
        arr(btLateBinding, idFileSystemObject, inDeclarate) = _
            "Dim " & CreateObjectVariableName(idFileSystemObject) & " As Object"
        arr(btLateBinding, idFileSystemObject, inInitialize) = _
            "Set " & CreateObjectVariableName(idFileSystemObject) & "=CreateObject(""Scripting.FileSystemObject"")"

        ' 連想配列（辞書）。
        arr(btEarlyBinding, idDictionary, incomment) = _
            "' 参照設定：Microsoft Scripting Runtime"
        arr(btEarlyBinding, idDictionary, inDeclarate) = _
            "Dim " & CreateObjectVariableName(idDictionary) & " As Scripting.Dictionary"
        arr(btEarlyBinding, idDictionary, inInitialize) = _
            "Set " & CreateObjectVariableName(idDictionary) & "=New Scripting.Dictionary"

        arr(btLateBinding, idDictionary, incomment) = vbNullString
        arr(btLateBinding, idDictionary, inDeclarate) = _
            "Dim " & CreateObjectVariableName(idDictionary) & " As Object"
        arr(btLateBinding, idDictionary, inInitialize) = _
            "Set " & CreateObjectVariableName(idDictionary) & "=CreateObject(""Scripting.Dictionary"")"
            
        ' 正規表現。
        arr(btEarlyBinding, idRegExp, incomment) = _
            "' 参照設定：Microsoft VBScript Regular Expressions 5.5"
        arr(btEarlyBinding, idRegExp, inDeclarate) = _
            "Dim " & CreateObjectVariableName(idRegExp) & " As VBScript_RegExp_55.RegExp"
        arr(btEarlyBinding, idRegExp, inInitialize) = _
            "Set " & CreateObjectVariableName(idRegExp) & "=New VBScript_RegExp_55.RegExp"

        arr(btLateBinding, idRegExp, incomment) = vbNullString
        arr(btLateBinding, idRegExp, inDeclarate) = _
            "Dim " & CreateObjectVariableName(idRegExp) & " As Object"
        arr(btLateBinding, idRegExp, inInitialize) = _
            "Set " & CreateObjectVariableName(idRegExp) & "=CreateObject(""VBScript.RegExp"")"
            
        CreateObjectArray = arr

End Property

' CreateObjcet変数名辞書
Private Property Get CreateObjectVariableName() As Object
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
        
        Dict(CreateObjectID.idFileSystemObject) = "FSO"
        Dict(CreateObjectID.idDictionary) = "Dict"
        Dict(CreateObjectID.idRegExp) = "myReg"
        
    Set CreateObjectVariableName = Dict
End Property

Private Property Get TypeID() As Long
    If OB_EarlyBinding.Value Then
        TypeID = BindingType.btEarlyBinding
    Else
        TypeID = BindingType.btLateBinding
    End If
End Property

Private Property Get ObjectID() As Long
    Select Case ObjectNameComboBox
        Case "ファイルシステムオブジェクト"
            ObjectID = CreateObjectID.idFileSystemObject
        
        Case "連想配列（辞書）"
            ObjectID = CreateObjectID.idDictionary
        
        Case "正規表現"
            ObjectID = CreateObjectID.idRegExp
    End Select
End Property

Private Property Get ObjectNameArray() As Variant
    ObjectNameArray = Array("ファイルシステムオブジェクト", _
                            "連想配列（辞書）", _
                            "正規表現")
End Property

参考まで。