Outlookフォルダの階層構造だけコピーする方法

初出:2003/12/20
改定:2003/12/20

1.概要

 Outlookの受信トレイ内に作った大量のフォルダ階層だけを、ローカルの受信トレイにも作りたい、という要望をエンドユーザーから受けた。筆者の調べた限りではそのように階層だけをコピーする機能がOutlookには無く、やるとすれば受信トレイのデータを全部ローカルの受信トレイにコピーしてメールデータだけ消す、というなんとも時間のかかるめんどくさいことをしなければならない。
 そこで、Outlook VBAを使ってこれを実現することにした。Outlook内に記述すると持ち運びがきかないため、VBScriptファイルとして作成した。これを使えばわずか数秒で、Outlookフォルダの階層構造のみコピーすることが出来る。

 

2.スクリプト紹介

 以下の通り。


'*********************************************************
'
'  Outlookフォルダの階層構造のみコピーするスクリプト
'
'  Programmed by H'Imagine.
'
'*********************************************************

'<目的>
'このスクリプトは、Outlookの受信トレイ内に作成した複数の子フォルダを、
'ローカルの個人用フォルダへフォルダ階層のみコピーしてほしい、という要請を受けて
'作成されました。

'<使い方>
'1.Outlookを起動します。
'2.このファイルをダブルクリックして実行します。
'3.フォルダの選択ダイアログが表示されるので、コピー「元」のフォルダを選択します。
'4.再度フォルダの選択ダイアログが表示されるので、コピー「先」のフォルダを選択します。
'5.フォルダがコピーされ、「終了しました」というダイアログが出たら完了です。

'※注意:
'最上位フォルダ(例えば受信トレイや個人用フォルダ)をコピー元・コピー先に選択してください。
'子フォルダを選択した場合の動作保証はしかねます。

'<動作確認>
'・OS: Windows2000/XP
'・Office: Outlook2000/XP

'<更新履歴>
'2003/12/18 ver 1.01
'・Outlookフォルダの選択ダイアログを表示できるようにする
'2003/12/08 ver 1.00
'・初版作成

Option Explicit

Main

'========================================================
'  始め
'========================================================
Sub Main()
    Dim SourceFolder, DestFolder
    Dim Success
    
    'Outlookフォルダの選択
    Success = OutlookSelectFolder(SourceFolder, DestFolder)
    If Success Then
        'Outlookフォルダ構造のコピー
        OutlookCopyFolderStructure SourceFolder, DestFolder
        MsgBox "終了しました。"
    Else
        MsgBox "操作は取り消されました。"
    End If
End Sub


'========================================================
'  Outlookフォルダの選択
'========================================================
Function OutlookSelectFolder(Source, Dest)
    Dim myOlApp, myNameSpace
    
    Set myOlApp = CreateObject("Outlook.Application")  'お約束
    Set myNameSpace = myOlApp.GetNamespace("MAPI")     'お約束
    
    'Outlookフォルダ選択ダイアログを表示
    Set Source = myNameSpace.PickFolder
    Set Dest = myNameSpace.PickFolder
    
    OutlookSelectFolder = (Not Source is Nothing) And (Not Dest is Nothing)
End Function


'========================================================
'  Outlookフォルダ構造のコピー
'========================================================
Sub OutlookCopyFolderStructure(Source, Dest)
    'Outlookフォルダの作成
    CreateFolders Source, Dest
End Sub


'========================================================
'  Outlookフォルダの作成
'========================================================
Sub CreateFolders(Source, Dest)
    Dim SourceItem, DestItem
    
    '再起処理でフォルダ階層を作っていく
    For Each SourceItem In Source.Folders
        On Error Resume Next
        Set DestItem = Dest.Folders.Add(SourceItem.Name)
        CreateFolders SourceItem, DestItem
    Next
End Sub

 

3.ダウンロード

 スクリプトファイルはこちらでダウンロードできる。

表紙へ


Copyright © 2003 H'Imagine.
All rights reserved.