VBAフォーム定義
VBAのユーザーフォームの定義表を作成するツールです。
対象のエクセルブックを開きますので、自己責任で注意して使ってください。
IMEモードをコード番号から日本語にしたものを掲載します。
型名順、名前順にソート設定が間違っていたので直しました。
.Sort.SortFields.Add Key:= とすべきところを
.Sort.SortFields.Add Keys:= としていました。
このまちがいはコンパイルエラーにも実行時エラーにもならないので困りますね。
見当たらないけど一覧表に出るコントロール
著作権の関係で現物を載せられないのですが、あるフォームの定義表をこのツールで作成したら、クリックしても見つからないオプションボタンが出てくるのですが、出来ればDELETEしたいと思います。作り直す以外で何かいい方法があれば教えて下さい。
出力例
プログラム
Option Explicit
'定数、変数
Const TITLE_ROW = 2
'下記項目の列位置表
Enum F_COL
左端 = 1
フォーム名
型名
名前
IMEモード
キャプション
可視
使用可
ロック
カラム数
カラム幅
使用カラム
表示カラム
上位置
左位置
高さ
幅
タブインデックス
タブストップ
End Enum
Const MAX_COL = 19
Dim I As Long
Dim bookName As String
Dim outWorkbook As Workbook
'--------------------------------------------------------------------------------
'フォームのコントロールの種類、名前などを新規ブックの各シートに出力（メイン処理）
'--------------------------------------------------------------------------------
Public Sub makeFormDocument()
'新規ワークブックに出力する
Set outWorkbook = Workbooks.Add
'分析対象のワークブックを選択する
bookName = openVBAFILE
'選択しなければ終了
If bookName = "" Then Exit Sub
'各モジュールを分析する
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)
Dim myCtrl As Object
I = TITLE_ROW
Worksheets.Add after:=ActiveSheet
outWorkbook.ActiveSheet.Name = fom.Name
With outWorkbook.ActiveSheet
.Cells(I, F_COL.フォーム名) = "フォーム名"
.Cells(I, F_COL.型名) = "型名"
.Cells(I, F_COL.名前) = "名前"
.Cells(I, F_COL.IMEモード) = "IMEモード"
.Cells(I, F_COL.キャプション) = "キャプション"
.Cells(I, F_COL.可視) = "可視"
.Cells(I, F_COL.使用可) = "使用可"
.Cells(I, F_COL.ロック) = "ロック"
.Cells(I, F_COL.カラム数) = "カラム数"
.Cells(I, F_COL.カラム幅) = "カラム幅"
.Cells(I, F_COL.使用カラム) = "使用カラム"
.Cells(I, F_COL.表示カラム) = "表示カラム"
.Cells(I, F_COL.上位置) = "上位置"
.Cells(I, F_COL.左位置) = "左位置"
.Cells(I, F_COL.高さ) = "高さ"
.Cells(I, F_COL.幅) = "幅"
.Cells(I, F_COL.タブインデックス) = "タブインデックス"
.Cells(I, F_COL.タブストップ) = "タブストップ"
' 列幅設定
.Cells(I, F_COL.フォーム名).ColumnWidth = 10
.Cells(I, F_COL.型名).ColumnWidth = 10
.Cells(I, F_COL.名前).ColumnWidth = 20
.Cells(I, F_COL.IMEモード).ColumnWidth = 8
.Cells(I, F_COL.キャプション).ColumnWidth = 20
.Cells(I, F_COL.可視).ColumnWidth = 6
.Cells(I, F_COL.使用可).ColumnWidth = 6
.Cells(I, F_COL.ロック).ColumnWidth = 6
.Cells(I, F_COL.カラム数).ColumnWidth = 6
.Cells(I, F_COL.カラム幅).ColumnWidth = 10
.Cells(I, F_COL.使用カラム).ColumnWidth = 6
.Cells(I, F_COL.表示カラム).ColumnWidth = 6
.Cells(I, F_COL.上位置).ColumnWidth = 6
.Cells(I, F_COL.左位置).ColumnWidth = 6
.Cells(I, F_COL.高さ).ColumnWidth = 6
.Cells(I, F_COL.幅).ColumnWidth = 6
.Cells(I, F_COL.タブインデックス).ColumnWidth = 6
.Cells(I, F_COL.タブストップ).ColumnWidth = 6
For Each myCtrl In fom.Designer.Controls
I = I + 1
'Typeによっては、存在しないプロパティもあるのでエラーなら飛ばす
On Error Resume Next
.Range(.Cells(I, 1), .Cells(I, F_COL.タブストップ)).ClearContents
.Cells(I, F_COL.フォーム名) = fom.Name
.Cells(I, F_COL.型名) = TypeName(myCtrl)
.Cells(I, F_COL.名前) = myCtrl.Name
.Cells(I, F_COL.IMEモード) = fg_imeMode(myCtrl.IMEMode) ' 20241224UPDATE
.Cells(I, F_COL.キャプション) = myCtrl.Caption
.Cells(I, F_COL.可視) = myCtrl.Visible
.Cells(I, F_COL.使用可) = myCtrl.Enabled
.Cells(I, F_COL.ロック) = myCtrl.Locked
.Cells(I, F_COL.カラム数) = myCtrl.columncount
.Cells(I, F_COL.カラム幅) = myCtrl.columnwidths
.Cells(I, F_COL.使用カラム) = myCtrl.boundcolumn
.Cells(I, F_COL.表示カラム) = myCtrl.textcolumn
.Cells(I, F_COL.上位置) = myCtrl.Top
.Cells(I, F_COL.左位置) = myCtrl.Left
.Cells(I, F_COL.高さ) = myCtrl.Height
.Cells(I, F_COL.幅) = myCtrl.Width
.Cells(I, F_COL.タブインデックス) = myCtrl.tabindex
.Cells(I, F_COL.タブストップ) = myCtrl.tabstop
Next
'ソートする（なぜかうまくソートされてない？）
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Cells(TITLE_ROW, F_COL.型名), Order:=xlAscending
.Sort.SortFields.Add Key:=.Cells(TITLE_ROW, F_COL.名前), Order:=xlAscending
.Sort.SetRange .Range(.Cells(TITLE_ROW, F_COL.左端), .Cells(I, F_COL.タブストップ))
.Sort.Header = xlYes
.Sort.Apply
'オートフィルター設定
.Range("B2").AutoFilter
'ウインドウ枠固定
Range("E3").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, 2), Cells(I, MAX_COL)).Borders.LineStyle = xlContinuous
'タイトル設定
.Cells(1, 3).Value = bookName & "(" & Format(Now, "YYYY/MM/DD") & ")"
'印刷範囲設定
.PageSetup.PrintArea = .Range(Cells(1, 2), 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モードを日本語化
MEモードをコード番号から日本語にしたものを掲載します。
'------------------------------------------------------------------
'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
出力例
