ExcelVBAでディレクトリ階層図作成を作成するツールです。Windowsでしか動作確認していないです。
以下のようにシート出力します。新規ブックとして切り離して出力します。
使い方説明
使い方については、以下の画像を参照してください。
処理の実行
以下のように適当にオブジェクトを作成し、ShowFormのマクロを登録して下さい
ユーザーフォームのコントロール名
1: SettingForm
2: btnSelectFolder
3: txtTargetFolder
4: txtPathOutput
5: txtFolderNameFileNameOutput
6: txtClassifyOutput
7: txtSizeOutput
8: txtLastUpdateOutput
9: txtClassMapStart
10: chkSearchSubFolder
11: chkColoredFolderFile
12: chkAddHyperLinkToPath
13: chkExtension1 右隣が2、下が3、24まで
14: txtExtension1 右隣が2、下が3、24まで
15: chkNotSpecifyExtension
16: btnClearExtension
17: btnExecute
18: btnClose
SettingFormのコード
Option Explicit
Private Enum SETTING '各種の固定設定値を格納するEnum
titleOutputRow = 1 '階層図のタイトル部分を出力する行番号
classMapOutputFirstRow = 2 '階層図部分を出力する最初の行番号
coloredLasColumn = 1000
' 「フォルダとファイルで色分け」が有効の場合、暫定でセル色を変更する範囲の最後の列番号
' この範囲を超えた部分はセル色が変更されないので、大き目の数値で
maxSpecifyColumn = 100 '「パス」、「フォルダ名・ファイル名」等の出力列指定の最大値
notOutput = 0 ' 各種設定項目で、無効の場合は0とする
alertFileAndFolderCount = 50000
'指定フォルダ以下にある、フォルダ数とファイル数の合計が、この数値以上になったら警告を出す
maxFolderPathLength = 230 '階層図を作成するフォルダのパスの最大文字数
maxExtensionLength = 20 '指定する拡張子の最大文字数
End Enum
Private objFSO As FileSystemObject ' FSO
Private wsJikkou As Worksheet ' 「実行」シート
Private wsOutput As Worksheet ' 階層図出力シート
Private lngMaxDataColumn As Long ' データのある最大列
Private lngMaxDataRow As Long ' データのある最大行
Private lngCurrentOutputRow As Long ' 出力シートの現在の出力する行番号
Private strTopFolderPath As String ' 階層図作成の基点となるフォルダのパス
Private arrExtension() As String ' 出力するファイルの拡張子を格納する配列
Private lngPathOutputColumn As Long ' 「パス」を出力する列番号
Private lngNameOutputColumn As Long ' 「フォルダ名・ファイル名」を出力する列番号
Private lngClassifyOutputColumn As Long ' 「種別」を出力する列番号
Private lngSizeOutputColumn As Long ' 「サイズ」を出力する列番号
Private lngLastUpdateOutputColumn As Long ' 「最終更新日時」を出力する列番号
Private lngClassMapOutputFirstColumn As Long ' 階層図の作成を始める列番号
Private isSearchSubFolder As Boolean ' 「サブフォルダも検索する」のフラグ
Private isColoredFolderFile As Boolean ' 「フォルダとファイルで色分け」のフラグ
Private isAddHyperLink As Boolean ' 「パスにハイパーリンクを付与」のフラグ
Private isSpecifyExtension As Boolean ' 「出力するファイル種別を指定する」のフラグ
Private lngOutputColumnInCaseFolder As Long ' フォルダの場合の出力列
Private lngOutputColumnInCaseFile As Long ' ファイルの場合の出力列
Private strSortString As String ' パスのソート用文字列
Private lngYenPosition As Long ' パスの文字列内の「￥」の位置
Private lngFileCount As Long '指定フォルダ以下にある、ファイル数の合計
Private lngFolderCount As Long '指定フォルダ以下にある、フォルダ数の合計
' ************ 階層図作成処理 ***************************************************************
Private Sub CreateClassMapMain()
On Error GoTo CreateClassMapMain_ErrorHandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ThisWorkbook.Activate
Call SetupInitialValue ' 初期値を設定する処理
'入力内容のチェック
If ValidateInputs = False Then '入力内容に問題があった場合
Call LastProcess ' 最終的に実行する処理を呼び出し
Exit Sub
End If
'指定フォルダ以下にある、フォルダ数とファイル数の合計を取得
lngFileCount = objFSO.GetFolder(strTopFolderPath).Files.Count '直下にあるファイル数を取得
Call GetFileCountAndFolderCount(strTopFolderPath)
'サブフォルダ以下のフォルダ数、ファイル数を取得する処理を呼び出し
If lngFileCount + lngFolderCount >= SETTING.alertFileAndFolderCount Then
'フォルダ数とファイル数の合計が既定値以上である場合は、警告を出して処理続行を確認する
Dim msgResult As VbMsgBoxResult
msgResult = MsgBox("指定フォルダ以下にある、フォルダ数とファイル数の合計が" _
& SETTING.alertFileAndFolderCount & "以上になっています" & vbCrLf & _
"(合計で" & (lngFileCount + lngFolderCount) & "あります)" & vbCrLf & _
"このまま実行すると途中で処理が中断される可能性があります" & vbCrLf & _
"続行しますか？", vbYesNo)
If msgResult = vbNo Then
MsgBox "処理を中断します"
Call LastProcess
Exit Sub
End If
End If
Call SetupOutputSheet ' 出力シートのセットアップ処理の呼び出し
Call FileAndFolderSearch(strTopFolderPath, lngOutputColumnInCaseFolder, lngOutputColumnInCaseFile)
' ファイル・フォルダの検索処理を呼び出し
Call AdjustOutputSheet ' 出力シートの調整処理の呼び出し
Call LastProcess
階層図作成.Activate
MsgBox "完了"
Exit Sub
CreateClassMapMain_ErrorHandler:
If Err.Number <> 514 Then '他のプロシージャ・関数が再スローしたエラー番号ではない場合
MsgBox "階層図作成処理でエラーが発生したため、処理を中断します"
End If
Call LastProcess ' 最終的に実行する処理を呼び出し
Exit Sub
End Sub
' ************ 初期値設定処理 ******************************************************************
Private Sub SetupInitialValue()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set wsJikkou = 階層図作成
Set wsOutput = Nothing
lngMaxDataColumn = 1
lngMaxDataRow = 1
lngCurrentOutputRow = 1
strTopFolderPath = ""
Erase arrExtension
ReDim arrExtension(0)
lngPathOutputColumn = SETTING.notOutput
lngNameOutputColumn = SETTING.notOutput
lngClassifyOutputColumn = SETTING.notOutput
lngSizeOutputColumn = SETTING.notOutput
lngLastUpdateOutputColumn = SETTING.notOutput
lngClassMapOutputFirstColumn = SETTING.notOutput
isSearchSubFolder = False
isColoredFolderFile = False
isAddHyperLink = False
isSpecifyExtension = False
lngOutputColumnInCaseFolder = 1
lngOutputColumnInCaseFile = 1
strSortString = ""
lngYenPosition = 1
lngFileCount = 0
lngFolderCount = 0
'サブフォルダも検索するか
If Me.chkSearchSubFolder.Value Then
isSearchSubFolder = True
End If
'フォルダとファイルで色分けするか
If Me.chkColoredFolderFile.Value Then
isColoredFolderFile = True
End If
'パスにハイパーリンクを付与するか
If Me.chkAddHyperLinkToPath.Value Then
isAddHyperLink = True
End If
'拡張子を限定するか
If Me.chkNotSpecifyExtension.Value = False Then
isSpecifyExtension = True
End If
End Sub
' ************ 入力内容のチェック処理 **********************************************************
Private Function ValidateInputs() As Boolean
Dim arrOutputColumn() As Long ' 出力列の指定内容を格納する配列
Dim i As Long
ValidateInputs = True
ReDim arrOutputColumn(0)
strTopFolderPath = Me.txtTargetFolder '階層図を作成するフォルダのパス
If strTopFolderPath = "" Then
MsgBox "階層図を作成するフォルダの指定がありません"
ValidateInputs = False
Exit Function
End If
If Left(strTopFolderPath, 1) = "." Then
MsgBox "階層図を作成するフォルダのパスは、「.」で始まるものにしないで下さい"
ValidateInputs = False
Exit Function
End If
If Left(strTopFolderPath, 1) = "\" Then
MsgBox "階層図を作成するフォルダのパスは、「\」で始まるものにしないで下さい"
ValidateInputs = False
Exit Function
End If
If Left(strTopFolderPath, 1) = "/" Then
MsgBox "階層図を作成するフォルダのパスは、「/」で始まるものにしないで下さい"
ValidateInputs = False
Exit Function
End If
If Len(strTopFolderPath) > SETTING.maxFolderPathLength Then
MsgBox "階層図を作成するフォルダのパスは" & SETTING.maxFolderPathLength & "文字までにしてください"
ValidateInputs = False
Exit Function
End If
If objFSO.FolderExists(strTopFolderPath) = False Then
MsgBox "階層図を作成するフォルダに指定されたフォルダは存在しません"
ValidateInputs = False
Exit Function
Else
If Right(strTopFolderPath, 1) <> "\" Then ' パスの最後に￥が無い場合は、￥を付け足す
strTopFolderPath = strTopFolderPath & "\"
End If
End If
If Me.txtPathOutput.Text <> "" Then '「パス」の出力列の指定がある場合
If IsNumeric(Me.txtPathOutput.Text) = False Then
MsgBox "「パス」の出力列の指定は数値にしてください"
ValidateInputs = False
Exit Function
End If
If Me.txtPathOutput.Text > SETTING.maxSpecifyColumn Then
MsgBox "「パス」の出力列の指定は" & SETTING.maxSpecifyColumn & "以下にして下さい"
ValidateInputs = False
Exit Function
End If
If Me.txtPathOutput.Text < 1 Then
MsgBox "「パス」の出力列の指定は1以上にしてください"
ValidateInputs = False
Exit Function
End If
lngPathOutputColumn = CLng(WorksheetFunction.RoundDown(CDbl(Me.txtPathOutput.Text), 0))
arrOutputColumn(UBound(arrOutputColumn)) = lngPathOutputColumn
ReDim Preserve arrOutputColumn(UBound(arrOutputColumn) + 1)
End If
If Me.txtFolderNameFileNameOutput.Text <> "" Then '「フォルダ名・ファイル名」の出力列の指定がある場合
If IsNumeric(Me.txtFolderNameFileNameOutput.Text) = False Then
MsgBox "「フォルダ名・ファイル名」の出力列の指定は数値にしてください"
ValidateInputs = False
Exit Function
End If
If Me.txtFolderNameFileNameOutput.Text > SETTING.maxSpecifyColumn Then
MsgBox "「フォルダ名・ファイル名」の出力列の指定は" & SETTING.maxSpecifyColumn & "以下にして下さい"
ValidateInputs = False
Exit Function
End If
If Me.txtFolderNameFileNameOutput.Text < 1 Then
MsgBox "「フォルダ名・ファイル名」の出力列の指定は1以上にしてください"
ValidateInputs = False
Exit Function
End If
lngNameOutputColumn = CLng(WorksheetFunction.RoundDown(CDbl(Me.txtFolderNameFileNameOutput.Text), 0))
arrOutputColumn(UBound(arrOutputColumn)) = lngNameOutputColumn
ReDim Preserve arrOutputColumn(UBound(arrOutputColumn) + 1)
End If
If Me.txtClassifyOutput.Text <> "" Then '「種別」の出力列の指定がある場合
If IsNumeric(Me.txtClassifyOutput.Text) = False Then
MsgBox "「種別」の出力列の指定は数値にしてください"
ValidateInputs = False
Exit Function
End If
If Me.txtClassifyOutput.Text > SETTING.maxSpecifyColumn Then
MsgBox "「種別」の出力列の指定は" & SETTING.maxSpecifyColumn & "以下にして下さい"
ValidateInputs = False
Exit Function
End If
If Me.txtClassifyOutput.Text < 1 Then
MsgBox "「種別」の出力列の指定は1以上にしてください"
ValidateInputs = False
Exit Function
End If
lngClassifyOutputColumn = CLng(WorksheetFunction.RoundDown(CDbl(Me.txtClassifyOutput.Text), 0))
arrOutputColumn(UBound(arrOutputColumn)) = lngClassifyOutputColumn
ReDim Preserve arrOutputColumn(UBound(arrOutputColumn) + 1)
End If
If Me.txtSizeOutput.Text <> "" Then '「サイズ」の出力列の指定がある場合
If IsNumeric(Me.txtSizeOutput.Text) = False Then
MsgBox "「サイズ」の出力列の指定は数値にしてください"
ValidateInputs = False
Exit Function
End If
If Me.txtSizeOutput.Text > SETTING.maxSpecifyColumn Then
MsgBox "「サイズ」の出力列の指定は" & SETTING.maxSpecifyColumn & "以下にして下さい"
ValidateInputs = False
Exit Function
End If
If Me.txtSizeOutput.Text < 1 Then
MsgBox "「サイズ」の出力列の指定は1以上にしてください"
ValidateInputs = False
Exit Function
End If
lngSizeOutputColumn = CLng(WorksheetFunction.RoundDown(CDbl(Me.txtSizeOutput.Text), 0))
arrOutputColumn(UBound(arrOutputColumn)) = lngSizeOutputColumn
ReDim Preserve arrOutputColumn(UBound(arrOutputColumn) + 1)
End If
If Me.txtLastUpdateOutput.Text <> "" Then '「最終更新日時」の出力列の指定がある場合
If IsNumeric(Me.txtLastUpdateOutput.Text) = False Then
MsgBox "「最終更新日時」の出力列の指定は数値にしてください"
ValidateInputs = False
Exit Function
End If
If Me.txtLastUpdateOutput.Text > SETTING.maxSpecifyColumn Then
MsgBox "「最終更新日時」の出力列の指定は" & SETTING.maxSpecifyColumn & "以下にして下さい"
ValidateInputs = False
Exit Function
End If
If Me.txtLastUpdateOutput.Text < 1 Then
MsgBox "「最終更新日時」の出力列の指定は1以上にしてください"
ValidateInputs = False
Exit Function
End If
lngLastUpdateOutputColumn = CLng(WorksheetFunction.RoundDown(CDbl(Me.txtLastUpdateOutput.Text), 0))
arrOutputColumn(UBound(arrOutputColumn)) = lngLastUpdateOutputColumn
ReDim Preserve arrOutputColumn(UBound(arrOutputColumn) + 1)
End If
If Me.txtClassMapStart.Text <> "" Then '「階層図作成開始」の出力列の指定がある場合
If IsNumeric(Me.txtClassMapStart.Text) = False Then
MsgBox "「階層図作成開始」の出力列の指定は数値にしてください"
ValidateInputs = False
Exit Function
End If
If Me.txtClassMapStart.Text > SETTING.maxSpecifyColumn Then
MsgBox "「階層図作成開始」の出力列の指定は" & SETTING.maxSpecifyColumn & "以下にして下さい"
ValidateInputs = False
Exit Function
End If
If Me.txtClassMapStart.Text < 1 Then
MsgBox "「階層図作成開始」の出力列の指定は1以上にしてください"
ValidateInputs = False
Exit Function
End If
lngClassMapOutputFirstColumn = CLng(WorksheetFunction.RoundDown(CDbl(Me.txtClassMapStart.Text), 0))
arrOutputColumn(UBound(arrOutputColumn)) = lngClassMapOutputFirstColumn
ReDim Preserve arrOutputColumn(UBound(arrOutputColumn) + 1)
End If
If arrOutputColumn(0) = 0 Then
MsgBox "出力する列の指定が１つもありません"
ValidateInputs = False
Exit Function
End If
ReDim Preserve arrOutputColumn(UBound(arrOutputColumn) - 1) ' 最後の要素は削除
If IsOverlapping(arrOutputColumn) Then '重複をチェックするFunctionを呼び出し
MsgBox "出力列の指定に重複があります"
ValidateInputs = False
Exit Function
End If
' 「階層図作成開始」の出力指定列が最も大きいことのチェック
If lngClassMapOutputFirstColumn <> SETTING.notOutput Then
If lngPathOutputColumn > lngClassMapOutputFirstColumn Then
MsgBox "「パス」の出力指定列は「階層図作成開始」の出力指定列よりも小さい数値にしてください"
ValidateInputs = False
Exit Function
End If
If lngNameOutputColumn > lngClassMapOutputFirstColumn Then
MsgBox _
"「フォルダ名・ファイル名」の出力指定列は「階層図作成開始」の出力指定列よりも小さい数値にしてください"
ValidateInputs = False
Exit Function
End If
If lngClassifyOutputColumn > lngClassMapOutputFirstColumn Then
MsgBox "「種別」の出力指定列は「階層図作成開始」の出力指定列よりも小さい数値にしてください"
ValidateInputs = False
Exit Function
End If
If lngSizeOutputColumn > lngClassMapOutputFirstColumn Then
MsgBox "「サイズ」の出力指定列は「階層図作成開始」の出力指定列よりも小さい数値にしてください"
ValidateInputs = False
Exit Function
End If
If lngLastUpdateOutputColumn > lngClassMapOutputFirstColumn Then
MsgBox "「最終更新日時」の出力指定列は「階層図作成開始」の出力指定列よりも小さい数値にしてください"
ValidateInputs = False
Exit Function
End If
End If
'拡張子を限定するか
If Me.chkNotSpecifyExtension Then
isSpecifyExtension = False
Else
isSpecifyExtension = True
End If
If isSpecifyExtension = True Then
If SetExtensions = False Then '指定された拡張子を配列にセットする処理
MsgBox "有効な拡張子の指定が１つもありません"
ValidateInputs = False
Exit Function
End If
If IsOverStringLength(arrExtension, SETTING.maxExtensionLength) Then '規定文字数を超える拡張子の指定がある場合
MsgBox SETTING.maxExtensionLength & "文字を超える拡張子が指定されています。拡張子は" _
& SETTING.maxExtensionLength & "文字までにしてください"
ValidateInputs = False
Exit Function
End If
If IsOverlapping(arrExtension) Then '拡張子配列の要素に重複がある場合
MsgBox "拡張子の指定に重複があります"
ValidateInputs = False
Exit Function
End If
End If
End Function
' ************ 指定された拡張子を配列にセットする処理 ********************************************
Private Function SetExtensions() As Boolean
SetExtensions = True
If Me.chkExtension1.Value And Me.txtExtension1.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension1.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension2.Value And Me.txtExtension2.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension2.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension3.Value And Me.txtExtension3.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension3.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension4.Value And Me.txtExtension4.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension4.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension5.Value And Me.txtExtension5.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension5.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension6.Value And Me.txtExtension6.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension6.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension7.Value And Me.txtExtension7.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension7.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension8.Value And Me.txtExtension8.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension8.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension9.Value And Me.txtExtension9.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension9.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension10.Value And Me.txtExtension10.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension10.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension11.Value And Me.txtExtension11.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension11.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension12.Value And Me.txtExtension12.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension12.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension13.Value And Me.txtExtension13.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension13.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension14.Value And Me.txtExtension14.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension14.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension15.Value And Me.txtExtension15.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension15.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension16.Value And Me.txtExtension16.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension16.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension17.Value And Me.txtExtension17.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension17.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension18.Value And Me.txtExtension18.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension18.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension19.Value And Me.txtExtension19.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension19.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension20.Value And Me.txtExtension20.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension20.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension21.Value And Me.txtExtension21.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension21.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension22.Value And Me.txtExtension22.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension22.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension23.Value And Me.txtExtension23.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension23.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If Me.chkExtension24.Value And Me.txtExtension24.Value <> "" Then
arrExtension(UBound(arrExtension)) = Me.txtExtension24.Value
ReDim Preserve arrExtension(UBound(arrExtension) + 1)
End If
If arrExtension(0) = "" Then '第一要素が空の場合は、何も指定されていない
SetExtensions = False
Exit Function
End If
ReDim Preserve arrExtension(UBound(arrExtension) - 1) ' 最後の要素は削除
End Function
' ************ 指定フォルダ以下にある、フォルダ数とファイル数の合計を取得 ******************************************************************
Private Sub GetFileCountAndFolderCount(ByRef strFolderPath As String)
Dim folTarget As Folder
On Error GoTo GetFileCountAndFolderCount_ErrorHandler
For Each folTarget In objFSO.GetFolder(strFolderPath).SubFolders ' サブフォルダを取得する
lngFolderCount = lngFolderCount + 1 'フォルダ数をカウントアップ
If isSearchSubFolder Then 'サブフォルダも検索する場合
lngFileCount = lngFileCount + objFSO.GetFolder(folTarget.Path).Files.Count 'フォルダ内のファイル数を取得
Call GetFileCountAndFolderCount(folTarget.Path) ' 再帰処理でサブフォルダまで検索
End If
Next folTarget
Exit Sub
GetFileCountAndFolderCount_ErrorHandler:
MsgBox "指定フォルダ以下にある、フォルダ数とファイル数の合計を取得する処理実行時に" & _
"エラーが発生したため、処理を中断します"
Err.Raise 514
Exit Sub
End Sub
' ************ 出力シートのセットアップ処理 ****************************************************
Private Sub SetupOutputSheet()
ThisWorkbook.Worksheets.Add ' 新しいシートを追加し、このシートに階層図を作成
Set wsOutput = ActiveSheet
wsOutput.Name = "階層図"
With wsOutput ' 出力シートのタイトル部の設定
If lngPathOutputColumn <> SETTING.notOutput Then
.Cells(SETTING.titleOutputRow, lngPathOutputColumn) = "Path"
.Cells(SETTING.titleOutputRow, lngPathOutputColumn).Interior.Color = RGB(70, 137, 255)
End If
If lngNameOutputColumn <> SETTING.notOutput Then
.Cells(SETTING.titleOutputRow, lngNameOutputColumn) = "フォルダ名／ファイル名"
.Cells(SETTING.titleOutputRow, lngNameOutputColumn).Interior.Color = RGB(70, 137, 255)
End If
If lngClassifyOutputColumn <> SETTING.notOutput Then
.Cells(SETTING.titleOutputRow, lngClassifyOutputColumn) = "種別"
.Cells(SETTING.titleOutputRow, lngClassifyOutputColumn).Interior.Color = RGB(70, 137, 255)
End If
If lngSizeOutputColumn <> SETTING.notOutput Then
.Cells(SETTING.titleOutputRow, lngSizeOutputColumn) = "サイズ"
.Cells(SETTING.titleOutputRow, lngSizeOutputColumn).Interior.Color = RGB(70, 137, 255)
End If
If lngLastUpdateOutputColumn <> SETTING.notOutput Then
.Cells(SETTING.titleOutputRow, lngLastUpdateOutputColumn) = "最終更新日時"
.Cells(SETTING.titleOutputRow, lngLastUpdateOutputColumn).Interior.Color = RGB(70, 137, 255)
End If
If lngClassMapOutputFirstColumn <> SETTING.notOutput Then
.Cells(SETTING.titleOutputRow, lngClassMapOutputFirstColumn) = "ここから階層図"
.Cells(SETTING.titleOutputRow, lngClassMapOutputFirstColumn).Interior.Color = RGB(255, 199, 175)
End If
lngMaxDataColumn = wsOutput.Cells(SETTING.titleOutputRow, wsOutput.Columns.Count).End(xlToLeft).Column
wsOutput.Range(Cells(SETTING.titleOutputRow, 1), _
Cells(SETTING.titleOutputRow, lngMaxDataColumn)).Columns.AutoFit ' セル幅の自動調整
End With
' データのある最終列の変数の設定。階層図部分を出力するかどうかで異なる
If lngClassMapOutputFirstColumn <> SETTING.notOutput Then '階層図部分を出力する場合
lngOutputColumnInCaseFolder = lngClassMapOutputFirstColumn
lngOutputColumnInCaseFile = lngClassMapOutputFirstColumn + 1
Else
lngOutputColumnInCaseFolder = SETTING.notOutput
lngOutputColumnInCaseFile = SETTING.notOutput
End If
lngCurrentOutputRow = SETTING.classMapOutputFirstRow ' 現在の出力行を設定
End Sub
' ************ ファイル・フォルダの検索処理 *******************************************************
Private Sub FileAndFolderSearch(ByRef strTopFolderPath As String, _
ByVal lngOutputColumnInCaseFolder As Long, ByVal lngOutputColumnInCaseFile As Long)
Dim filTarget As File ' 調査対象となるファイル
Dim folTarget As Folder ' 調査対象となるフォルダ
Dim folSub As Folder ' サブフォルダ
Dim i As Long
Dim isMatchExtension As Boolean ' ファイルの拡張子が、指定されている拡張子と一致しているか
On Error GoTo FileAndFolderSearch_ErrorHandler
With objFSO
Set folTarget = .GetFolder(strTopFolderPath)
If isColoredFolderFile = True Then ' フォルダとファイルで色分けする場合
wsOutput.Range(Cells(lngCurrentOutputRow, 1), Cells(lngCurrentOutputRow, SETTING.coloredLasColumn)) _
.Interior.Color = RGB(204, 255, 255)
End If
Call OutputFolderInformation(folTarget, lngOutputColumnInCaseFolder) 'フォルダの情報を出力する処理を呼び出し
' フォルダ内のファイルのデータを出力
For Each filTarget In folTarget.Files
If isSpecifyExtension = True Then
' ファイル種別の指定がある場合
isMatchExtension = False
For i = 0 To UBound(arrExtension)
' 現在のfilTargetの拡張子が、指定されている拡張子の配列内に存在するかをチェック
If .GetExtensionName(filTarget) = arrExtension(i) Then
isMatchExtension = True
Exit For
End If
Next i
If isMatchExtension = True Then ' 現在のfilTargetが、指定ファイル種別に該当している場合
Call OutputFileInformation(filTarget, lngOutputColumnInCaseFile)
' ファイルの情報を出力する処理を呼び出し
End If
Else ' ファイル種別の指定が無い場合
Call OutputFileInformation(filTarget, lngOutputColumnInCaseFile)
' ファイルの情報を出力する処理を呼び出し
End If
Next filTarget
For Each folSub In folTarget.SubFolders ' サブフォルダのデータを出力する
lngCurrentOutputRow = lngCurrentOutputRow + 1
lngMaxDataRow = lngCurrentOutputRow
If isSearchSubFolder = True Then ' サブフォルダも検索する場合
' ここで自分自身を呼び出す再帰処理。階層図部分を出力するかどうかで、引数の値が変わる
If lngClassMapOutputFirstColumn <> SETTING.notOutput Then '階層図部分を出力する場合
Call FileAndFolderSearch(folSub.Path, lngOutputColumnInCaseFolder + 1, _
lngOutputColumnInCaseFile + 1)
Else
Call FileAndFolderSearch(folSub.Path, lngOutputColumnInCaseFolder, lngOutputColumnInCaseFile)
End If
Else ' サブフォルダは検索しない場合
If isColoredFolderFile = True Then ' フォルダとファイルで色分けする場合
wsOutput.Range(Cells(lngCurrentOutputRow, 1), Cells(lngCurrentOutputRow, SETTING.coloredLasColumn)) _
.Interior.Color = RGB(204, 255, 255)
End If
Call OutputFolderInformation(folSub, lngOutputColumnInCaseFolder + 1) 'フォルダの情報を出力する処理を呼び出し
End If
Next folSub
End With
Exit Sub
FileAndFolderSearch_ErrorHandler:
MsgBox "ファイル・フォルダ検索処理実行時にエラーが発生したため、処理を中断します"
Err.Raise 514
Exit Sub
End Sub
' ************ フォルダの情報を出力する処理 ******************************************************
Private Sub OutputFolderInformation(ByRef folTarget As Folder, ByVal lngOutputColumnInCaseFolder As Long)
With objFSO
If lngPathOutputColumn <> SETTING.notOutput Then
'パスを出力する列を設ける場合
wsOutput.Cells(lngCurrentOutputRow, lngPathOutputColumn) = .GetFolder(folTarget).Path
End If
If lngNameOutputColumn <> SETTING.notOutput Then
wsOutput.Cells(lngCurrentOutputRow, lngNameOutputColumn) = .GetFolder(folTarget).Name
End If
If lngClassifyOutputColumn <> SETTING.notOutput Then
wsOutput.Cells(lngCurrentOutputRow, lngClassifyOutputColumn) = "Folder"
End If
If lngSizeOutputColumn <> SETTING.notOutput Then
wsOutput.Cells(lngCurrentOutputRow, lngSizeOutputColumn) = .GetFolder(folTarget).Size
End If
If lngLastUpdateOutputColumn <> SETTING.notOutput Then
wsOutput.Cells(lngCurrentOutputRow, lngLastUpdateOutputColumn) = .GetFolder(folTarget).DateLastModified
End If
If lngClassMapOutputFirstColumn <> SETTING.notOutput Then
wsOutput.Cells(lngCurrentOutputRow, lngOutputColumnInCaseFolder) = .GetFolder(folTarget).Name
End If
If lngMaxDataColumn < lngOutputColumnInCaseFolder Then ' 最大データ列の更新
lngMaxDataColumn = lngOutputColumnInCaseFolder
End If
lngMaxDataRow = lngCurrentOutputRow
End With
End Sub
' ************ ファイルの情報を出力する処理 ******************************************************
Private Sub OutputFileInformation(ByRef filTarget As File, ByVal lngOutputColumnInCaseFile As Long)
With objFSO
lngCurrentOutputRow = lngCurrentOutputRow + 1
lngMaxDataRow = lngCurrentOutputRow
If isColoredFolderFile = True Then ' フォルダとファイルで色分けする場合
wsOutput.Range(Cells(lngCurrentOutputRow, 1), Cells(lngCurrentOutputRow, SETTING.coloredLasColumn)) _
.Interior.Color = RGB(255, 255, 204)
End If
If lngPathOutputColumn <> SETTING.notOutput Then
wsOutput.Cells(lngCurrentOutputRow, lngPathOutputColumn) = .GetFile(filTarget).Path
End If
If lngNameOutputColumn <> SETTING.notOutput Then
wsOutput.Cells(lngCurrentOutputRow, lngNameOutputColumn) = .GetFile(filTarget).Name
End If
If lngClassifyOutputColumn <> SETTING.notOutput Then
wsOutput.Cells(lngCurrentOutputRow, lngClassifyOutputColumn) = "File"
End If
If lngSizeOutputColumn <> SETTING.notOutput Then
wsOutput.Cells(lngCurrentOutputRow, lngSizeOutputColumn) = .GetFile(filTarget).Size
End If
If lngLastUpdateOutputColumn <> SETTING.notOutput Then
wsOutput.Cells(lngCurrentOutputRow, lngLastUpdateOutputColumn) = _
.GetFile(filTarget).DateLastModified
End If
If lngClassMapOutputFirstColumn <> SETTING.notOutput Then
wsOutput.Cells(lngCurrentOutputRow, lngOutputColumnInCaseFile) = .GetFile(filTarget).Name
End If
If lngMaxDataColumn < lngOutputColumnInCaseFile Then ' 最大データ列の更新
lngMaxDataColumn = lngOutputColumnInCaseFile
End If
End With
End Sub
' ************ 出力シートの調整処理 **********************************************************
Private Sub AdjustOutputSheet()
Dim i As Long
On Error GoTo AdjustOutputSheet_ErrorHandler
' パスのソートをする
If lngPathOutputColumn <> SETTING.notOutput And lngClassifyOutputColumn <> SETTING.notOutput Then
' ソートを実行するのは「パス」と「種別」の出力指定があった場合のみ
With wsOutput
.Columns(1).Select
Selection.Insert ' ソートのために1列追加
.Columns(1).NumberFormatLocal = "@" ' セルの書式設定を文字列に
lngCurrentOutputRow = SETTING.classMapOutputFirstRow
Do While .Cells(lngCurrentOutputRow, lngPathOutputColumn) <> ""
.Cells(lngCurrentOutputRow, 1) = .Cells(lngCurrentOutputRow, lngPathOutputColumn + 1)
strSortString = .Cells(lngCurrentOutputRow, 1)
If .Cells(lngCurrentOutputRow, lngClassifyOutputColumn + 1) = "File" Then ' 種別がFileだった場合
lngYenPosition = InStrRev(strSortString, "\") ' 文字列の後方から「\」を検索
strSortString = Left(strSortString, lngYenPosition) & " " & _
Right(strSortString, Len(strSortString) - lngYenPosition)
' 最後にある「\」の後に、半角スペースを入れる
.Cells(lngCurrentOutputRow, 1) = strSortString
End If
lngCurrentOutputRow = lngCurrentOutputRow + 1
Loop
.Range(Cells(SETTING.classMapOutputFirstRow, 1), Cells(lngMaxDataRow, SETTING.coloredLasColumn)). _
Sort key1:=.Cells(1, 1), MatchCase:=True, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
' 加工したパス名を元にソートする
.Columns(1).Delete ' ソートのために追加した1列目は削除
End With
End If
' 最終更新日時とサイズ以外の列は、全てセルの書式を文字列にする
If lngPathOutputColumn <> SETTING.notOutput Then ' 「パス」の列
wsOutput.Columns(lngPathOutputColumn).NumberFormatLocal = "@" ' セルの書式設定を文字列に
End If
If lngNameOutputColumn <> SETTING.notOutput Then '「フォルダ名・ファイル名」の列
wsOutput.Columns(lngNameOutputColumn).NumberFormatLocal = "@"
End If
If lngClassifyOutputColumn <> SETTING.notOutput Then ' 「種別」の列
wsOutput.Columns(lngClassifyOutputColumn).NumberFormatLocal = "@"
End If
If lngClassMapOutputFirstColumn <> SETTING.notOutput Then ' 「階層図」の列
wsOutput.Range(Columns(lngClassMapOutputFirstColumn), Columns(lngMaxDataColumn)) _
.NumberFormatLocal = "@"
End If
' データの無い部分を全クリア
wsOutput.Range(Columns(lngMaxDataColumn + 1), Columns(wsOutput.Columns.Count)).Clear
wsOutput.Range(Rows(lngMaxDataRow + 1), Rows(wsOutput.Rows.Count)).Clear
' タイトル行で枠固定
wsOutput.Cells(SETTING.titleOutputRow + 1, 1).Select
ActiveWindow.FreezePanes = True
'罫線を設定
wsOutput.Range(Cells(SETTING.titleOutputRow, 1), Cells(lngMaxDataRow, lngMaxDataColumn)). _
Borders.LineStyle = True
If isAddHyperLink = True Then ' パスにハイパーリンクを付与する場合
If lngPathOutputColumn <> SETTING.notOutput Then
For i = SETTING.classMapOutputFirstRow To lngMaxDataRow
wsOutput.Hyperlinks.Add anchor:=wsOutput.Cells(i, lngPathOutputColumn), _
Address:=wsOutput.Cells(i, lngPathOutputColumn)
Next i
End If
End If
wsOutput.Move ' 階層図のシートを新規ブックとして切り離し
Exit Sub
AdjustOutputSheet_ErrorHandler:
MsgBox "出力シートの調整処理でエラーが発生したため、処理を中断します"
Err.Raise 514
Exit Sub
End Sub
' ************ 配列の要素の文字列長をチェックする **********************************************************
Function IsOverStringLength(ByRef arrParam() As String, ByVal maxLength As Long) As Boolean
Dim i As Long
IsOverStringLength = False
For i = LBound(arrParam) To UBound(arrParam)
If Len(arrParam(i)) > maxLength Then
IsOverStringLength = True
Exit Function
End If
Next i
End Function
' ************ 重複をチェックする処理 **********************************************************
Function IsOverlapping(ByRef arrParam) As Boolean
Dim i As Long
Dim j As Long
IsOverlapping = False
For i = LBound(arrParam) To UBound(arrParam)
For j = LBound(arrParam) To UBound(arrParam)
If arrParam(i) = arrParam(j) And i <> j Then
IsOverlapping = True '重複があったらTrueに
Exit For '重複があったらループを抜ける
End If
Next j
If IsOverlapping Then Exit For
Next i
End Function
'************* 最後に実行する処理 ***************************************
Private Sub LastProcess()
Dim ws As Worksheet
'「階層図」シートがこのブック内に残っている場合は、新規ブックとして切り離す
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "階層図" Then
ws.Move
Exit For
End If
Next
Set objFSO = Nothing
Set wsJikkou = Nothing
Set wsOutput = Nothing
Erase arrExtension
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
'********** フォルダ選択のダイアログを開く *****************************************
Private Sub ShowSelectFolderDialog()
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
Me.txtTargetFolder = .SelectedItems(1) & "\"
Else
MsgBox "キャンセルされました"
End If
End With
End Sub
'********* 以下、コントロールのイベント発生時の処理 *******************************
'フォーム初期化時
Private Sub UserForm_Initialize()
Me.chkNotSpecifyExtension.Value = True
End Sub
'「フォルダ選択」ボタンを押した時
Private Sub btnSelectFolder_Click()
Call ShowSelectFolderDialog
End Sub
'拡張子のチェックボックス1の値が変化した時
Private Sub chkExtension1_Change()
If Me.chkExtension1.Value Then
Me.txtExtension1.Enabled = True
Else
Me.txtExtension1.Enabled = False
End If
End Sub
'拡張子のチェックボックス2の値が変化した時
Private Sub chkExtension2_Change()
If Me.chkExtension2.Value Then
Me.txtExtension2.Enabled = True
Else
Me.txtExtension2.Enabled = False
End If
End Sub
'拡張子のチェックボックス3の値が変化した時
Private Sub chkExtension3_Change()
If Me.chkExtension3.Value Then
Me.txtExtension3.Enabled = True
Else
Me.txtExtension3.Enabled = False
End If
End Sub
'拡張子のチェックボックス4の値が変化した時
Private Sub chkExtension4_Change()
If Me.chkExtension4.Value Then
Me.txtExtension4.Enabled = True
Else
Me.txtExtension4.Enabled = False
End If
End Sub
'拡張子のチェックボックス5の値が変化した時
Private Sub chkExtension5_Change()
If Me.chkExtension5.Value Then
Me.txtExtension5.Enabled = True
Else
Me.txtExtension5.Enabled = False
End If
End Sub
'拡張子のチェックボックス6の値が変化した時
Private Sub chkExtension6_Change()
If Me.chkExtension6.Value Then
Me.txtExtension6.Enabled = True
Else
Me.txtExtension6.Enabled = False
End If
End Sub
'拡張子のチェックボックス7の値が変化した時
Private Sub chkExtension7_Change()
If Me.chkExtension7.Value Then
Me.txtExtension7.Enabled = True
Else
Me.txtExtension7.Enabled = False
End If
End Sub
'拡張子のチェックボックス8の値が変化した時
Private Sub chkExtension8_Change()
If Me.chkExtension8.Value Then
Me.txtExtension8.Enabled = True
Else
Me.txtExtension8.Enabled = False
End If
End Sub
'拡張子のチェックボックス9の値が変化した時
Private Sub chkExtension9_Change()
If Me.chkExtension9.Value Then
Me.txtExtension9.Enabled = True
Else
Me.txtExtension9.Enabled = False
End If
End Sub
'拡張子のチェックボックス10の値が変化した時
Private Sub chkExtension10_Change()
If Me.chkExtension10.Value Then
Me.txtExtension10.Enabled = True
Else
Me.txtExtension10.Enabled = False
End If
End Sub
'拡張子のチェックボックス11の値が変化した時
Private Sub chkExtension11_Change()
If Me.chkExtension11.Value Then
Me.txtExtension11.Enabled = True
Else
Me.txtExtension11.Enabled = False
End If
End Sub
'拡張子のチェックボックス12の値が変化した時
Private Sub chkExtension12_Change()
If Me.chkExtension12.Value Then
Me.txtExtension12.Enabled = True
Else
Me.txtExtension12.Enabled = False
End If
End Sub
'拡張子のチェックボックス13の値が変化した時
Private Sub chkExtension13_Change()
If Me.chkExtension13.Value Then
Me.txtExtension13.Enabled = True
Else
Me.txtExtension13.Enabled = False
End If
End Sub
'拡張子のチェックボックス14の値が変化した時
Private Sub chkExtension14_Change()
If Me.chkExtension14.Value Then
Me.txtExtension14.Enabled = True
Else
Me.txtExtension14.Enabled = False
End If
End Sub
'拡張子のチェックボックス15の値が変化した時
Private Sub chkExtension15_Change()
If Me.chkExtension15.Value Then
Me.txtExtension15.Enabled = True
Else
Me.txtExtension15.Enabled = False
End If
End Sub
'拡張子のチェックボックス16の値が変化した時
Private Sub chkExtension16_Change()
If Me.chkExtension16.Value Then
Me.txtExtension16.Enabled = True
Else
Me.txtExtension16.Enabled = False
End If
End Sub
'拡張子のチェックボックス17の値が変化した時
Private Sub chkExtension17_Change()
If Me.chkExtension17.Value Then
Me.txtExtension17.Enabled = True
Else
Me.txtExtension17.Enabled = False
End If
End Sub
'拡張子のチェックボックス18の値が変化した時
Private Sub chkExtension18_Change()
If Me.chkExtension18.Value Then
Me.txtExtension18.Enabled = True
Else
Me.txtExtension18.Enabled = False
End If
End Sub
'拡張子のチェックボックス19の値が変化した時
Private Sub chkExtension19_Change()
If Me.chkExtension19.Value Then
Me.txtExtension19.Enabled = True
Else
Me.txtExtension19.Enabled = False
End If
End Sub
'拡張子のチェックボックス20の値が変化した時
Private Sub chkExtension20_Change()
If Me.chkExtension20.Value Then
Me.txtExtension20.Enabled = True
Else
Me.txtExtension20.Enabled = False
End If
End Sub
'拡張子のチェックボックス21の値が変化した時
Private Sub chkExtension21_Change()
If Me.chkExtension21.Value Then
Me.txtExtension21.Enabled = True
Else
Me.txtExtension21.Enabled = False
End If
End Sub
'拡張子のチェックボックス22の値が変化した時
Private Sub chkExtension22_Change()
If Me.chkExtension22.Value Then
Me.txtExtension22.Enabled = True
Else
Me.txtExtension22.Enabled = False
End If
End Sub
'拡張子のチェックボックス23の値が変化した時
Private Sub chkExtension23_Change()
If Me.chkExtension23.Value Then
Me.txtExtension23.Enabled = True
Else
Me.txtExtension23.Enabled = False
End If
End Sub
'拡張子のチェックボックス24の値が変化した時
Private Sub chkExtension24_Change()
If Me.chkExtension24.Value Then
Me.txtExtension24.Enabled = True
Else
Me.txtExtension24.Enabled = False
End If
End Sub
'「拡張子のクリア」ボタンを押した時
Private Sub btnClearExtension_Click()
Me.txtExtension1.Text = ""
Me.txtExtension2.Text = ""
Me.txtExtension3.Text = ""
Me.txtExtension4.Text = ""
Me.txtExtension5.Text = ""
Me.txtExtension6.Text = ""
Me.txtExtension7.Text = ""
Me.txtExtension8.Text = ""
Me.txtExtension9.Text = ""
Me.txtExtension10.Text = ""
Me.txtExtension11.Text = ""
Me.txtExtension12.Text = ""
Me.txtExtension13.Text = ""
Me.txtExtension14.Text = ""
Me.txtExtension15.Text = ""
Me.txtExtension16.Text = ""
Me.txtExtension17.Text = ""
Me.txtExtension18.Text = ""
Me.txtExtension19.Text = ""
Me.txtExtension20.Text = ""
Me.txtExtension21.Text = ""
Me.txtExtension22.Text = ""
Me.txtExtension23.Text = ""
Me.txtExtension24.Text = ""
End Sub
'「拡張子は限定しない」のチェックボックスの値が変化した時
Private Sub chkNotSpecifyExtension_Change()
If Me.chkNotSpecifyExtension.Value Then
Me.txtExtension1.Enabled = False
Me.txtExtension2.Enabled = False
Me.txtExtension3.Enabled = False
Me.txtExtension4.Enabled = False
Me.txtExtension5.Enabled = False
Me.txtExtension6.Enabled = False
Me.txtExtension7.Enabled = False
Me.txtExtension8.Enabled = False
Me.txtExtension9.Enabled = False
Me.txtExtension10.Enabled = False
Me.txtExtension11.Enabled = False
Me.txtExtension12.Enabled = False
Me.txtExtension13.Enabled = False
Me.txtExtension14.Enabled = False
Me.txtExtension15.Enabled = False
Me.txtExtension16.Enabled = False
Me.txtExtension17.Enabled = False
Me.txtExtension18.Enabled = False
Me.txtExtension19.Enabled = False
Me.txtExtension20.Enabled = False
Me.txtExtension21.Enabled = False
Me.txtExtension22.Enabled = False
Me.txtExtension23.Enabled = False
Me.txtExtension24.Enabled = False
Me.chkExtension1.Enabled = False
Me.chkExtension2.Enabled = False
Me.chkExtension3.Enabled = False
Me.chkExtension4.Enabled = False
Me.chkExtension5.Enabled = False
Me.chkExtension6.Enabled = False
Me.chkExtension7.Enabled = False
Me.chkExtension8.Enabled = False
Me.chkExtension9.Enabled = False
Me.chkExtension10.Enabled = False
Me.chkExtension11.Enabled = False
Me.chkExtension12.Enabled = False
Me.chkExtension13.Enabled = False
Me.chkExtension14.Enabled = False
Me.chkExtension15.Enabled = False
Me.chkExtension16.Enabled = False
Me.chkExtension17.Enabled = False
Me.chkExtension18.Enabled = False
Me.chkExtension19.Enabled = False
Me.chkExtension20.Enabled = False
Me.chkExtension21.Enabled = False
Me.chkExtension22.Enabled = False
Me.chkExtension23.Enabled = False
Me.chkExtension24.Enabled = False
Else
Me.chkExtension1.Enabled = True
Me.chkExtension2.Enabled = True
Me.chkExtension3.Enabled = True
Me.chkExtension4.Enabled = True
Me.chkExtension5.Enabled = True
Me.chkExtension6.Enabled = True
Me.chkExtension7.Enabled = True
Me.chkExtension8.Enabled = True
Me.chkExtension9.Enabled = True
Me.chkExtension10.Enabled = True
Me.chkExtension11.Enabled = True
Me.chkExtension12.Enabled = True
Me.chkExtension13.Enabled = True
Me.chkExtension14.Enabled = True
Me.chkExtension15.Enabled = True
Me.chkExtension16.Enabled = True
Me.chkExtension17.Enabled = True
Me.chkExtension18.Enabled = True
Me.chkExtension19.Enabled = True
Me.chkExtension20.Enabled = True
Me.chkExtension21.Enabled = True
Me.chkExtension22.Enabled = True
Me.chkExtension23.Enabled = True
Me.chkExtension24.Enabled = True
If Me.chkExtension1.Value Then
Me.txtExtension1.Enabled = True
End If
If Me.chkExtension2.Value Then
Me.txtExtension2.Enabled = True
End If
If Me.chkExtension3.Value Then
Me.txtExtension3.Enabled = True
End If
If Me.chkExtension4.Value Then
Me.txtExtension4.Enabled = True
End If
If Me.chkExtension5.Value Then
Me.txtExtension5.Enabled = True
End If
If Me.chkExtension6.Value Then
Me.txtExtension6.Enabled = True
End If
If Me.chkExtension7.Value Then
Me.txtExtension7.Enabled = True
End If
If Me.chkExtension8.Value Then
Me.txtExtension8.Enabled = True
End If
If Me.chkExtension9.Value Then
Me.txtExtension9.Enabled = True
End If
If Me.chkExtension10.Value Then
Me.txtExtension10.Enabled = True
End If
If Me.chkExtension11.Value Then
Me.txtExtension11.Enabled = True
End If
If Me.chkExtension12.Value Then
Me.txtExtension12.Enabled = True
End If
If Me.chkExtension13.Value Then
Me.txtExtension13.Enabled = True
End If
If Me.chkExtension14.Value Then
Me.txtExtension14.Enabled = True
End If
If Me.chkExtension15.Value Then
Me.txtExtension15.Enabled = True
End If
If Me.chkExtension16.Value Then
Me.txtExtension16.Enabled = True
End If
If Me.chkExtension17.Value Then
Me.txtExtension17.Enabled = True
End If
If Me.chkExtension18.Value Then
Me.txtExtension18.Enabled = True
End If
If Me.chkExtension19.Value Then
Me.txtExtension19.Enabled = True
End If
If Me.chkExtension20.Value Then
Me.txtExtension20.Enabled = True
End If
If Me.chkExtension21.Value Then
Me.txtExtension21.Enabled = True
End If
If Me.chkExtension22.Value Then
Me.txtExtension22.Enabled = True
End If
If Me.chkExtension23.Value Then
Me.txtExtension23.Enabled = True
End If
If Me.chkExtension24.Value Then
Me.txtExtension24.Enabled = True
End If
End If
End Sub
'「階層図作成実行」ボタンを押した時
Private Sub btnExecute_Click()
Dim result As VbMsgBoxResult
result = MsgBox("階層図作成換処理を実行しますか?", vbYesNo)
If result = vbYes Then
Call CreateClassMapMain '階層図作成処理を実行
Else
MsgBox "キャンセルされました"
End If
End Sub
'「閉じる」ボタンを押した時
Private Sub btnClose_Click()
Me.Hide
End Sub
'フォーム右上の×を押した時
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then
MsgBox "×ボタンで閉じることはできません"
Cancel = True
End If
End Sub
標準モジュールのコード
Option Explicit
'************* フォームの表示 *************************************
Public Sub ShowForm()
SettingForm.Show vbModeless
End Sub
ThisWorkbookのコード
Option Explicit
Private Sub Workbook_Open()
Load SettingForm
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Unload SettingForm
End Sub
バグなどがありましたら、報告してもらえると助かります。