MakeCodeEnum

'MakeCodeEnum               ・・・元場所：IkiAddin.ModClipboard
'MsgYesNo                   ・・・元場所：IkiAddin.ModMessage
'GetArray2DFromCell         ・・・元場所：IkiAddin.ModCell
'FlattenArray2D             ・・・元場所：IkiAddin.ModArray
'CheckArray2D               ・・・元場所：IkiAddin.ModArray
'CheckArray2DStart1         ・・・元場所：IkiAddin.ModArray
'F_InputBox                 ・・・元場所：IkiAddin.ModMessage
'UniqueArray                ・・・元場所：IkiAddin.ModArray
'MakeDictFromArray1DForCount・・・元場所：IkiAddin.ModDictionary
'CheckArray1D               ・・・元場所：IkiAddin.ModArray
'CheckArray1DStart1         ・・・元場所：IkiAddin.ModArray
'DimArray1DSameValue        ・・・元場所：IkiAddin.ModArray
'MakeDictFromArray1D        ・・・元場所：IkiAddin.ModDictionary
'Conv__使えない記号を置換   ・・・元場所：IkiAddin.ModClipboard
'ClipboardCopy              ・・・元場所：IkiAddin.ModClipboard



Public Sub MakeCodeEnum()
'選択セルからEnumを作成する
'20221015
'20230123 要素名に番号を付与するかどうかどうか選択機能追加
'20230123 要素名が重複する場合に番号を追加する
'20230127 使えない記号を"_"に置き換える

'http://blog.livedoor.jp/aero_iki-jibundakemacro/archives/35130289.html

    '選択オブジェクトがセルかどうか判定して、セルならセルを参照
    Dim Dummy      As Object: Set Dummy = Selection
    Dim Cell       As Range
'    Dim DefaultStr As String
    If TypeName(Dummy) = "Range" Then
        Set Cell = Dummy
'        DefaultStr = Dummy.Address
    Else
        Exit Sub
'        DefaultStr = ""
    End If
    
    '要素名に番号を付与するかどうか尋ねる
    Dim Judge_番号付与 As Boolean
    If MsgYesNo("要素名に番号を付与しますか?") = True Then
        Judge_番号付与 = True
    Else
        Judge_番号付与 = False
    End If
    
    'セル範囲の項目名を全て取得する
    Dim List_項目 As Variant: List_項目 = GetArray2DFromCell(Cell) 'セル範囲から二次元配列を取得する(選択範囲が単一セルでも対応)
    List_項目 = FlattenArray2D(List_項目) '平滑化する
    
    'Enumの名前を入力させる
    Dim EnumName As String: EnumName = "Enum_" & F_InputBox("Enumの名前を入力してください", "Enum名入力", "", String_:=True)
    
    '頭文字のアルファベットを入力させる
    Do
        Dim HeadABC As String: HeadABC = F_InputBox("要素名の頭文字のアルファベットを1文字入力してください", "要素名頭文字", "E", String_:=True)
        If Len(HeadABC) = 1 And IsNumeric(Mid(HeadABC, 1, 1)) = False Then '1文字で数値でない
            Exit Do
        End If
    Loop
    
    '重複する項目名に番号を追加するための連想配列
    Dim List_項目_非重複 As Variant: List_項目_非重複 = UniqueArray(List_項目)
    Dim Dict_項目        As Dictionary: Set Dict_項目 = MakeDictFromArray1DForCount(List_項目_非重複)
    
    '各項目を要素名にする
    Dim I As Long
    Dim N As Long: N = UBound(List_項目, 1)
    Dim K As Long
    For I = 1 To N
        If List_項目(I) <> "" Then '空白は除外する
            K = K + 1
            Dim Str_項目名   As String: Str_項目名 = List_項目(I)
            Str_項目名 = Conv__使えない記号を置換(Str_項目名)
            
            Dim Str_追加番号 As String
            If Dict_項目(Str_項目名) = 1 Then
                Str_追加番号 = ""
            Else
                Str_追加番号 = Dict_項目(Str_項目名) + 1
                Dict_項目(Str_項目名) = Dict_項目(Str_項目名) + 1
            End If
            
            If Judge_番号付与 = True Then
                List_項目(I) = HeadABC & Format(K, "00") & "_" & Str_項目名 & Str_追加番号 & " = " & K '例)E01番号 = 1
            Else
                List_項目(I) = HeadABC & "_" & Str_項目名 & Str_追加番号 & " = " & K  '例)E01番号 = 1
            End If
        End If
    Next
    
    'コードを作成する
    Dim Str As String
    Str = Str & "Public Enum " & EnumName & vbLf
    K = 0
    For I = 1 To N
        If List_項目(I) <> "" Then '空白は除外する
            Str = Str & "    " & List_項目(I) & vbLf
        End If
    Next
    Str = Str & "End Enum"
        
    '作成したコードをクリップボードに格納
    Call ClipboardCopy(Str)
    
'    '音で知らせる
'    Call Beep
'
'    '確認メッセージ
'    With frmMessageText
'        .frmCaption = "選択セルからセル範囲を取得するコード"
'        .Lbl = "下記コードをクリップボードに格納しました"
'        .Text = Str
'        .AutoSize = True
'        .Show
'    End With
    
End Sub

Private Function MsgYesNo(ParamArray MsgList()) As Boolean
'文章だけを入力してYes,Noを訪ねてTrue/Falseを返す。
'Yes→True
'No→False
'文章は可変長引数配列で入力して自動的に改行する
'20221221
'http://blog.livedoor.jp/aero_iki-jibundakemacro/archives/35242205.html

'引数
'MsgList・・・メッセージを1行ずつ可変長引数配列で入力
    
    'メッセージの作成
    Dim Str     As Variant
    Dim Message As String
    For Each Str In MsgList
        If Message = "" Then '1文字目の場合
            Message = Str
        Else '2文字目以降の場合は改行でつなげる
            Message = Message & vbLf & Str
        End If
    Next
    
    'メッセージ表示とYes,Noを尋ねる
    Dim Output As Boolean
    If MsgBox(Message, vbYesNo + vbInformation) = vbYes Then
        Output = True
    Else
        Output = False
    End If
    
    '出力
    MsgYesNo = Output
    
End Function

Private Function GetArray2DFromCell(CellArea As Range) As Variant
'セルオブジェクトからセル値の二次元配列を取得する
'セルオブジェクトが単一セルでも二次元配列となる。
'「単一セル.Value」が配列でなく変数になるのに対応
'20220921
'http://blog.livedoor.jp/aero_iki-jibundakemacro/archives/35185051.html

'引数
'CellArea・・・セル範囲

'戻り値
'セル範囲から生成される二次元配列

    Dim Output As Variant
    If CellArea.CountLarge = 1 Then '単一セルの場合
        ReDim Output(1 To 1, 1 To 1)
        Output(1, 1) = CellArea.Value
    Else
        Output = CellArea.Value
    End If
    
    '出力
    GetArray2DFromCell = Output
    
End Function

Private Function FlattenArray2D(ByRef Array2D As Variant, _
                    Optional ByRef Direction As XlDirection = XlDirection.xlToRight) _
                                             As Variant
'二次元配列を平滑化（一次元配列）にする。並べる値の方向はDirectionで指定
'20220307
'http://blog.livedoor.jp/aero_iki-jibundakemacro/archives/32360924.html

'引数
'Array2D    ・・・二次元配列
'[Direction]・・・並べる値の方向

'返り値
'二次元配列が平坦化されて一次元配列になったもの

    '引数チェック
    Call CheckArray2D(Array2D)       '二次元配列かチェック
    Call CheckArray2DStart1(Array2D) '開始要素番号が1かチェック
    
    '二次元配列のサイズ取得
    Dim N As Long: N = UBound(Array2D, 1) '縦要素数
    Dim M As Long: M = UBound(Array2D, 2) '横要素数
    
    '出力する一次元配列を作成。Directionで場合分け
    Dim Output As Variant: ReDim Output(1 To N * M)
    Dim I      As Long
    Dim J      As Long
    Dim K      As Long: K = 0
    
    Select Case Direction
        Case XlDirection.xlToRight '左から右方向
            For I = 1 To N
                For J = 1 To M
                    K = K + 1
                    Output(K) = Array2D(I, J)
                Next J
            Next I
        Case XlDirection.xlToLeft '右から左方向
            For I = 1 To N
                For J = M To 1 Step -1
                    K = K + 1
                    Output(K) = Array2D(I, J)
                Next J
            Next I
        Case XlDirection.xlDown '上から下方向
            For J = 1 To M
                For I = 1 To N
                    K = K + 1
                    Output(K) = Array2D(I, J)
                Next I
            Next J
        Case XlDirection.xlUp '下から上方向
            For J = 1 To M
                For I = N To 1 Step -1
                    K = K + 1
                    Output(K) = Array2D(I, J)
                Next I
            Next J
    End Select
    
    '出力
    FlattenArray2D = Output
    
End Function

Private Sub CheckArray2D(ByRef Array2D As Variant, _
             Optional ByRef ArrayName As String = "配列")
'入力配列が2次元配列かどうかチェックする
'20210804
'20220309 変数名変更

    On Error Resume Next
    Dim Dummy2 As Long: Dummy2 = UBound(Array2D, 2)
    Dim Dummy3 As Long: Dummy3 = UBound(Array2D, 3)
    On Error GoTo 0
    If Dummy2 = 0 Or Dummy3 <> 0 Then
        MsgBox ArrayName & "は2次元配列を入力してください", vbExclamation
        Stop
        Exit Sub '入力元のプロシージャを確認するために抜ける
    End If

End Sub

Private Sub CheckArray2DStart1(ByRef Array2D As Variant, _
                   Optional ByRef ArrayName As String = "配列")
'入力2次元配列の開始番号が1かどうかチェックする
'20210804
'20220309 変数名変更

    If LBound(Array2D, 1) <> 1 Or LBound(Array2D, 2) <> 1 Then
        MsgBox ArrayName & "の開始要素番号は1にしてください", vbExclamation
        Stop
        Exit Sub '入力元のプロシージャを確認するために抜ける
    End If

End Sub

Private Function F_InputBox(ByRef Prompt As String, _
                   Optional ByRef Title As String, _
                 Optional ByRef Default As String, _
                 Optional ByRef formula As Boolean = False, _
                   Optional ByRef Value As Boolean = False, _
                 Optional ByRef String_ As Boolean = False, _
                Optional ByRef Boolean_ As Boolean = False, _
                 Optional ByRef refCell As Boolean = False, _
                   Optional ByRef Error As Boolean = False, _
                  Optional ByRef Array_ As Boolean = False) As Variant
'Application.InputBoxのType引数の処理を個別に指定できる
'20211222
'20220118修正
'20220317改良
'http://blog.livedoor.jp/aero_iki-jibundakemacro/archives/35111320.html

'引数
'Prompt    ・・・表示メッセージ
'[Title]   ・・・タイトル
'[Default] ・・・デフォルト値
'[Formula] ・・・数式かどうか
'[Value]   ・・・数値かどうか
'[String_] ・・・文字列かどうか
'[Boolean_]・・・ブール値かどうか
'[RefCell] ・・・セル参照かどうか
'[Error]   ・・・エラー値かどうか
'[Array_]  ・・・値の配列かどうか

    'InputBoxのType引数を計算する
    Dim TypeNum As Long: TypeNum = 0
    If formula Then TypeNum = TypeNum + 0
    If Value Then TypeNum = TypeNum + 1
    If String_ Then TypeNum = TypeNum + 2
    If Boolean_ Then TypeNum = TypeNum + 4
    If refCell Then TypeNum = TypeNum + 8
    If Error Then TypeNum = TypeNum + 16
    If Array_ Then TypeNum = TypeNum + 64
    
    If TypeNum = 0 Then
        TypeNum = 2 'デフォルトでは文字列とする
    End If
    
    If refCell = True Then
        Set F_InputBox = Nothing '20220317(セル選択にてキャンセルとなった場合はNothingを返す処理)
        On Error Resume Next
        If Default <> "" Then
            Set F_InputBox = Application.InputBox(Prompt, Title, Type:=TypeNum, Default:=Default)
        Else
            Set F_InputBox = Application.InputBox(Prompt, Title, Type:=TypeNum)
        End If
        On Error GoTo 0
    Else
        If Default <> "" Then
            F_InputBox = Application.InputBox(Prompt, Title, Type:=TypeNum, Default:=Default)
        Else
            F_InputBox = Application.InputBox(Prompt, Title, Type:=TypeNum)
        End If
    End If
    
End Function

Private Function UniqueArray(Array_)
'配列のユニーク値を一次元配列で返す
'20220125

'引数
'Array_・・・配列
    
    'ユニーク値抜き出し用に連想配列を定義
    Dim TmpDict  As Object: Set TmpDict = CreateObject("Scripting.Dictionary")
    Dim TmpValue As Variant
    Dim I        As Long
    For Each TmpValue In Array_
        If TmpDict.Exists(TmpValue) = False Then
            TmpDict.Add TmpValue, ""
        End If
    Next
        
    '出力する一次元配列を作成
    Dim Output As Variant: Output = TmpDict.Keys
    Output = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Output))
    
    UniqueArray = Output
    
End Function

Private Function MakeDictFromArray1DForCount(ByRef Array1D As Variant, _
                                  Optional ByRef StartNum As Long = 1) _
                                                          As Dictionary
'各要素の数え上げ用の連想配列を作成する
'20230123

'引数
'Array1D   ・・・キーとなる要素が入った一次元配列(中身が重複していないこと)
'[StartNum]・・・数え上げの最初の番号。デフォルトでは1
    
    '引数チェック
    Call CheckArray1D(Array1D, "Array1D")         '一次元配列かチェック
    Call CheckArray1DStart1(Array1D, "Array1D")   '要素の開始番号が1かチェック
    
    '処理
    Dim N          As Long:       N = UBound(Array1D, 1)
    Dim NumArray1D As Variant:    NumArray1D = DimArray1DSameValue(N, StartNum)
    Dim Output     As Dictionary: Set Output = MakeDictFromArray1D(Array1D, NumArray1D)
    
    '出力
    Set MakeDictFromArray1DForCount = Output

End Function

Private Sub CheckArray1D(ByRef Array1D As Variant, _
             Optional ByRef ArrayName As String = "配列")
'入力配列が1次元配列かどうかチェックする
'20210804
'20220309 変数名変更

    On Error Resume Next
    Dim Dummy As Long: Dummy = UBound(Array1D, 2)
    On Error GoTo 0
    If Dummy <> 0 Then
        MsgBox ArrayName & "は1次元配列を入力してください", vbExclamation
        Stop
        Exit Sub '入力元のプロシージャを確認するために抜ける
    End If

End Sub

Private Sub CheckArray1DStart1(ByRef Array1D As Variant, _
                   Optional ByRef ArrayName As String = "配列")
'入力1次元配列の開始番号が1かどうかチェックする
'20210804
'20220309 変数名変更

    If LBound(Array1D, 1) <> 1 Then
        MsgBox ArrayName & "の開始要素番号は1にしてください", vbExclamation
        Stop
        Exit Sub '入力元のプロシージャを確認するために抜ける
    End If

End Sub

Private Function DimArray1DSameValue(ByRef Count As Long, _
                                    ByRef Value As Variant) _
                                                As Variant
'全て同じ値が入った一次元配列を定義する
'20210923
'http://blog.livedoor.jp/aero_iki-jibundakemacro/archives/32349170.html

'引数
'Count・・・要素数(Long型)
'Value・・・同じ値を入れる値(オブジェクト型でも可能)
    
'返り値
'全て同じ値が入った一次元配列
    
    '引数チェック
    If Count <= 0 Then
        MsgBox "要素数Countは1以上の値を入れてください。" & vbLf & _
               "Count = " & Count, vbExclamation
        Stop
    End If
    
    '処理
    Dim I      As Long
    Dim Output As Variant: ReDim Output(1 To Count)
    For I = 1 To Count
        If IsObject(Value) Then
            Set Output(I) = Value
        Else
            Output(I) = Value
        End If
    Next I
    
    '出力
    DimArray1DSameValue = Output
    
End Function

Private Function MakeDictFromArray1D(ByRef KeyArray1D As Variant, _
                                   ByRef ItemArray1D As Variant, _
                         Optional ByRef ConvKeyToStr As Boolean = False) _
                                                     As Dictionary
'2つの一次元配列から連想配列を作成する
'各配列の要素の開始番号は1とすること
'20210806作成
'20211118
'20221130 Keyを文字列型に変換するかどうかのオプション追加
'http://blog.livedoor.jp/aero_iki-jibundakemacro/archives/33786210.html

'引数

'引数
'KeyArray1D    ・・・Keyが入った一次元配列
'ItemArray1D   ・・・Itemが入った一次元配列
'[ConvKeyToStr]・・・Keyを文字列型に変換するかどうか/省略なら変換しない

'返り値
'2つの一次元配列から作成された連想配列

    '引数チェック
    Call CheckArray1D(KeyArray1D, "KeyArray1D")         '一次元配列かチェック
    Call CheckArray1DStart1(KeyArray1D, "KeyArray1D")   '要素の開始番号が1かチェック
    Call CheckArray1D(ItemArray1D, "ItemArray1D")       '一次元配列かチェック
    Call CheckArray1DStart1(ItemArray1D, "ItemArray1D") '要素の開始番号が1かチェック
    If UBound(KeyArray1D, 1) <> UBound(ItemArray1D, 1) Then
        MsgBox ("「KeyArray1D」と「ItemArray1D」の縦要素数を一致させてください")
        Stop
        Exit Function
    End If
    
    Dim I      As Long
    Dim N      As Long: N = UBound(KeyArray1D, 1)
    Dim Output As Dictionary: Set Output = New Dictionary
'    Dim TmpKey As Variant '20211118 数値と文字列型両方を扱うためVariant型
'    Dim TmpKey As String '20220808 キーは文字列型にする
    Dim TmpKey As Variant '20221130 まずはバリアント型で取得する
    
    For I = 1 To N
        TmpKey = KeyArray1D(I)
        If IsNumeric(TmpKey) = True And ConvKeyToStr = True Then '20221130
            TmpKey = CStr(TmpKey)
        End If
        
        If Output.Exists(TmpKey) = False Then
            Output.Add TmpKey, ItemArray1D(I)
        End If
    Next I
    
    Set MakeDictFromArray1D = Output
        
End Function

Private Function Conv__使えない記号を置換(Str_項目名 As String) As String
    Dim Output As String
    Output = Replace(Str_項目名, "(", "_")
    Output = Replace(Output, ")", "")
    Output = Replace(Output, "（", "_")
    Output = Replace(Output, "）", "")
    Output = Replace(Output, "・", "")
    Output = Replace(Output, "/", "_")
    Output = Replace(Output, vbLf, "")
    Output = Replace(Output, vbCr, "")
    Conv__使えない記号を置換 = Output
End Function

Private Sub ClipboardCopy(ByVal InputClipText As Variant, _
                      Optional ByRef Message As Boolean = False)
'入力テキストをクリップボードに格納
'配列ならば列方向をTabわけ、行方向を改行する。
'20210719作成

'参考:http://blog.livedoor.jp/aero_iki-jibundakemacro/archives/30565154.html

    '入力した引数が配列か、配列の場合は1次元配列か、2次元配列か判定
    Dim HairetuHantei As Long
    Dim Jigen1        As Long
    Dim Jigen2        As Long
    If IsArray(InputClipText) = False Then
        '入力引数が配列でない
        HairetuHantei = 0
    Else
        On Error Resume Next
        Jigen2 = UBound(InputClipText, 2)
        On Error GoTo 0
        
        If Jigen2 = 0 Then
            HairetuHantei = 1
        Else
            HairetuHantei = 2
        End If
    End If
    
    'クリップボードに格納用のテキスト変数を作成
    Dim Output As String
    Dim I      As Long
    Dim J      As Long
    Dim M      As Long
    Dim N      As Long
    
    If HairetuHantei = 0 Then '配列でない場合
        Output = InputClipText
    ElseIf HairetuHantei = 1 Then '1次元配列の場合
    
        If LBound(InputClipText, 1) <> 1 Then '最初の要素番号が1出ない場合は最初の要素番号を1にする
            InputClipText = Application.Transpose(Application.Transpose(InputClipText))
        End If
        
        N = UBound(InputClipText, 1)
        
        Output = ""
        For I = 1 To N
            If I = 1 Then
                Output = InputClipText(I)
            Else
                Output = Output & vbLf & InputClipText(I)
            End If
            
        Next I
    ElseIf HairetuHantei = 2 Then '2次元配列の場合
        
        If LBound(InputClipText, 1) <> 1 Or LBound(InputClipText, 2) <> 1 Then
            InputClipText = Application.Transpose(Application.Transpose(InputClipText))
        End If
        
        N = UBound(InputClipText, 1)
        M = UBound(InputClipText, 2)
        
        Output = ""
        
        For I = 1 To N
            For J = 1 To M
                If J < M Then
                    Output = Output & InputClipText(I, J) & Chr(9)
                Else
                    Output = Output & InputClipText(I, J)
                End If
                
            Next J
            
            If I < N Then
                Output = Output & Chr(10)
            End If
        Next I
    End If
    
    
    'クリップボードに格納'参考 https://www.ka-net.org/blog/?p=7537
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True
        .Text = Output
        .SelStart = 0
        .SelLength = .TextLength
        .Copy
    End With

    '格納したテキスト変数をメッセージ表示
    If Message Then
        MsgBox ("「" & Output & "」" & vbLf & _
                "をクリップボードにコピーしました。")
    End If
    
End Sub