' [324.xls]



' [Module1] のコード
'★★☆　VBAソースコードの取得　☆★★

Option Explicit

Sub start()
Dim file As Variant     'VBAコードを取得するファイル
Dim cord As String      'VBAコード１行分
Dim Sauce As Object     'モジュール
Dim mypath As String
Dim I As Integer
Dim j As Integer
Dim new_txt As String

    With Application
        'ファイルを開くダイアログに標準のExeclのファイルを指定して開く
        file = .GetOpenFilename _
            ("*(*.xls),*.xls,", 1, "選択したExcelファイルのソースの読込")
        
        If file = False Then Exit Sub
    
        '新しいtxtファイルのパス
        mypath = Left(file, Len(file) - Len(Dir(file, vbNormal)))
        new_txt = Left(Dir(file, vbNormal), Len(Dir(file, vbNormal)) - 3) & "txt"
    
        '画面の更新禁止
        .ScreenUpdating = False
        .DisplayAlerts = False
    
        'VBAコードを書き込む為の新しいtxtファイルをシーケンシャル出力モードで開く
        Open new_txt For Output As #1
    
        'txtファイルに見出しを作成
        Print #1, "対象は [" & Dir(file, vbNormal) & "]"
        Print #1, "VBAソースコードを以下に表示します"
        Print #1, ""
    
        'VBAコードを取得するファイルを開く前に全てのイベントを無効にする
        'Workbook_Open等が実行されないようにする為
        .EnableEvents = False
    
        'VBAコードを取得するファイルを開く
        Workbooks.Open file
   
        On Error GoTo errorhandl
        
            'VBAコードを取得するファイル内の全てのモジュールが終わる迄繰り返す
            For Each Sauce In ActiveWorkbook.VBProject.VBComponents
        
                'CodeModule オブジェクトはコード テキストについての情報を
                '行単位で操作したり、取得したりすることができます
                
                'ひとつのモジュールのタイトル
                Print #1, "[" & Sauce.codemodule & "] のコード"
                
                'CountOfLines プロパティはCodeModule内のコードの行数を取得
            
                    'ひとつのモジュール内のすべての行を繰り返す
                For I = 1 To Sauce.codemodule.countoflines
                
                    'ひとつのモジュールの１行を取り出す
                    cord = Sauce.codemodule.Lines(I, 1)
                
                    '取り出した１行のコードを書き込む
                    Print #1, cord
                Next
            Next
        
        'VBAコード取得の対象ファイルを閉じる
        Workbooks(Dir(file, vbNormal)).Close savechanges:=False
    
        'txtファイルを閉じる
        Close #1
    
        '画面の更新禁止を解除
        .ScreenUpdating = True
        .DisplayAlerts = True
    
        '全てのイベントを有効にする
        .EnableEvents = True
    
        MsgBox Dir(file, vbNormal) & " モジュールを以下に書き出しました" _
            & Chr(10) & Chr(10) & mypath & new_txt
        
        Exit Sub
        
errorhandl:

        Workbooks(Dir(file, vbNormal)).Close savechanges:=False
        Close #1
        MsgBox "エラーが発生しました中止します"
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        
    End With

End Sub