ExcelでCDケースジャケットのリストを作る「CDジャケット作成マクロ.xls」を作った

今、いきいきパソコン談話室で「デジカメ」談話中で、写真は「日付別フォルダー」で整理するようにしている。
CD−R に焼いた時、ジャケットに印刷するデータをエクセル・マクロ(VBA)で作ろう‥‥ と、この一週間構想を練って(ループして)いたが、昨日・今日でほぼ完成させた。


 苦労したコード

  1. Excel モジュールで、コマンドプロンプト(tree)を動かす
  2. コマンドプロンプトが「終わるのを待つ」

結果として、「mougモーグ)」,「Office Tanaka」に大変お世話になった。

  • フォルダを選択するダイアログ (Office Tanaka)
     フォルダを選択するダイアログボックスを表示するにはいくつかの方法があります。
    1. FileDialogオブジェクトを使う方法
    2. Shellを使う方法
    3. APIを使う方法(1)
    4. APIを使う方法(2)
  • 他アプリを起動する (mougモーグ)
    • Shell関数でアプリケーションを起動する
       Shell関数で起動したメモ帳をVBAから操作することは難しいです。
      起動したメモ帳はアクティブなウィンドウとなるので、VBAからSendKeysという命令を実行して、任意のキーが「押されたこと」にして、何かの操作を行わせることは可能です。

       ただし、上記のSample2は環境によっては失敗します。
      Shell関数はメモ帳を起動しますが、VBAからはメモ帳が「完全に起動し終わった」かどうかの判断がつきません。したがって、メモ帳が完全に起動し終わる前にSendKeysメソッドが実行されてしまうと、"%EP" のキーコードはExcelに対して送信されてしまうのです。
    • ファイルに関連付けられたアプリケーションを起動する
      こうした"拡張子関連づけ"でアプリケーションを起動するには、WSH(Windows Script Host)の機能を使うと簡単です。

       次のコードは、WSHのWshShellクラスのインスタンスを作成し、Runメソッドで"C:\Data\Image.JPG"ファイルを開きます。


 コード
最終的にはコメントをもっと入れ、「検索」出来るようにする予定。

Option Explicit
Public MacroName As String
Public MacroPath As String     'マクロファイルが置いてあるパス
Public ListupFolderName As String
Public LngAns As Long
Public StrAns As String
Public VarAns As Variant

Public Sub Auto_Open()
Dim dsn As Long, dsn1 As Long, dsn2 As Long
Dim i As Long, r As Long
Dim strFileList As String, strFolderList As String, strFullPath As String
Dim strText As String, strCDFile As String

    MacroName = ThisWorkbook.Name
    MacroPath = ThisWorkbook.Path
        'リストアップするフォルダを取得する。
    ListupFolderName = getフォルダ名()
    If ListupFolderName = "" Then Exit Sub
        'ファイルリストを作る。
    strFileList = MacroPath & "\FileList.txt"
    VarAns = getファイル(strFileList)
        '出力ファイルを開く。
    strCDFile = MacroPath & "\CDJacketText.txt"
    dsn = FreeFile
    Open strCDFile For Output As dsn
        'FileListから直下のファイル名を取り込む。
    dsn1 = FreeFile
    Open strFileList For Input As dsn1
    For i = 1 To 3
        Line Input #dsn1, strText
        If Left(strText, 5) <> "ボリューム" Then Print #dsn, strText
    Next
    Do While Not EOF(dsn1)
        Line Input #dsn1, strText
        If Left(strText, 1) = "│" Then
            Print #dsn, strText
        Else
            Close #dsn1
            Exit Do
        End If
    Loop
    Close #dsn1
    
        'フォルダリストを作る。
    strFolderList = MacroPath & "\FolderList.txt"
    VarAns = getフォルダ(strFolderList)
        'FolderListからフォルダ名を取り込む。
    dsn2 = FreeFile
    Open strFolderList For Input As dsn2
    For i = 1 To 3      'ヘッダ部分を読み捨てる。
        Line Input #dsn1, strText
    Next
    Do While Not EOF(dsn1)
        Line Input #dsn2, strText
        Print #dsn, strText
    Loop
    Close #dsn2
    
    Close #dsn
        'メモ帳で開いてアクティブにし、閉じるのを待つ)
    With CreateObject("Wscript.Shell")
        LngAns = .Run("notepad.exe " & strCDFile, vbNormalFocus, True)
    End With
        'テキストファイルを削除する。
    Kill strFileList
    Kill strFolderList
    Kill strCDFile
        '保存したことにする (保存はしない)
    ThisWorkbook.Saved = True
        'Excel を終了する
    Application.Quit
        '自分以外の Book は保存の問い合わせが出る
    ThisWorkbook.Close False

End Sub

Public Function getファイル(argOutFile As String)
Dim ret As Long
Dim strCommand As String

    strCommand = "tree " & ListupFolderName & " /f >" & argOutFile
    With CreateObject("Wscript.Shell")
         ret = .Run("cmd /c" & strCommand, 7, True)
    End With

End Function

Public Function getフォルダ(argOutFile As String)
Dim ret As Long
Dim strCommand As String
    
    strCommand = "tree " & ListupFolderName & ">" & argOutFile
    With CreateObject("Wscript.Shell")
         ret = .Run("cmd /c" & strCommand, 7, True)
    End With

End Function


Public Function getフォルダ名() As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            getフォルダ名 = .SelectedItems(1)
        Else
            getフォルダ名 = ""
        End If
    End With

End Function


 Run メソッド
【構文】 object.Run(strCommand, [intWindowStyle], [bWaitOnReturn])

  • object
     WshShell オブジェクトです。
  • strCommand
     実行するコマンド ラインを示す文字列値です。この引数には、実行可能ファイルに渡すべきパラメータをすべて含める必要があります。
  • intWindowStyle
     省略可能です。プログラムのウィンドウの外観を示す整数値です。すべてのプログラムがこの情報を使用するわけではないので注意してください。
    • 0:ウィンドウを非表示にし、別のウィンドウをアクティブにします。
    • 1:ウィンドウをアクティブにして表示します。ウィンドウが最小化または最大化されている場合は、元のサイズと位置に戻ります。アプリケーションでウィンドウを最初に表示するときには、このフラグを指定してください。
    • 2:ウィンドウをアクティブにし、最小化ウィンドウとして表示します。
    • 3:ウィンドウをアクティブにし、最大化ウィンドウとして表示します。
    • 4:ウィンドウを最新のサイズと位置で表示します。アクティブなウィンドウは切り替わりません。
    • 5:ウィンドウをアクティブにし、現在のサイズと位置で表示します。
    • 6:指定したウィンドウを最小化し、Z オーダー上で次に上位となるウィンドウをアクティブにします。
    • 7:ウィンドウを最小化ウィンドウとして表示します。アクティブなウィンドウは切り替わりません。
    • 8:ウィンドウを現在の状態で表示します。アクティブなウィンドウは切り替わりません。
    • 9:ウィンドウをアクティブにして表示します。ウィンドウが最小化または最大化されている場合は、元のサイズと位置に戻ります。アプリケーションで最小化ウィンドウを復元するときには、このフラグを指定してください。
    • 10 アプリケーションを起動したプログラムの状態に基づいて、表示状態を設定します。
  • bWaitOnReturn
     省略可能です。スクリプト内の次のステートメントに進まずにプログラムの実行が終了するまでスクリプトを待機させるかどうかを示すブール値です。bWaitOnReturn に TRUE を指定すると、プログラムの実行が終了するまでスクリプトの実行は中断され、Run メソッドはアプリケーションから返される任意のエラー コードを返します。bWaitOnReturn に FALSE を指定すると、プログラムが開始すると Run メソッドは即座に復帰して自動的に 0 を返します (これをエラー コードとして解釈しないでください)。