如何通过VBA宏分拆我的默认PST文件，例如New Pst File Name可能是Year-2015.pst。它应该包含所有属于2015年的邮件（所有文件夹）。
答案 0 :(得分：0)
在正常的活动过程中，您的问题没有任何答案。这不是免费的编码服务。该站点的存在是为了允许程序员互相帮助开发。如果您发布有缺陷的代码并解释其行为与您所寻求的行为有何不同，则有人会在Excel VBA上在几分钟内提供帮助，但在Outlook VBA网站上却会更慢。
你得到这个答案是因为我为自己编写了一个符合你要求的宏。这些评论是我写的，允许自己在六到十二个月内返回宏并更新它。我用它来测试它。它没有进行系统测试，我通常会在发布之前给出一个宏。它不会删除任何内容，因此如果失败则不会造成任何永久性损坏。最可能的失败是它会在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
“dell”是PST文件的名称。我从早期的笔记本电脑上将它复制到我当前的笔记本“！Tony”是PST文件中包含我的私人电子邮件的文件夹。 “dell”包含其他文件夹，我不想保存或希望以不同方式保存。
GetFolderRef是我的标准程序之一。第一个（强制）参数是商店的用户/显示名称。 PST文件是一种商店。 Outlook文件夹窗格中最左侧的名称是商店的用户/显示名称。第二个（可选）参数是商店中文件夹的名称。对于子文件夹和子子文件夹的名称，可以有第三，第四，第五参数（最多需要任何深度）。例程返回对指定文件夹的引用（如果存在）。我使用GetFolderRef来引用“dell-＆gt;！Tony”，“tony archive 2010”和“tony archive 2011”
这些引用用于MoveEmailsByYear的调用。它的参数是源文件夹，目标文件夹和年份。它将指定年份的所有电子邮件从源文件夹移动到目标文件夹。此举保留了结构。例如，如果文件夹“dell-＆gt;！Tony-＆gt; Amazon-＆gt; TraderA“包含来自指定年份的电子邮件，该电子邮件将被移至”tony archive 2010-＆gt; Amazon-＆gt; TraderA“。如果目标文件夹尚不存在，则将创建该目标文件夹。
您需要使用MoveEmailsByYear的适当构造调用创建等效的宏。默认的“收件箱”位于商店“展望数据文件”中，但可能不是您的电子邮件所在的位置。使用文件夹窗格中的名称。在我的系统上，Outlook为每个电子邮件帐户创建了一个商店，其名称与电子邮件地址相匹配，因此每个当前电子邮件帐户都有一个收件箱，另外每个旧计算机都有一个。
警告：我有几十个宏。我相信我已经提取了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