'********************************************************* ' ' 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 |