Thunderbird のディレクトリ構成を移す方法 (VBS)

社内で Thunderbird に関してディレクトリ構造をそのまま移す必要があったため、スクリプトを作成しました。

指針

Thunderbird の POP3 のディレクトリ構成は、 ディレクトリごとにファイルがあります。

まず Inbox のプロパティを見ると、どこに格納されているかが表示されます。

そのフォルダ内に、サブフォルダやファイルがあり、メールフォルダを構成しています。

すごくおおざっぱにいって、拡張子なしのファイルがあればそれがフォルダです。
msf が拡張子のファイルはメールのインデックスファイルです。
最後が .sbd で終わるファイルがあればそれがサブフォルダを格納するフォルダです。

概念図

Inbox
|-- Subfolder1   # ファイルが存在する
`-- Subfolder2   # ファイルが存在する、sbdフォルダも存在する
 `-- Subfolder3  # ファイルが存在する

このファイル・フォルダ構造を、移したい先のフォルダにコピーしてやれば、同じ構造のフォルダが Thunderbird でも使えるようになります。

実際のフォルダの様子

Thunderbird

File System

プログラム

そのフォルダ構成のみを移すプログラムを作成しました。

コピー元のフォルダとコピー先のフォルダを選択します。
コピー元のフォルダにあるファイル・サブフォルダを再帰的に走査して、同じ構造のファイル・サブフォルダをコピー先のフォルダに作成します。

できたファイル・サブフォルダをそのままフォルダ構造を移したい Thunderbird のフォルダに移してやれば、 Thunderbird のフォルダ構造が移ります。

msf のファイルがなくても Thunderbird が自動で作成するので、 msf ファイル は作成しません。

Dim shellObject
Dim fileSystemObject
Dim folderFrom
Dim folderTo

Set shellObject = WScript.CreateObject("Shell.Application")
Set fileSystemObject = WScript.CreateObject("Scripting.FileSystemObject")

Set folderFrom = shellObject.BrowseForFolder(0, "Please Select Original Folder", 0, "C:\")
If folderFrom Is Nothing Then
  MsgBox "Interrupted."
  WScript.Quit 1
End If

Set folderTo = shellObject.BrowseForFolder(0, "Please Select Destination Folder", 0, "C:\")
If folderTo Is Nothing Then
  MsgBox "Interrupted."
  WScript.Quit 1
End If

Set folderFrom = fileSystemObject.getFolder(folderFrom.Self.Path)
Set folderTo = fileSystemObject.getFolder(folderTo.Self.Path)

Sub createBlankFile(ByVal path)
    Dim file
    Set file = fileSystemObject.CreateTextFile(path, True)
    file.Write ""
    file.Close
End Sub

Sub copyAllComponent(ByRef folder, ByRef destinationFolder)
  Dim file
  For Each file in folder.files
    If InStr(file.name, ".") = 0 Then
      createBlankFile(destinationFolder.Path + "\" + file.name)
    End If
  Next

  Dim subfolder
  For Each subfolder in folder.subfolders
    If Right(subfolder.name, 4) = ".sbd" Then
      Dim newFolderName
      newFolderName = destinationFolder.Path + "\" + subfolder.name
      Dim newFolder
      fileSystemObject.createFolder(newFolderName)
      Set newFolder = fileSystemObject.getFolder(newFolderName)
      copyAllComponent subfolder, newFolder
    End If
  Next
End Sub

copyAllComponent folderFrom, folderTo

Set folderFrom = Nothing
Set folderTo = Nothing
Set shellObject = Nothing
Set fileSystemObject = Nothing