制御 ブックOpen時にModuleを読み込みClose時にModuleを削除

※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。

※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。

改変しました。
①ブックOpen時に同階層の「Module一覧テキストファイル」からModuleを読み込み。
②開いたブックのModuleは自由に改変や追加可能。
③Close時に現在あるModuleを「Module一覧テキストファイル」に新規に書き込み（旧ファイル削除）、更に任意の場所へModuleを保存後、Moduleを全て削除する。
①～②～③～①で常に最新Module群に保てる。
改変や新規追加したModuleは上書きされ最新になる。
他のブックとModuleが重複しない他、共有出来便利。
１度作成したModuleは閉じた時登録される。
登録後に開いて不要なModuleを削除すると再度起動時には読み込まれない。（Moduleは指定フォルダに残っている）
再び必要となったModuleはフォルダからドラッグ＆ドロップでインポート可能。（探すのが大変ですから名前付けの定義を決めておいた方が良い）
SubをFunctionを同じフォルダ内で管理ができる。
※ここではModuleだけを対象にしていますがSheet、UserForm、ClassModuleも対象にすることが可能。
※Module名は自由ですがいちいち開かなくても内容が判るような名前付けが賢明です。
※閉じる際に「保存する」を選択して下さい。（Module名に[1]が付加され、保存Moduleが増える）自動保存されます。
※閉じた状態なら約58kb
下のコードをコピペでThisWorkbookにペーストして下さい。
Moduleが一つも無い場合のエラー回避はしていません。

すべてThisWorkbookに記述
Option Explicit

'#パラメータ
Const ComponentsPath As String = "C:\VBAbas\"

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'****************************************************
'閉じる前に実行するイベント
'****************************************************

ThisProJectComponentCopy
'コンポーネント削除
ComponentsDelete
ThisWorkbook.Save
'ThisWorkbook.Close saveChanges:=True

End Sub

Private Sub Workbook_Open()
'****************************************************
'ModuleやClass・UserFormを一覧から自動インポートする
'****************************************************
'本ブックと同じ階層にテキストを保存。
'行毎に記入の事
'全て「ThisWorkbook」に記述のこと
'#パラメータ
Dim TxtPath As String, i As Long
Dim CharacterDB() As String

TxtPath = ThisWorkbook.Path & "\" & ThisWorkbook.Name & ".txt"
'If MsgBox("", vbYesNo) = vbYes Then
    'ModuleやClass・UserFormを削除する
    ComponentsDelete

    '指定ファイルの存在を確認する
    If FileExistence(TxtPath) = False Then
        MsgBox "Not File! " & TxtPath
        Exit Sub
    End If
    '指定ファイルを読み込む
    Call FileInput(TxtPath, CharacterDB())
    'Moduleをインポートする
    For i = LBound(CharacterDB) To UBound(CharacterDB)
        ComponentImport (CharacterDB(i))
    Next i

'End If
End Sub

Private Function FileExistence(TxtPath As String) As Boolean
'**************************************************
'指定ファイルの存在を確認する
'**************************************************
    If Dir(TxtPath) = "" Then
        FileExistence = False
    Else
        FileExistence = True
    End If
End Function

Private Sub FileInput(ByVal TxtPath As String, ByRef CharacterDB() As String)
'**************************************************
'指定ファイルを１行づつ読み込む
'**************************************************
Dim CharacterString As String
Dim FileNumber As Integer, i As Long
    FileNumber = FreeFile
    Open TxtPath For Input As #FileNumber
        Do Until EOF(FileNumber) '末尾に達するまで
            '取得文字を変数CharacterStringに格納
            Line Input #FileNumber, CharacterString
            '文字があるか確認
            If Len(CharacterString) > 0 Then
                '処理
                ReDim Preserve CharacterDB(i)
                CharacterDB(i) = (ComponentsPath & CharacterString)
                i = i + 1
            End If
        Loop
    Close #FileNumber
End Sub

Private Sub ComponentImport(ComponentsPathName As String)
'**************************************************
'ModuleやClass・UserFormをインポートする
'**************************************************
'定数 ComponentsPathName：bas等の格納パス&名前

Application.StatusBar = "ComponentImport:" & ComponentsPathName

    If Dir(ComponentsPathName) = "" Then
        MsgBox "Not Module! " & ComponentsPathName
        Exit Sub
    Else
        ThisWorkbook.VBProject.VBComponents.Import ComponentsPathName
    End If

End Sub

Private Sub ComponentsDelete()
'************************************
'ModuleやClass・UserFormを削除する
'************************************
'※自分も削除されます。ここでは.Type=100以外なので削除されません。
'NoDeleteObjTyp:削除非対象コレクション
'1  :Module
'2  :ClassModule
'3  :UserForm
'100:Workbook & Sheet

Application.StatusBar = "ComponentsDelete......"

Dim Obj As Object, NoDeleteObjTyp As Integer
NoDeleteObjTyp = 100

For Each Obj In ThisWorkbook.VBProject.VBComponents

    If Obj.Type <> NoDeleteObjTyp Then
        ThisWorkbook.VBProject.VBComponents.Remove Obj
    End If

Next Obj

End Sub

Sub ThisProJectComponentCopy()
'ObjectName:M_ThisProJectComponentCopy
'***************************************
'実行プロシージャ
'***************************************
Dim TxtPath As String
'Dim ComponentPath As String
TxtPath = ThisWorkbook.Path & "\" & ThisWorkbook.Name & ".txt"

Dim ComponentsName() As String
Dim str As String, i As Integer
'現在のComponent一覧取得
Call ComponentsGetName(ComponentsName)
'前回のテキスト削除
FileKill TxtPath
'新規テキスト入力
For i = LBound(ComponentsName) To UBound(ComponentsName)
    FileAppend TxtPath, ComponentsName(i)
Next i
'Componentを全てエクスポート(コピー)する
ComponentsExport ComponentsPath

End Sub

Sub ComponentsExport(ObjPath As String)
'ObjectName:M_ComponentsExport
'***************************************************************
'ModuleやClass・UserFormを別ファイルにエクスポート(コピー)する
'***************************************************************
'※自分もコピーされます。
'※対象はプロジェクト全体
'ExportObjTyp:対象コレクション

Dim Obj As Object, ExportObjTyp As Integer
Dim ObjName As String '対象コレクション名

ExportObjTyp = 1 '対象コレクション(Module)

Dim Extension(100) As String '拡張子(Select Caseの方がベター)
Extension(1) = ".bas"   '1  :Module
Extension(2) = ".cls"   '2  :ClassModule
Extension(3) = ".frm"   '3  :UserForm
Extension(100) = ".cls" '100:Workbook & Sheet

For Each Obj In ThisWorkbook.VBProject.VBComponents

    If Obj.Type = ExportObjTyp Then
        ObjName = Obj.Name
        Obj.Export (ObjPath & ObjName & Extension(ExportObjTyp))
    End If

Next Obj

End Sub

Sub ComponentsGetName(ByRef ComponentsName() As String)
'ObjectName:M_ComponentsGetName
'***************************************************************
'ModuleやClass・UserForm名を取得する
'***************************************************************
'※自分も対象にされます。
'※対象はプロジェクト全体
'ObjTyp:対象コレクション

Dim Obj As Object, ObjTyp As Integer
Dim i As Integer

ObjTyp = 1 '対象コレクション(Module)

Dim Extension(100) As String '拡張子(Select Caseの方がベター)
Extension(1) = ".bas"   '1  :Module
Extension(2) = ".cls"   '2  :ClassModule
Extension(3) = ".frm"   '3  :UserForm
Extension(100) = ".cls" '100:Workbook & Sheet

i = 0 '初期化

For Each Obj In ThisWorkbook.VBProject.VBComponents

    If Obj.Type = ObjTyp Then
        ReDim Preserve ComponentsName(i)
        ComponentsName(i) = Obj.Name & Extension(ObjTyp)
        i = i + 1
    End If

Next Obj

End Sub

Sub FileKill(DelPath As String)
'ObjectName:M_FileKill
'*********************************
'Killを使用しファイルを削除
'*********************************

On Error Resume Next

Kill DelPath

On Error GoTo 0

End Sub

Sub FileAppend(TxtPath As String, str As String)
'ObjectName:M_FileAppend
'*******************************************************************************
'指定パスのテキストファイルに追加
'*******************************************************************************

    Dim n As Long
    n = FreeFile '使われていないファイル番号を自動的に割り振る
    Open TxtPath For Append As #n
        Print #n, str
    Close #n

' キーワード 処理             モード
' Input   読み込み           入力モード
' Output  書き込み           出力モード
' Append  書き込み           追加モード
' Random  読み込み/書き込み  ランダムアクセスモード(データベースの
'                            データファイルにアクセスするモード)
' Binary  読み込み/書き込み  バイナリモード(ファイルのデータを一気
'                            に読み込む)
End Sub

 

2000年01月01日|[VBサンプルコード]:[制御]