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