VSTマクロを使用してPSTファイルの構造を新しいpstファイルにコピーするには

Question

VSTマクロを使用して年単位でデフォルトのPSTファイルを分割するにはどうすればよいですか？新しいPSTファイル名はYear-2015.pstです。 2015年に属するすべてのメール（すべてのフォルダ）が含まれている必要があります。

Answer 1

通常のイベントでは、質問に対する回答がありません。これは無料のコーディングサービスではありません。このサイトは、プログラマーが互いに助け合うことを可能にするために存在します。あなたが間違ったコードを投稿してその行動があなたが求めているものとどのように異なるのかを説明すれば、誰かがExcel VBAでは数分で、Outlook VBAサイトではゆっくりと役立ちます。

自分のマクロをコーディングしているため、あなたの要件に合っているようです。コメントは、自分が6か月または12か月以内にマクロに戻り、それを更新できるように書くものです。私はそれを使ってテストしました。私は通常、リリース前にマクロを与える体系的なテストは行っていません。それは何も削除されませんので、それが壊れても永久的なダメージはありません。最も可能性の高いエラーは、VBAインタプリタがエラーを報告して停止することだけです。このような場合は、シナリオを説明するコメントを追加し、エラーを修正しようとします。

サブルーチンCtrlMoveEmailsByYearは、書き直しが必要な唯一のマクロです。サブルーチンMoveEmailsByYearとfunction GetCreateFldr2Fullは、この要件を満たすために特別にコーディングされたマクロです。他のすべてのサブルーチンと関数は、私が何年も使ってきた一般的な関数です。

はサブルーチンCtrlMoveEmailsByYear考えてみましょう：

Sub CtrlMoveEmailsByYear() 

    Dim FldrDestRoot As Folder 
    Dim FldrSrcRoot As Folder 

    Set FldrSrcRoot = GetFolderRef("dell", "!Tony") 

    Set FldrDestRoot = GetFolderRef("tony archive 2010") 
    Call MoveEmailsByYear(FldrSrcRoot, FldrDestRoot, 2010) 

    Set FldrDestRoot = GetFolderRef("tony archive 2011") 
    Call MoveEmailsByYear(FldrSrcRoot, FldrDestRoot, 2011) 

End Sub 

を「デルは、」PSTファイルの名前です。以前のラップトップから現在のラップトップにコピーしました。 "！Tony"は私の私的メールを含むPSTファイル内のフォルダです。 「dell」には、私が保存したくない、あるいは別に保存したいと思う他のフォルダが含まれています。

GetFolderRefは私の標準ルーチンの1つです。最初の（強制）パラメーターは、ストアのユーザー/表示名です。 PSTファイルはストアの一種です。 Outlookのフォルダペインの一番左の名前は、ストアのユーザー名または表示名です。 2番目のパラメータ（オプション）は、ストア内のフォルダの名前です。サブとサブのサブフォルダの名前には、3番目、4番目、5番目のパラメータ（必要な深さまで）があります。このルーチンは、指定されたフォルダへの参照が存在する場合にそれを返します。私はGetFolderRefを使って "dell - >！Tony"、 "tony archive 2010"、 "tony archive 2011"への参照を取得しました。

これらの参照はMoveEmailsByYearの呼び出しで使用されています。そのパラメータは、送信元フォルダ、送信先フォルダ、および年です。指定した年のすべてのメールを送信元フォルダから送信先フォルダに移動します。動きは構造を保持します。たとえば、「dell - >！Tony-> Amazon-> TraderA」というフォルダに指定された年のメールが含まれている場合、そのメールは「tony archive 2010-> Amazon-> TraderA」に移動されます。コピー先のフォルダが作成されていない場合は作成されます。

MoveEmailsByYearの適切に構成された呼び出しを使用して、同等のマクロを作成する必要があります。デフォルトの「受信トレイ」は店舗の「Outlookデータファイル」にありますが、メールが保存されている場所ではない可能性があります。フォルダペインの名前を使用します。私のシステムでは、Outlookは電子メールアカウントごとに電子メールアドレスと一致する名前のストアを作成しているので、現在の電子メールアカウントごとに1つの受信ボックスと古いコンピュータごとに1つの受信トレイがあります。

警告：私は何十ものマクロを持っています。私は、MoveEmailsByYearによって使用されるすべてのマクロまたはそれが呼び出すルーチンを抽出したと信じています。 「マクロXxxxxが指定されていません」というレポートが表示された場合は、ごめんなさい。私に教えてください。私はそれを答えに加えます。

Sub MoveEmailsByYear(ByRef FldrSrcRoot As Folder, ByRef FldrDestRoot As Folder, _ 
        ByVal YearToCopy As Long) 

    ' FldrSrcRoot: A folder 
    ' FldrDestRoot: Another folder that cannot be in the same store. 
    ' YearToCopy: A four digit year 

    ' The routine moves emails with a ReceivedTime within YearToCopy from FldrSrcRoot, 
    ' or a folder under FldrSrcRoot, to the equivalent position in FldDestRoot. 
    ' See function GetCreateFldr2Full for information on how the new folder is created. 

    ' The restriction that FldrSrcRoot and FldrDestRoot cannot be in the same store is 
    ' to avoid any possibility that FldrSrcRoot and FldrDestRoot do not overlap to an 
    ' email is moved to a sub-folder within FldrDestRoot and then moved to a 
    ' sub-sub-folder within FldrDestRoot and so on indefinitely. 

    ‘ Coded by Tony Dallimore 

    Dim FldrDestCrnt As Folder 
    Dim FldrSrcCrnt As Folder 
    Dim FldrSrcLast As Folder 
    Dim FldrSrcCrntNames() As String 
    Dim FldrSrcLastNames() As String 
    Dim InxN As Long 
    Dim MailItemCrnt As MailItem 
    Dim NewFldr As Boolean 

    Set FldrSrcLast = Nothing 
    Call GetNextMailItem("I", MailItemCrnt, FldrSrcCrnt, FldrSrcRoot) 

    Do While Not MailItemCrnt Is Nothing 
    With MailItemCrnt 
     If Year(.ReceivedTime) = YearToCopy Then 
     If FldrSrcLast Is Nothing Then 
      ' FldrSrcLast not initialised so this is first mail item from required year 
      NewFldr = True 
     ElseIf FldrSrcLast <> FldrSrcCrnt Then 
      ' Different folders 
      NewFldr = True 
     End If 
     If NewFldr Then 
      FldrSrcLastNames = GetFolderNames(FldrSrcCrnt) 
      Set FldrDestCrnt = GetCreateFldr2Full(FldrSrcRoot, FldrSrcCrnt, FldrDestRoot) 
     End If 
     .Move FldrDestCrnt 
     End If 
    End With 
    Call GetNextMailItem("N", MailItemCrnt, FldrSrcCrnt) 
    Loop 

End Sub 

Public Sub DeNestParamArray(Denested() As Variant, ParamArray Original() As Variant) 

    ' Each time a ParamArray is passed to a sub-routine, it is nested in a one 
    ' element Variant array. This routine finds the bottom level of the nesting and 
    ' sets RetnValue to the values in the original parameter array so that other routines 
    ' need not be concerned with this complication. 

    ' Coded by Tony Dallimore 

    Dim Bounds   As Collection 
    Dim Inx1   As Long 
    Dim Inx2   As Long 
    Dim DenestedCrnt() As Variant 
    Dim DenestedTemp() As Variant 

    DenestedCrnt = Original 
    ' Find bottom level of nesting 
    Do While True 
    If VarType(DenestedCrnt) < vbArray Then 
     ' Have found a non-array element so must have reached the bottom level 
     Debug.Assert False ' Should have exited loop at previous level 
     Exit Do 
    End If 
    Call NumberOfDimensions(Bounds, DenestedCrnt) 
    ' There is one entry in Bounds per dimension in NestedCrnt 
    ' Each entry is an array: Bounds(N)(0) = Lower bound of dimension N 
    ' and Bounds(N)(1) = Upper bound of dimenssion N 
    If Bounds.Count = 1 Then 
     If Bounds(1)(0) > Bounds(1)(1) Then 
     ' The original ParamArray was empty 
     Denested = DenestedCrnt 
     Exit Sub 
     ElseIf Bounds(1)(0) = Bounds(1)(1) Then 
     ' This is a one element array 
     If VarType(DenestedCrnt(Bounds(1)(0))) < vbArray Then 
      ' But it does not contain an array so the user only specified 
      ' one value (a literal or a non-array variable) 
      ' This is a valid exit from this loop 
      Exit Do 
     End If 
     ' The following sometimes crashed Outlook 
     'DenestedCrnt = DenestedCrnt(Bounds(1)(0)) 
     If VarType(DenestedCrnt(Bounds(1)(0))) = vbArray + vbString Then 
      ' DenestedCrnt(Bounds(1)(0))) is an array of strings. 
      ' This is the array sought but it must be converted to an array 
      ' of variants with lower bound = 0 before it can be returned. 
      ReDim Denested(0 To UBound(DenestedCrnt(Bounds(1)(0))) - LBound(DenestedCrnt(Bounds(1)(0)))) 
      Inx2 = LBound(DenestedCrnt) 
      For Inx1 = 0 To UBound(Denested) 
      Denested(Inx1) = DenestedCrnt(Bounds(1)(0))(Inx2) 
      Inx2 = Inx2 + 1 
      Next 
      Exit Sub 
     End If 
     DenestedTemp = DenestedCrnt(Bounds(1)(0)) 
     DenestedCrnt = DenestedTemp 
     Else 
     ' This is a one-dimensional, non-nested array 
     ' This is the usual exit from this loop 
     Exit Do 
     End If 
    Else 
     ' This is an array but not a one-dimensional array 
     ' There is no code for this situation 
     Debug.Assert False 
     Exit Do 
    End If 
    Loop 

    ' Have found bottom level array. Save contents in Return array. 
    If LBound(DenestedCrnt) <> 0 Then 
    ' A ParamArray should have a lower bound of 0. Assume the ParamArray 
    ' was loaded with a 1D array that did not have a lower bound of 0. 
    ' Build Denested so it has standard lbound 
    ReDim Denested(0 To UBound(DenestedCrnt) - LBound(DenestedCrnt)) 
    Inx2 = LBound(DenestedCrnt) 
    For Inx1 = 0 To UBound(Denested) 
     Denested(Inx1) = DenestedCrnt(Inx2) 
     Inx2 = Inx2 + 1 
    Next 
    Else 
    Denested = DenestedCrnt 
    End If 

End Sub 
Function GetCreateFldr2Full(ByRef Fldr1Root As Folder, ByRef Fldr1Full As Folder, _ 
          ByRef Fldr2Root As Folder) As Folder 

    ' Fldr1Root is a folder. 
    ' Fldr1Full is a child of Fld1Root. 
    ' Fldr2Root is another folder. 
    ' The routine returns a reference to folder Fldr2Full where Fldr2Full's 
    ' position within Fldr2Root matches the position of Fldr1Full's 
    ' position within Fldr1Root. 

    ' For example: 
    ' If Fldr1Root is  A->B->C 
    ' and Fldr1Full is  A->B->C->D->E 
    ' and Fldr2Root is  Z->Y->X 
    ' then Fldr2Full will be Z->Y->X->D->E 

    ' Fldr1Root, Fldr1Full and Fldr2Roor must exist. 
    ' Fldr1Full must be a child of Fldr1Root. 
    ' If either of the above conditions are not met, the routine returns Nothing. 
    ' The routine will find Fldr2Full if it already exists or create it if it does not. 

    ' Coded by Tony Dallimore 

    Dim Fldr1FullNames() As String 
    Dim Fldr1RootNames() As String 
    Dim Fldr2Chld As Folder 
    Dim Fldr2Crnt As Folder 
    Dim Fldr2FullNames() As String 
    Dim Fldr2RootNames() As String 
    Dim InxFull1Crnt As Long 

    Fldr1RootNames = GetFolderNames(Fldr1Root) 
    Fldr1FullNames = GetFolderNames(Fldr1Full) 
    Fldr2RootNames = GetFolderNames(Fldr2Root) 

    If UBound(Fldr1RootNames) >= UBound(Fldr1FullNames) Then 
    ' The full name is not longer than the root name so it cannot be a child 
    Debug.Assert False 
    Set GetCreateFldr2Full = Nothing 
    Exit Function 
    End If 

    ' Match names within Fldr1Root and Fldr1Full to: 
    ' * Check Fldr1Full is within Fldr1Root 
    ' * Find "tail" that will have to be added to Fldr2Root to create Fldr2Full 
    For InxFull1Crnt = 0 To UBound(Fldr1RootNames) 
    If Fldr1RootNames(InxFull1Crnt) <> Fldr1FullNames(InxFull1Crnt) Then 
     ' The root name does not match the start of the full name 
     Set GetCreateFldr2Full = Nothing 
     Exit Function 
    End If 
    Next 

    ' UBound(Fldr1RootName) + 1 To UBound(Fldr1FullName) is the "tail" of 
    ' Fldr1Full. Check there is an identical tail for Fldr2Root and, if there 
    ' isn't, create it. 
    Set Fldr2Crnt = Fldr2Root 
    For InxFull1Crnt = UBound(Fldr1RootNames) + 1 To UBound(Fldr1FullNames) 
    Err.Clear 
    Set Fldr2Chld = Nothing 
    On Error Resume Next 
    Set Fldr2Chld = Fldr2Crnt.Folders(Fldr1FullNames(InxFull1Crnt)) 
    On Error GoTo 0 
    If Fldr2Chld Is Nothing Then 
     ' Fldr2Crnt.Folders(Fldr1FullName(InxFull1Crnt)) does not exist 
     ' so create it 
     Set Fldr2Chld = Fldr2Crnt.Folders.Add(Fldr1FullNames(InxFull1Crnt)) 
     ' Since folder did not exist within Fldr2Root, its children can't exist 
     ' either. I could take advantage of this knowledge and not check existence 
     ' of children but I think it is simpler not to. 
    End If 
    Set Fldr2Crnt = Fldr2Chld 
    Next 

    Set GetCreateFldr2Full = Fldr2Crnt 

End Function 
Function GetFolderNames(ByRef Fldr As Folder) As String() 

    ' * Fldr is a folder. It could be a store, the child of a store, 
    ' the grandchild of a store or more deeply nested. 
    ' * Return the name of that folder as a string array in the sequence: 
    ' (0)=StoreName (1)=Level1FolderName (2)=Level2FolderName ... 

    ' Coded by Tony Dallimore 

    Dim FldrCrnt As Folder 
    Dim FldrNameCrnt As String 
    Dim FldrNames() As String 
    Dim FldrNamesRev() As String 
    Dim FldrPrnt As Folder 
    Dim InxFn As Long 
    Dim InxFnR As Long 

    Set FldrCrnt = Fldr 
    FldrNameCrnt = FldrCrnt.Name 
    ReDim FldrNamesRev(0 To 0) 
    FldrNamesRev(0) = Fldr.Name 
    ' Loop getting parents until FldrCrnt has no parent. 
    ' Add names of Fldr and all its parents to FldrName as they are found 
    Do While True 
    Set FldrPrnt = Nothing 
    On Error Resume Next 
    Set FldrPrnt = FldrCrnt.Parent 
    On Error GoTo 0 
    If FldrPrnt Is Nothing Then 
     ' FldrCrnt has no parent 
     Exit Do 
    End If 
    ReDim Preserve FldrNamesRev(0 To UBound(FldrNamesRev) + 1) 
    FldrNamesRev(UBound(FldrNamesRev)) = FldrPrnt.Name 
    Set FldrCrnt = FldrPrnt 
    Loop 

    ' Copy names to FldrNames in reverse sequence so they end up in the correct sequence 
    ReDim FldrNames(0 To UBound(FldrNamesRev)) 
    InxFn = 0 
    For InxFnR = UBound(FldrNamesRev) To 0 Step -1 
    FldrNames(InxFn) = FldrNamesRev(InxFnR) 
    InxFn = InxFn + 1 
    Next 

    GetFolderNames = FldrNames 

End Function 
Public Function GetFolderRef(ParamArray FolderNames() As Variant) As Folder 

    ' FolderNames can be used as a conventional ParamArray: a list of values. Those 
    ' Values must all be strings. 
    ' Alternatively, its parameter can be a preloaded one-dimensional array of type 
    ' Variant or String. If of type Variant, the values must all be strings. 
    ' The first, compulsory, entry in FolderNames is the name of a Store. 
    ' Each subsequent, optional, entry in FolderNames is the name of a folder 
    ' within the folder identified by the previous names. Example calls: 
    ' 1) Set Fldr = GetFolderRef("outlook data file") 
    ' 2) Set Fldr = GetFolderRef("outlook data file", "Inbox", "Processed") 
    ' 3) MyArray = Array("outlook data file", "Inbox", "Processed") 
    '  Set Fldr = GetFolderRef(MyArray) 
    ' Return a reference to the folder identified by the names or Nothing if it 
    ' does not exist 

    ' Coded by Tony Dallimore 

    Dim FolderNamesDenested() As Variant 
    Dim ErrNum As Long 
    Dim FldrChld As Folder 
    Dim FldrCrnt As Folder 
    Dim InxP As Long 

    ' See sub DeNestParamArray for an explanation of its purpose. 
    Call DeNestParamArray(FolderNamesDenested, FolderNames) 

    If LBound(FolderNamesDenested) > UBound(FolderNamesDenested) Then 
    ' No names specified 
    Set GetFolderRef = Nothing 
    Exit Function 
    End If 

    For InxP = 0 To UBound(FolderNamesDenested) 
    If VarType(FolderNamesDenested(InxP)) <> vbString Then 
     ' Value is not a string 
     Debug.Assert False  ' Fatal error 
     Set GetFolderRef = Nothing 
     Exit Function 
    End If 
    Next 

    Set FldrCrnt = Nothing 
    On Error Resume Next 
    Set FldrCrnt = Session.Folders(FolderNamesDenested(0)) 
    On Error GoTo 0 
    If FldrCrnt Is Nothing Then 
    ' Store name not recognised 
    Debug.Print FolderNamesDenested(0) & " is not recognised as a store" 
    Debug.Assert False  ' Fatal error 
    Set GetFolderRef = Nothing 
    Exit Function 
    End If 

    For InxP = 1 To UBound(FolderNamesDenested) 
    Set FldrChld = Nothing 
    On Error Resume Next 
    Set FldrChld = FldrCrnt.Folders(FolderNamesDenested(InxP)) 
    On Error GoTo 0 
    If FldrChld Is Nothing Then 
     ' Folder name not recognised 
     Debug.Print FolderNamesDenested(InxP) & " is not recognised as a folder within " & _ 
        Join(GetFolderNames(FldrCrnt), "->") 
     Debug.Assert False ' Fatal error 
     Set GetFolderRef = Nothing 
     Exit Function 
    End If 
    Set FldrCrnt = FldrChld 
    Set FldrChld = Nothing 
    Next 

    Set GetFolderRef = FldrCrnt 

End Function 
Public Sub GetNextMailItem(ByVal Action As String, ByRef MailItemNext As MailItem, _ 
          ByRef MailItemFolder As Folder, _ 
          ParamArray Params() As Variant) 

    ' Each call returns the next mail item from the specified folder or folder list. 
    ' It may be called repeatedly until all mail items in the specified folder or 
    ' folder list have been returned 

    ' On return, if MailItemNext is Nothing, there are no [more] mail items in the 
    ' specified folder or folder list. Otherwise, MailItemNext is a reference to the next 
    ' mail item and MailItemFolderName contains the name of the folder. See below for 
    ' format of folder names used by this routine. 

    ' * If Action = "I", the routine initialises itself and then returns the first mail 
    ' item, if any, in the first specified folder. 
    ' * If Action = "N", the routine returns the next mail item, if any, from its list of 
    ' folders. Params() is ignored since values were stored during the Action = "I" call. 
    ' * MailItemNext will be Nothing if no [more] mail items are present in the folder or 
    ' folder list to search. 
    ' * MailItemFolder is the the folder containing MailItemNext. 
    ' * Params is only used if Action = "I" 
    ' * Each value in Params, if any, is a folders to be searched for emails. If Params is 
    ' empty, every folder in every store will be searched for emails. 

    ' Example uses: 
    ' 
    ' Call GetMailItemNext("I", MailItemCrnt, MainItemPrntName) 
    ' Do While Not MailItemCrnt Is Nothing 
    '  ' Process mail item 
    '  Call GetMailItemNext("N", MailItemCrnt, MainItemPrntName) 
    ' Loop 
    ' or 
    ' Set FldrSrcRoot = GetFolderRef("outlook data file" & vbTab & "Inbox") 
    ' Call GetMailItemNext("I", MailItemCrnt, MainItemPrntName, vbTab, FldrSrcRoot) 
    ' Do While Not MailItemCrnt Is Nothing 
    '  ' Process mail item 
    '  Call GetMailItemNext("N", MailItemCrnt, MainItemPrntName) 
    ' Loop 
    ' 
    ' Coded by Tony Dallimore 

    ' The routine uses three static variables: 
    ' 1) name of folder holding pending mail items 
    ' 2) collection MailItemsPending 
    ' 4) collection FolderSearchPending 

    ' * The first part of the routine is only executed if Action = "I". It analyses 
    ' the values in Params, if any, and initialises the static variables as 
    ' appropriate. 
    ' * The second part of the routine is a loop which is always executed. Each 
    ' repeat of the loop: 
    ' * If MailItemsPending contains any mail items, the first mail item 
    '  is removed from the collection and returned to the caller in 
    '  MailItemNext and MailItemFolderName. 
    ' * if FolderSearchPending is empty, MailItemNext is set to Nothing 
    '  and the routine exits. 
    ' * The first folder in FolderSearchPending is removed from the collection 
    '  and processed as follows: 
    '  * If this folder contains mail items, they are added to MailItemsPending. 
    '  * If this folder has any sub-folders, they are added to the beginning of 
    '   FolderSearchPending. 
    ' * The loop repeats to process the first new mail item, if any, or the next 
    '  search folder, if any. 

    Static FolderMainItem() As String 
    ' Values in MailItemsPending are arrays with two entries. Entry 0 is a reference to 
    ' the folder holding the mail item. Entry 1 is a reference to the mail item. 
    Static MailItemsPending As New Collection 
    ' Values in FolderSearchsPending are references to folders. 
    Static FolderSearchsPending As New Collection 

    Dim FolderChld As Folder 
    Dim FolderChldNameStr As String 
    Dim InxChld As Long ' Index into child folders of folder 
    Dim InxInsert As Long ' Position within collection at which new 
         ' element is to be inserted 
    Dim InxItm As Long  ' Index into mail items within folder 
    Dim InxPrm As Long  ' Index into Params 
    Dim FolderSearch As Folder 
    Dim FolderSearchNameArr As String 
    Dim FolderSearchNameStr As String 

    If LCase(Action) = "n" Then 
    ' Drop through to handle next mail item 
    ElseIf LCase(Action) = "i" Then 
    ' Code for Action = "I" 
    If UBound(Params) = -1 Then 
     ' No search folders specified 
     ' Search every folder in every store 
     With Session 
     For InxChld = 1 To .Folders.Count 
      Set FolderChld = .Folders(InxChld) 
      FolderSearchsPending.Add FolderChld 
     Next 
     End With 
    Else 
     ' One or more search folders specified 
     For InxPrm = 0 To UBound(Params) 
     If TypeOf Params(InxPrm) Is Folder Then 
      FolderSearchsPending.Add Params(InxPrm) 
     Else 
      Debug.Print "The " & InxPrm + 5 & "th parameter in the call of GetNextMailItem" & _ 
         " is not a string. It should be a reference to a folder." 
      Debug.Assert False  ' Fatal error 
      Set MailItemNext = Nothing 
      Exit Sub 
     End If 
     Next 
    End If 
    Else 
    ' Invalid value for Action 
    Set MailItemNext = Nothing 
    Exit Sub 
    End If 

    ' Loop until have mail item to return or there are no [more] mail items to return 
    Do While True 
    If MailItemsPending.Count > 0 Then 
     ' Extract values from first entry for return to caller and then remove first entry 
     Set MailItemFolder = MailItemsPending(1)(0) 
     Set MailItemNext = MailItemsPending(1)(1) 
     MailItemsPending.Remove 1 
     Exit Sub 
    ElseIf FolderSearchsPending.Count = 0 Then 
     ' No more folders to search 
     Set MailItemNext = Nothing 
     Set MailItemFolder = Nothing 
     Exit Sub 
    Else 
     ' Extract first search folder, process and store results if any 
     Set FolderSearch = FolderSearchsPending(1) 
     FolderSearchsPending.Remove 1 
     If Not FolderSearch.Parent Is Nothing Then 
     ' This is not a store so it is a folder that could contain mail items 
     For InxItm = 1 To FolderSearch.Items.Count 
      If TypeOf FolderSearch.Items(InxItm) Is MailItem Then 
      MailItemsPending.Add VBA.Array(FolderSearch, _ 
              FolderSearch.Items(InxItm)) 
      End If 
     Next 
     End If 
     ' Now add any children to the start of FolderSearchsPending 
     InxInsert = 1 ' Insertion point of first child folder 
     For InxChld = 1 To FolderSearch.Folders.Count 
     With FolderSearch.Folders(InxChld) 
      Select Case .Name 
      Case "Calendar", "Contacts", "Journal", "Notes", "Tasks", "RSS Feeds", _ 
       "Conversation Action Settings", "Quick Step Settings" 
       ' Ignore folders that cannot (should not?) contain mail items 
      Case "Deleted Items" 
       ' Ignore mail items deleted by user 
      Case Else 
       ' This folder can contain mail items 
       If InxInsert < FolderSearchsPending.Count Then 
       ' Insert new element before at least one existing element 
       FolderSearchsPending.Add Item:=FolderSearch.Folders(InxChld), Before:=InxInsert 
       Else 
       ' Add new element after any existing elements 
       FolderSearchsPending.Add FolderSearch.Folders(InxChld) 
       End If 
       ' Insert any further children after child just added 
       InxInsert = InxInsert + 1 
      End Select 
     End With 
     Next 
    End If 
    Loop 

End Sub 
Public Function NumberOfDimensions(ByRef Bounds As Collection, _ 
            ParamArray Params() As Variant) As Long 

    ' Example calls of this routine are: 
    ' NumDim = NumberOfDimensions(Bounds, MyArray) 
    ' or NumDim = NumberOfDimensions(Bounds, Worksheets("Sheet1").Range("D4:E20")) 

    ' * Returns the number of dimensions of Params(LBound(Params)). Param is a ParamArray. 
    ' MyArray, in the example call, is held as the first element of array Params. That is 
    ' it is held as Params(LBound(Params)) or Params(LBdP) where LBdP = LBound(Params). 
    ' * If the array to test is a regular array, then, in exit, for each dimension, the lower 
    ' and upper bounds are recorded in Bounds. Entries in Bounds are zero-based arrays 
    ' with two entries: lower bound and upper bound. 
    ' * If the array is a worksheet range, the lower bound values in Bounds are 1 and the 
    ' upper bound values are the number of rows (first entry in Bounds) or columns (second 
    ' entry in Bounds) 
    ' * The collection Bounds is of most value to routines that can be pased an array as 
    ' a parameter but does not know if that array is a regular array or a range. The values 
    ' returned in Bounds means that whether the test array is a regular array or a range, 
    ' its elements can be accessed so: 
    '  For InxDim1 = Bounds(0)(0) to Bounds(0)(1) 
    '  For InxDim2 = Bounds(1)(0) to Bounds(1)(1) 
    '   : : : 
    '  Next 
    '  Next 

    ' If there is an official way of determining the number of dimensions, I cannot find it. 

    ' This routine tests for dimension 1, 2, 3 and so on until it get a failure. 
    ' By trapping that failure it can determine the last test that did not fail. 

    ' * Params() is a ParamArray because it allows the passing of arrays of any type. 
    ' * The array to be tested in not Params but Params(LBound(Params)). 
    ' * The routine does not check for more than one parameter. If the call was 
    ' NumDim(Bounds, MyArray1, MyArray2), it would ignore MyArray2. 

    ' Coded by Tony Dallimore 

    Dim InxDim As Long 
    Dim Lbd As Long 
    Dim LBdC As Long 
    Dim LBdP As Long 
    Dim LBdR As Long 
    Dim NumDim As Long 
    Dim TestArray As Variant 
    Dim UBdC As Long 
    Dim UBdR As Long 

    Set Bounds = New Collection 

    If VarType(Params(LBound(Params))) < vbArray Then 
    ' Variable to test is not an array 
    NumberOfDimensions = 0 
    Exit Function 
    End If 

    On Error Resume Next 

    LBdP = LBound(Params) 

    TestArray = Params(LBdP) 

    NumDim = 1 
    Do While True 
    Lbd = LBound(TestArray, NumDim) 
    'Lbd = LBound(Params(LBdP), NumDim) 
    If Err.Number <> 0 Then 
     If NumDim > 1 Then 
     ' Only known reason for failing is because array 
     ' does not have NumDim dimensions 
     NumberOfDimensions = NumDim - 1 
     On Error GoTo 0 
     For InxDim = 1 To NumberOfDimensions 
      Bounds.Add VBA.Array(LBound(TestArray, InxDim), UBound(TestArray, InxDim)) 
      'Bounds.Add VBA.Array(LBound(Params(LBdP), InxDim), _ 
           UBound(Params(LBdP), InxDim)) 
     Next 
     Exit Function 
     Else 
     Err.Clear 
     Bounds.Add VBA.Array(TestArray.Row, TestArray.Rows.Count - TestArray.Row + 1) 
     Bounds.Add VBA.Array(TestArray.Column, TestArray.Columns.Count - TestArray.Column + 1) 
     If Err.Number <> 0 Then 
      ' I do not know how got here. Investigate 
      Debug.Assert False 
      NumberOfDimensions = 0 
      Exit Function 
     End If 
     On Error GoTo 0 
     NumberOfDimensions = 2 
     Exit Function 
     End If 

    End If 
    NumDim = NumDim + 1 
    Loop 

End Function