MakeCodeSheetNamedCellProperty

'MakeCodeSheetNamedCellProperty・・・元場所：VBAProject.Mod01_
'GetNamedCellInSheet           ・・・元場所：VBAProject.Mod01_
'ExtractArray2D                ・・・元場所：IkiAddin.ModArray
'IsArray2D                     ・・・元場所：IkiAddin.ModArray
'IsArray2DStart1               ・・・元場所：IkiAddin.ModArray
'ClipText                      ・・・元場所：IkiAddin.ModClipboard
'ShowVBE                       ・・・元場所：IkiAddin.ModOther
'ShowImmediateWindow           ・・・元場所：IkiAddin.ModOther
'ShowCodeWindowDelay           ・・・元場所：IkiAddin.ModOther
'ShowVBEOfModule               ・・・元場所：IkiAddin.ModVBIDE
'GetAllCodeModuleInBook        ・・・元場所：IkiAddin.ModVBIDE
'Get__AllCodeInModule          ・・・元場所：IkiAddin.ModVBIDE
'ShowCodeWindow                ・・・元場所：IkiAddin.ModOther

'宣言セクション※※※※※※※※※※※※※※※※※※※※※※※※※※※
'-----------------------------------
'元場所:IkiAddin.ModVBIDE.Enum_ModuleShowRow
Public Enum Enum_ModuleShowRow
    vbModuleStart = 1
    vbModuleEnd = 2
    vbByCodeStr = 3
End Enum
'宣言セクション終了※※※※※※※※※※※※※※※※※※※※※※※※※※※

Public Sub MakeCodeSheetNamedCellProperty()
'ワークシートのコードウィンドウで名前定義一覧を取得できるPropertyプロシージャを自動的に生成する
'ワークシートはActiveSheetを対象とする
'20251009

    'ActiveSheet内の名前定義一覧を取得する
    Dim Sheet         As Worksheet: Set Sheet = ActiveSheet
    Dim ListNamedCell As Variant: ListNamedCell = GetNamedCellInSheet(Sheet)
    If IsEmpty(ListNamedCell) = True Then
        MsgBox "「" & Sheet.Name & "」内に名前定義のセルはありません", vbInformation
        Exit Sub
    End If
    
    'コードを生成
    Dim I        As Long
    Dim N        As Long: N = UBound(ListNamedCell, 1)
    Dim StrCode  As String: StrCode = "Option Explicit" & vbLf & vbLf
    Dim Name_    As String
    Dim NameCell As Name
    For I = 1 To N
        Name_ = ListNamedCell(I, 2)
        Set NameCell = ListNamedCell(I, 1)
        StrCode = StrCode & "Public Property Get NC_" & Name_ & "() As Range" & vbLf
        StrCode = StrCode & "'Address:" & NameCell.RefersToRange.Address(False, False) & " " & Format(Date, "YYYYMMDD更新") & vbLf
        StrCode = StrCode & "    " & "Set NC_" & Name_ & " = Me.Range(" & """" & Name_ & """" & ")" & vbLf
        StrCode = StrCode & "End Property" & vbLf
        StrCode = StrCode & vbLf
    Next
    
    '作成したコードをクリップボードに格納
    Call ClipText(StrCode)
    
    '音で知らせる
    Call Beep
    
    'VBEとイミディエイトウィンドウ表示
    Call ShowVBE
    Call ShowImmediateWindow
    Call ShowCodeWindowDelay
    Call ModVBIDE.ShowVBEOfModule(Sheet.CodeName, Sheet.Parent, vbModuleStart) 'ワークシートのコードウィンドウ表示
    
    'イミディエイトウィンドウに表示
    Debug.Print "下記コードをクリップボードにコピーしました"
    Debug.Print "ワークシートのコードウィンドウに貼り付けてください"
    Debug.Print StrCode
        
End Sub

Private Function GetNamedCellInSheet(Sheet As Worksheet) As Variant
'ワークシート内の名前定義セルを一覧で取得する
'20251009

'引数
'Sheet・・・対象シート

'返り値
'シート内の名前定義一覧の二次元配列
'1列目:Nameオブジェクト,2列目:名前,3列目:参照範囲(Book or Sheet)
 
    Dim NameCell As Name
    Dim Book     As Workbook: Set Book = Sheet.Parent
    Dim Output   As Variant: ReDim Output(1 To Book.Names.Count, 1 To 3) '1列目:Nameオブジェクト,2列目:名前,3列目:参照範囲(Book or Sheet)
    Dim Name_    As String
    Dim K        As Long: K = 0
    Dim Scope    As String
    For Each NameCell In Book.Names
        If InStr(NameCell.RefersTo, "#REF!") = 0 And _
           NameCell.Visible = True And _
           InStr(NameCell.RefersTo, Sheet.Name & "!") > 0 Then
            
            If InStr(NameCell.Name, "!") = 0 Then
                Name_ = NameCell.Name
            Else
                Name_ = Split(NameCell.Name, "!")(1)
            End If
            
            If NameCell.ValidWorkbookParameter = True Then
                Scope = "Book"
            Else
                Scope = "Sheet"
            End If
            
            K = K + 1
            Set Output(K, 1) = NameCell
            Output(K, 2) = Name_
            Output(K, 3) = Scope
        End If
    Next
    
    If K = 0 Then
        Output = Empty
    Else
        Output = ExtractArray2D(Array2D:=Output, EndRow:=K)
    End If
    
    GetNamedCellInSheet = Output
    
End Function

Private Function ExtractArray2D(ByRef Array2D As Variant, _
                     Optional ByRef StartRow As Long = 1, _
                     Optional ByRef StartCol As Long = 1, _
                       Optional ByRef EndRow As Long = 0, _
                       Optional ByRef EndCol As Long = 0) _
                                             As Variant
                       
'二次元配列の指定範囲を配列として抽出する
'20210917
'20211102 抽出範囲をデフォルト値設定が可能に
'20220915 要素がオブジェクトでも対応可能
'https://www.softex-celware.com/post/extractarray2d

'引数
'Array2D   ・・・二次元配列
'[StartRow]・・・抽出範囲の開始行番号/省略なら1
'[StartCol]・・・抽出範囲の開始列番号/省略なら1
'[EndRow]  ・・・抽出範囲の終了行番号/省略なら最大行番号
'[EndCol]  ・・・抽出範囲の終了列番号/省略なら最大列番号
                                  
'返り値
'指定の範囲が抽出された二次元配列
                                  
    '引数チェック
    If IsArray2D(Array2D) = False Then Exit Function       '二次元配列かチェック
    If IsArray2DStart1(Array2D) = False Then Exit Function '開始要素番号が1かチェック
    
    Dim I As Long
    Dim J As Long
    Dim N As Long: N = UBound(Array2D, 1) '行数
    Dim M As Long: M = UBound(Array2D, 2) '列数
    
    '終了行、列の設定
    If EndRow = 0 Then
        EndRow = N
    End If
    
    If EndCol = 0 Then
        EndCol = M
    End If
    
    If StartRow > EndRow Then
        MsgBox "抽出範囲の開始行「StartRow」は、" & _
               "終了行「EndRow」以下でなければなりません", vbExclamation
        Stop
        Exit Function
    ElseIf StartCol > EndCol Then
        MsgBox "抽出範囲の開始列「StartCol」は、" & _
                "終了列「EndCol」以下でなければなりません", vbExclamation
        Stop
        Exit Function
    ElseIf StartRow < 1 Then
        MsgBox "抽出範囲の開始行「StartRow」は" & _
               "1以上の値を入れてください", vbExclamation
        Stop
        Exit Function
    ElseIf StartCol < 1 Then
        MsgBox "抽出範囲の開始列「StartCol」は" & _
               "1以上の値を入れてください", vbExclamation
        Stop
        Exit Function
    ElseIf EndRow > N Then
        MsgBox "抽出範囲の終了行「EndRow」は" & _
               "抽出元の二次元配列の行数" & N & _
               "以下の値を入れてください", vbExclamation
        Stop
        Exit Function
    ElseIf EndCol > M Then
        MsgBox "抽出範囲の終了列「EndCol」は" & _
               "抽出元の二次元配列の列数" & M & _
               "以下の値を入れてください", vbExclamation
        Stop
        Exit Function
    End If
    
    '処理
    Dim Output As Variant
    ReDim Output(1 To EndRow - StartRow + 1, _
                 1 To EndCol - StartCol + 1)
    
    For I = StartRow To EndRow
        For J = StartCol To EndCol
            If IsObject(Array2D(I, J)) = True Then '20220915
                Set Output(I - StartRow + 1, J - StartCol + 1) _
                    = Array2D(I, J)
            Else
                Output(I - StartRow + 1, J - StartCol + 1) _
                = Array2D(I, J)
            End If
        Next J
    Next I
    
    '出力
    ExtractArray2D = Output
    
End Function

Private Function IsArray2D(ByRef Array2D As Variant, _
               Optional ByRef ArrayName As String = "Array2D") _
                                        As Boolean
'入力配列が二次元配列かどうかチェックする
'20210804
'20220309 変数名変更
'20241230 Functionプロシージャにして判定結果を返す
'https://www.softex-celware.com/post/isarray1d

'引数
'Array2D    ・・・チェックする配列
'[ArrayName]・・・エラーメッセージで表示する時の名前

    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 & "は二次元配列を入力してください", vbExclamation
        Stop 'エラーを確認するために一度停止する
        Exit Function 'Falseが返ってくる
    End If
    
    '出力
    IsArray2D = True
    
End Function

Private Function IsArray2DStart1(ByRef Array2D As Variant, _
                     Optional ByRef ArrayName As String = "Array2D") _
                                              As Boolean
'入力二次元配列の開始番号が1かどうかチェックする
'20210804
'20220309 変数名変更
'20241230 Functionプロシージャにして判定結果を返す
'https://www.softex-celware.com/post/isarray1d

'引数
'Array2D    ・・・チェックする二次元配列
'[ArrayName]・・・エラーメッセージで表示する時の名前

    If LBound(Array2D, 1) <> 1 Or LBound(Array2D, 2) <> 1 Then
        MsgBox ArrayName & "の開始要素番号は1にしてください", vbExclamation
        Stop 'エラーを確認するために一度停止する
        Exit Function 'Falseが返ってくる
    End If
    
    '出力
    IsArray2DStart1 = True

End Function

Private Sub ClipText(ByVal Text As String)
'テキストをクリップボードに格納
'テキストが配列ならば列方向をTab区切り、行方向を改行
'https://www.softex-celware.com/post/cliptext
'20251007 テキストのみの処理に変更

'引数
'Text・・・クリップボードに格納するテキスト
    
    'クリップボードに格納
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True
        .Text = Text
        .SelStart = 0
        .SelLength = .TextLength
        .Copy
    End With
    
End Sub

Private Sub ShowVBE()
'VBEを表示する
'20251007

    Application.CommandBars.ExecuteMso "VisualBasic"
End Sub

Private Sub ShowImmediateWindow()
'イミディエイトウィンドウを表示する
'20251007

    'メインウィンドウを見える化＆フォーカス
    With Application.VBE.MainWindow
        .Visible = True
        .SetFocus
    End With

    'イミディエイトを探して表示
    Dim Window As Object
    For Each Window In Application.VBE.Windows
        On Error Resume Next
        If Window.Type = vbext_wt_Immediate Then 'イミディエイトウィンドウである
            Window.Visible = True
            Window.SetFocus            '前面に
            Exit For
        End If
        On Error GoTo 0
    Next
End Sub

Private Sub ShowCodeWindowDelay()
'少し送らせてから「ShowCodeWindow」を実行する
'イミディエイトウィンドウから実行する場合はこの処理を行わないとイミディエイトウィンドウに残ったままになる
'20251007
    
'    Dim Time_    As Date: Time_ = Now() + TimeSerial(0, 0, 1) / 100'少し遅らせる
    Dim Time_    As Date: Time_ = Now() '検証したらこれでも上手くいく。理由はわからん。
    Dim BookName As String: BookName = ThisWorkbook.Name
    Dim ProcName As String: ProcName = "ShowCodeWindow"
    Dim FullProc As String: FullProc = BookName & "!" & ProcName
    
    Call Application.OnTime(EarliestTime:=Time_, Procedure:=FullProc, Schedule:=True)
    
End Sub

Private Sub ShowVBEOfModule(ByRef ModuleName As String, _
                        Optional ByRef Book As Workbook, _
                     Optional ByRef ShowRow As Enum_ModuleShowRow = Enum_ModuleShowRow.vbModuleEnd, _
                     Optional ByRef CodeStr As String)
'指定のモジュールのVBE(コードウィンドウ)を表示する
'20230808

'引数
'ModuleName・・・モジュール名
'[Book]    ・・・対象ブック/省略ならActiveWorkbook
'[ShowRow] ・・・表示位置のオプション
'[CodeStr] ・・・表示位置をコード検索であればその検索させるコードの1行

    If Book Is Nothing Then
        Set Book = ActiveWorkbook
    End If
    
    Dim Dict_Component As Dictionary:  Set Dict_Component = GetAllCodeModuleInBook(Book)
    Dim Component      As VBComponent: Set Component = Dict_Component(ModuleName)
    Dim CodePane       As CodePane:    Set CodePane = Component.CodeModule.CodePane
    
    '表示行を計算
    Dim Row     As Long
    Dim AllCode As Variant
    Dim I       As Long
    Dim Str     As String
    Dim Col     As Long
    Select Case ShowRow
        Case Enum_ModuleShowRow.vbModuleStart
            Row = 1
            Col = 1
        Case Enum_ModuleShowRow.vbModuleEnd
            Row = Component.CodeModule.CountOfLines + 1
            Col = 1
        Case Enum_ModuleShowRow.vbByCodeStr
            AllCode = Get__AllCodeInModule(Component)
            For I = 1 To UBound(AllCode, 1)
                Str = AllCode(I)
                If InStr(Str, CodeStr) > 0 Then
                    Row = I + 1 '1つ下のCallの所を選択
                    Exit For
                End If
            Next
            If Row = 0 Then 'モジュール内に指定のコードが見つからなかったら最終行
                Row = Component.CodeModule.CountOfLines + 1
                Col = 1
            Else
                Col = 10 'Callで実行しているプロシージャの位置
            End If
    End Select
    
    'コードウィンドウ表示
    With CodePane
        .Show
        .SetSelection Row, Col, Row, Col
    End With
End Sub

Private Function GetAllCodeModuleInBook(Book As Workbook) As Dictionary
'指定ブックの全VBComponentを取得して連想配列に格納
'20230808

'引数
'Book・・・対象ブック

    Dim Project   As VBProject: Set Project = Book.VBProject 'ブックのVBProject
    Dim Component As VBComponent
    Dim Output    As New Dictionary
    For Each Component In Project.VBComponents
        Output.Add Component.Name, Component
    Next
        
    Set GetAllCodeModuleInBook = Output
End Function

Private Function Get__AllCodeInModule(Component As VBComponent) As Variant
'指定モジュール（VBComponent）内の全コードを取得する
'20230808

'引数
'Component・・・モジュールのVBComponent

    Dim I      As Long
    Dim N      As Long: N = Component.CodeModule.CountOfLines
    Dim Output As Variant: ReDim Output(1 To N)
    For I = 1 To N
        Output(I) = Component.CodeModule.Lines(I, 1)
    Next
    
    Get__AllCodeInModule = Output
    
End Function

Public Sub ShowCodeWindow()
'コードウィンドウを表示する
'20251007

    'イミディエイトを探して表示
    Dim Window As Object
    For Each Window In Application.VBE.Windows
        On Error Resume Next
        If Window.Type = vbext_wt_CodeWindow And Window.WindowState = vbext_ws_Maximize Then
            'コードウィンドウかつ最大表示のものを条件とする
            On Error GoTo 0
'            Debug.Print Window.Caption'開発確認用
            'コードウィンドウかつ、最大表示状態のもの
            Window.Visible = True
            Window.SetFocus '前面に
            Exit For
        End If
        On Error GoTo 0
    Next
End Sub