EXCEL VBAのフォームのオブジェクト一覧を自動作成（改良版）

VBAフォーム定義

VBAのユーザーフォームの定義表を作成するツールです。
機能は前回と同じですがプログラムを整理して、少し短くし分かり易く直しやすくしました。
対象のエクセルブックを開きますので、自己責任で注意して使ってください。

分析結果(例）

プログラム

定数・変数

Option Explicit
Option Base 1 '配列添え字は１から始める

'定数、変数
Const TITLE_ROW = 2  '項目名の行位置
Const MAX_COL = 18  '項目数
Dim Titles As Variant   '項目名の配列
Dim Widths As Variant   '列幅の配列

Dim bookName As String  '分析対象ワークブック
Dim outWorkbook As Workbook  '分析結果出力ワークブック

メイン処理

'----------------------------------------------------------------------------
'フォームのコントロールの種類、名前などを新規ブックの各シートに出力（メイン処理）
'----------------------------------------------------------------------------
Public Sub makeFormDocument()

    '新規ワークブックに出力する
    Set outWorkbook = Workbooks.Add
    '分析対象のワークブックを選択する
    bookName = openVBAFILE
    '選択しなければ終了
    If bookName = "" Then Exit Sub
  
    '項目名の配列を設定
    Titles = Array("フォーム名", "型名", "名前", "IMEモード", "キャプション", "可視", _
                "使用可", "使用可", "カラム数", "カラム幅", "使用カラム", "表示カラム" _
                , "上位置", "左位置", "高さ", "幅", "タブインデックス", "タブインデックス")
    '列幅の配列を設定
    Widths = Array(10, 10, 20, 8, 20, 6, 6, 6, 6, 10, 6, 6, 6, 6, 6, 6, 6, 6)
    
    '各モジュールを分析する
    Dim xlModule As Object
    For Each xlModule In Workbooks(bookName).VBProject.VBComponents
          
        If xlModule.Type = 3 Then
            'ユーザーフォームならオブジェクト定義一覧表シートを作成する
            Call getFormControls(xlModule)
            
        End If
        
    Next xlModule
    
    If bookName <> ThisWorkbook.Name Then Workbooks(bookName).Close False
    
    Windows(ThisWorkbook.Name).Activate
    Windows(outWorkbook.Name).Activate

End Sub

各フォーム毎の処理

'------------------------------------------------------------------
'オブジェクト定義一覧表ワークシートを作成する
'------------------------------------------------------------------
Private Sub getFormControls(ByVal fom As Object)
    'ワークシートを追加（シート名はフォーム名）
    Worksheets.Add after:=ActiveSheet
    outWorkbook.ActiveSheet.Name = fom.Name
    With outWorkbook.ActiveSheet
    
    '項目名行を設定
    Dim J As Long
    For J = 1 To UBound(Titles)
        .Cells(TITLE_ROW, J).Value = Titles(J)
        .Cells(TITLE_ROW, J).ColumnWidth = Widths(J)
    Next J
    
    Dim myCtrl As Object
    Dim I As Long
    I = TITLE_ROW

    '各コントーロールを分析し１行出力する
    For Each myCtrl In fom.Designer.Controls
    
        I = I + 1
        
        'Typeによっては、存在しないプロパティもあるのでエラーなら飛ばす
        On Error Resume Next

        '各項目を取得し表示する
        .Cells(I, 1) = fom.Name             'フォーム名
        .Cells(I, 2) = TypeName(myCtrl)     '型名
        .Cells(I, 3) = myCtrl.Name          '型名
        .Cells(I, 4) = fg_imeMode(myCtrl.IMEMode)  'IMEモード
        .Cells(I, 5) = myCtrl.Caption       'キャプション
        .Cells(I, 6) = myCtrl.Visible       '可視
        .Cells(I, 7) = myCtrl.Enabled       '使用可
        .Cells(I, 8) = myCtrl.Locked        'ロック
        .Cells(I, 9) = myCtrl.columncount   'カラム数
        .Cells(I, 10) = myCtrl.columnwidths 'カラム幅
        .Cells(I, 11) = myCtrl.boundcolumn  '使用カラム
        .Cells(I, 12) = myCtrl.textcolumn   '表示カラム
        .Cells(I, 13) = myCtrl.Top          '上位置
        .Cells(I, 14) = myCtrl.Left         '左位置
        .Cells(I, 15) = myCtrl.Height       '高さ
        .Cells(I, 16) = myCtrl.Width        '幅
        .Cells(I, 17) = myCtrl.tabindex     'タブインデックス
        .Cells(I, 18) = myCtrl.tabstop      'タブストップ
    Next
    
    '型名(2)、名前順(3)にソートする
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=.Cells(TITLE_ROW, 2), Order:=xlAscending
    .Sort.SortFields.Add Key:=.Cells(TITLE_ROW, 3), Order:=xlAscending
    .Sort.SetRange .Range(.Cells(TITLE_ROW, 1), .Cells(I, MAX_COL))
    .Sort.Header = xlYes
    .Sort.Apply
    
    'オートフィルター設定
    .Range("B2").AutoFilter
    
    'ウインドウ枠固定
    Range("D3").Select
    ActiveWindow.FreezePanes = True
    '項目名は折り返し表示
    .Range(Cells(TITLE_ROW, 1), Cells(TITLE_ROW, MAX_COL)).WrapText = True
    '縮小表示
    .Range(Cells(TITLE_ROW + 1, 2), Cells(I, 3)).ShrinkToFit = True
    '折り返し表示
    .Range(Cells(TITLE_ROW + 1, 4), Cells(I, MAX_COL)).WrapText = True
    '罫線を引く
    .Range(Cells(TITLE_ROW, 1), Cells(I, MAX_COL)).Borders.LineStyle = xlContinuous
    'タイトル設定
    .Cells(1, 3).Value = bookName & "(" & Format(Now, "YYYY/MM/DD") & ")"
     '印刷範囲設定
    .PageSetup.PrintArea = .Range(Cells(1, 1), Cells(I, MAX_COL)).Address
    
   End With

End Sub

対象ファイルオープン

'------------------------------------------------------------------
'対象ファイルをオープンしてファイル名を返す
'------------------------------------------------------------------
Private Function openVBAFILE() As String

    Dim targetFileName As String
    
    targetFileName = Application.GetOpenFilename("マクロ有効　EXCELブック, *.xlsm")
    If targetFileName = "False" Then Exit Function
    
    Application.EnableEvents = False
    Workbooks.Open targetFileName, ReadOnly:=True
    Application.EnableEvents = True
    
    If Not (ActiveWindow Is Nothing) Then
        ActiveWindow.Visible = False
    End If
    openVBAFILE = Mid(targetFileName, InStrRev(targetFileName, "\") + 1)
 
End Function

IMEモード（数字）を日本語

'------------------------------------------------------------------
'IMEモード（数字）を日本語にして返す
'------------------------------------------------------------------
Private Function fg_imeMode(ByVal ime As String) As String

    If IsNull(ime) Then
          fg_imeMode = ""
          Exit Function
    End If
    
    Select Case ime
        Case "0"
           fg_imeMode = "制御なし"
        Case "1"
          fg_imeMode = "オン"
        Case "2"
          fg_imeMode = "オフ英語モード"
        Case "3"
          fg_imeMode = "使用不可"
        Case "4"
          fg_imeMode = "全角ひらがな"
        Case "5"
          fg_imeMode = "全角カタカナカタカナ"
        Case "6"
          fg_imeMode = "半角カタカナ"
        Case "7"
          fg_imeMode = "全角英数字"
        Case "8"
          fg_imeMode = "半角英数字"
        Case Else
           fg_imeMode = ""
    End Select
 
End Function