特定のフォルダーのサブフォルダーを直下に移動するマクロ


コメントにて以下のようなご要望をいただきました。


連絡先
連絡先\仕事用\仕事999\仕事888
連絡先\仕事用\友人A\友人B\友人C\友人D

上記のような階層構造になってしまった場合、すべてのフォルダを1アクション(バッチ/スクリプト等)で連絡先直下に移動することは可能でしょうか。



以下のようなマクロで実現可能です。なお、連絡先に限定するのは汎用性に欠けるので、現在指定されているフォルダーのサブフォルダーすべてを対象とするという動作にしています。そのため、連絡先の直下に移動するという場合は、連絡先を選択した状態でマクロを実行してください。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub MoveToTop()
    Dim fldTop As Folder
    Dim fldSub As Folder
    ' 現在選択されているフォルダーを最上位フォルダーとする
    Set fldTop = ActiveExplorer.CurrentFolder
    ' 最上位フォルダーのサブ フォルダーをチェック
    For Each fldSub In fldTop.Folders
        MoveToTopRecursive fldSub, fldTop
    Next
End Sub
' 再帰的に処理するサブ プロシージャ
Private Sub MoveToTopRecursive(fldCurrent As Folder, fldTop As Folder)
    Dim i As Integer
    ' サブフォルダーを再帰的に既定の連絡先に移動
    For i = fldCurrent.Folders.Count To 1 Step -1
        MoveToTopRecursive fldCurrent.Folders(i), fldTop
    Next
    ' 処理中のフォルダーの親が最上位フォルダーでない場合のみ
    If fldCurrent.Parent.EntryID <> fldTop.EntryID Then
        ' フォルダー自身を既定の連絡先に移動
        fldCurrent.MoveTo fldTop
    End If
End Sub

マクロの登録方法やメニューへの追加について

特定のフォルダーのサブフォルダーを直下に移動するマクロ」への8件のフィードバック

  1. ありがとうございます。全て連絡先直下のサブフォルダーとなりました。
    1点可能であれば・・・スクリプトを実行すると、強制的に連絡先直下のサブフォルダーとなるようにすることは不可能でしょうか。
    マクロを登録する作業に慣れていない方が多いため、ログオンスクリプト等で自動実行させたいと考えています。

    • マクロをスクリプトにすると以下のようになります。
      Dim appOlk
      Dim fldTop
      Dim fldSub
      Set appOlk = CreateObject(“Outlook.Application”)
      ‘ 現在選択されているフォルダーを最上位フォルダーとする
      Set fldTop = appOlk.ActiveExplorer.CurrentFolder
      ‘ 最上位フォルダーのサブ フォルダーをチェック
      For Each fldSub In fldTop.Folders
      MoveToTopRecursive fldSub, fldTop
      Next
      ‘ 再帰的に処理するサブ プロシージャ
      Private Sub MoveToTopRecursive(fldCurrent, fldTop)
      Dim i
      ‘ サブフォルダーを再帰的に既定の連絡先に移動
      For i = fldCurrent.Folders.Count To 1 Step -1
      MoveToTopRecursive fldCurrent.Folders(i), fldTop
      Next
      ‘ 処理中のフォルダーの親が最上位フォルダーでない場合のみ
      If fldCurrent.Parent.EntryID fldTop.EntryID Then
      ‘ フォルダー自身を既定の連絡先に移動
      fldCurrent.MoveTo fldTop
      End If
      End Sub

  2. ご対応ありがとうございます。
    上記を実行したところ、以下のエラーメッセージが表示されました。

    行:19
    列:30
    エラー:’Then’がありません。
    コード:800A03F9
    ソース:Microsoft VBScripts コンパイル エラー

    原因と対処方法がわかりましたらご教授いただけますでしょうか。
    よろしくお願いします。

    • コメントフィールドにコードを張り付ける際に、不等号記号が削除されてしまったようです。

      If fldCurrent.Parent.EntryID fldTop.EntryID Then

      If Not fldCurrent.Parent.EntryID = fldTop.EntryID Then

      として試してください。

  3. 上記の件、IfとThenの間にを追加することで解決できました。
    が、今度は別のエラーメッセージが表示されました。

    行:8
    列:1
    エラー:オブジェクトがありません。:”
    コード:800A01A8
    ソース:Microsoft VBScripts 実行時 エラー

    Outlook2010を起動(連絡先フォルダを選択)していても、していなくても同じメッセージが表示されます。

    理想は、Outlook2010を起動せずに本スクリプトを実行することで、全ての連絡先フォルダが強制的に「連絡先」直下のサブフォルダーとなることです。
    そのようなことは可能でしょうか。

    ご確認の程、よろしくお願いします。

    • 常に既定の連絡先に対して処理を行うのであれば、
      Set fldTop = appOlk.ActiveExplorer.CurrentFolder

      Set fldTop = appOlk.Session.GetDefaultFolder(10)
      としてください。

      • ご対応ありがとうございます。
        当方が理想とする動作を確認しました。
        本当に助かりました!!

  4. すみません、入れ違いでコメントしてしまいました。

    If Not fldCurrent.Parent.EntryID = fldTop.EntryID Then

    で試してみましたが、以下のエラーメッセージは消えませんでした。

    行:8
    列:1
    エラー:オブジェクトがありません。:”
    コード:800A01A8
    ソース:Microsoft VBScripts 実行時 エラー

    ご確認の程、よろしくお願いします。

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト / 変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト / 変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト / 変更 )

Google+ フォト

Google+ アカウントを使ってコメントしています。 ログアウト / 変更 )

%s と連携中