18

私はVBAとマクロの初心者です。誰かが VBA コードとマクロで私を助けてくれれば、それは役に立ちます。

毎日、「タスク完了」という標準的な件名のメールを約 50 ~ 60 通受け取ります。特定のフォルダー「タスク完了」に移動するすべてのメールにルールを作成しました。

1 日に 50 ~ 60 通のメールをすべて読み、すべてのメールを更新するには、非常に時間がかかります。私の受信トレイに届く 50 ~ 60 通のメールはすべて同じ件名ですが、別のユーザーからのものです。メールの本文は異なります。

Outlook 2010 と Excel 2010 を使用しています。

ここに画像の説明を入力

4

2 に答える 2

24

何をコピーする必要があるかについて言及していないので、以下のコードではそのセクションを空のままにしました。

また、最初に電子メールをフォルダーに移動してから、そのフォルダーでマクロを実行する必要はありません。受信メールでマクロを実行し、同時にフォルダに移動することができます。

これで始められます。あなたがそれを理解するのに問題に直面しないように、私はコードにコメントしました。

まず、以下のコードをOutlookモジュールに貼り付けます。

それで

  1. [ツール]~~>[ルールとアラート]をクリックします
  2. 「新しいルール」をクリックします
  3. 「空白のルールから開始」をクリックします
  4. [メッセージが到着したら確認する]を選択します
  5. 条件の下で、「件名に特定の単語を含む」をクリックします
  6. ルールの説明の下にある「特定の単語」をクリックします。
  7. ポップアップ表示されるダイアログボックスにチェックしたい単語を入力し、「追加」をクリックします。
  8. [OK]をクリックして、[次へ]をクリックします
  9. 「指定したフォルダに移動する」を選択し、同じボックスで「スクリプトを実行する」も選択します
  10. 下のボックスで、実行する特定のフォルダーとスクリプト(モジュールにあるマクロ)を指定します。
  11. [完了]をクリックすると完了です。

新しい電子メールが到着すると、電子メールは指定したフォルダーに移動するだけでなく、そこからのデータもExcelにエクスポートされます。

コード

Const xlUp As Long = -4162

Sub ExportToExcel(MyMail As MailItem)
    Dim strID As String, olNS As Outlook.Namespace
    Dim olMail As Outlook.MailItem
    Dim strFileName As String
    
    '~~> Excel Variables
    Dim oXLApp As Object, oXLwb As Object, oXLws As Object
    Dim lRow As Long
    
    strID = MyMail.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)
    
    '~~> Establish an EXCEL application object
    On Error Resume Next
    Set oXLApp = GetObject(, "Excel.Application")
    
    '~~> If not found then create new instance
    If Err.Number <> 0 Then
        Set oXLApp = CreateObject("Excel.Application")
    End If
    Err.Clear
    On Error GoTo 0
    
    '~~> Show Excel
    oXLApp.Visible = True
    
    '~~> Open the relevant file
    Set oXLwb = oXLApp.Workbooks.Open("C:\Sample.xls")
    
    '~~> Set the relevant output sheet. Change as applicable
    Set oXLws = oXLwb.Sheets("Sheet1")
    
    lRow = oXLws.Range("A" & oXLApp.Rows.Count).End(xlUp).Row + 1
    
    '~~> Write to outlook
    With oXLws
        '
        '~~> Code here to output data from email to Excel File
        '~~> For example
        '
        .Range("A" & lRow).Value = olMail.Subject
        .Range("B" & lRow).Value = olMail.SenderName
        '
    End With
    
    '~~> Close and Clean up Excel
    oXLwb.Close (True)
    oXLApp.Quit
    Set oXLws = Nothing
    Set oXLwb = Nothing
    Set oXLApp = Nothing
    
    Set olMail = Nothing
    Set olNS = Nothing
End Sub

ファローアップ

メール本文からコンテンツを抽出するには、SPLIT()を使用して内容を分割し、そこから関連情報を解析します。この例を参照してください

Dim MyAr() As String

MyAr = Split(olMail.body, vbCrLf)

For i = LBound(MyAr) To UBound(MyAr)
    '~~> This will give you the contents of your email
    '~~> on separate lines
    Debug.Print MyAr(i)
Next i
于 2012-08-09T05:50:10.600 に答える
19

新しい紹介 2

以前のバージョンのマクロ「SaveEmailDetails」では、次のステートメントを使用して受信トレイを見つけました。

Set FolderTgt = CreateObject("Outlook.Application"). _
              GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)

その後、新しいバージョンの Outlook をインストールしましたが、既定の受信トレイを使用していないことがわかりました。私の電子メールアカウントごとに、それぞれ独自の受信トレイを持つ個別のストア (電子メールアドレスにちなんで名付けられた) が作成されました。これらの受信ボックスはどれもデフォルトではありません。

このマクロは、既定の受信トレイを保持しているストアの名前をイミディエイト ウィンドウに出力します。

Sub DsplUsernameOfDefaultStore()

  Dim NS As Outlook.NameSpace
  Dim DefaultInboxFldr As MAPIFolder

  Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
  Set DefaultInboxFldr = NS.GetDefaultFolder(olFolderInbox)

  Debug.Print DefaultInboxFldr.Parent.Name

End Sub

私のインストールでは、これは「Outlook Data File」を出力します。

任意のストアの受信トレイにアクセスする方法を示すマクロ "SaveEmailDetails" に追加のステートメントを追加しました。

新規紹介1

多くの人が以下のマクロを手に取り、それが有用であることを発見し、さらなるアドバイスを求めて私に直接連絡してきました. これらの連絡に従って、マクロにいくつかの改善を加えたので、改訂版を以下に掲載しました。また、Outlook 階層を持つ任意のフォルダーの MAPIFolder オブジェクトを一緒に返すマクロのペアも追加しました。これらは、既定のフォルダー以外にアクセスする場合に便利です。

元のテキストは、日付ごとに 1 つの質問を参照しており、以前の質問にリンクしていました。最初の質問が削除されたため、リンクが失われました。そのリンクは、Outlook メールに基づいて Excel シートを更新することでした (終了)

原文

「Outlook の電子メールから Excel ブックにデータを抽出するにはどうすればよいですか?」という質問には、驚くほど多くのバリエーションがあります。たとえば、[outlook-vba] に関する 2 つの質問は、同じ質問が 8 月 13 日に行われました。その質問は、私が答えようとした 12 月のバリエーションを参照しています。

12 月の質問については、2 つの部分からなる回答でやり過ぎました。最初の部分は、Outlook フォルダー構造を調査し、テキスト ファイルまたは Excel ブックにデータを書き込む一連の教育用マクロでした。第 2 部では、抽出プロセスの設計方法について説明しました。この質問に対して、Siddarth は優れた簡潔な回答と、次の段階に役立つフォローアップを提供しました。

すべてのバリエーションの質問者が理解できないように見えるのは、データが画面上でどのように見えるかを示しても、テキストまたは html 本体がどのように見えるかがわからないということです。この回答は、その問題を乗り越えるための試みです。

以下のマクロは、Siddarth のものよりも複雑ですが、12 月の回答に含めたマクロよりもはるかに単純です。追加できるものは他にもありますが、最初はこれで十分だと思います。

このマクロは、新しい Excel ワークブックを作成し、受信トレイ内のすべての電子メールの選択されたプロパティを出力して、このワークシートを作成します。

マクロで作成したワークシートの例

マクロの上部近くに、8 つのハッシュ (#) を含むコメントがあります。そのコメントの下のステートメントは、Excel ワークブックが作成されるフォルダーを識別するため、変更する必要があります。

ハッシュを含む他のすべてのコメントは、マクロを要件に適合させるための修正を示唆しています。

データが抽出される電子メールはどのように識別されますか? 送信者、件名、本文内の文字列、またはこれらすべてですか? コメントは、興味のない電子メールを排除するのに役立ちます。質問を正しく理解できれば、興味深いメールにはSubject = "Task Completed".

コメントは、興味深いメールからデータを抽出するのに役立ちませんが、ワークシートには、メール本文のテキストと HTML の両方のバージョンが存在する場合は表示されます。私の考えでは、マクロが何を見るかを確認し、抽出プロセスの設計を開始できます。

これは上の画面イメージには示されていませんが、マクロはテキスト本文に 2 つのバージョンを出力します。最初のバージョンは変更されていません。つまり、タブ、キャリッジ リターン、ライン フィードは順守され、改行以外のスペースはスペースのように見えます。2 番目のバージョンでは、これらのコードを文字列 [TB]、[CR]、[LF]、および [NBSP] に置き換えて、表示できるようにしました。私の理解が正しければ、2 番目の本文には次のように表示されるはずです。

Activity[TAB]Count[CR][LF]Open[TAB]35[CR][LF]HCQA[TAB]42[CR][LF]HCQC[TAB]60[CR][LF]HAbst[TAB]50 45 5 2 2 1[CR][LF] など

この文字列の元から値を抽出することは難しくありません。

電子メールのプロパティに加えて、抽出された値を出力するようにマクロを修正してみます。この変更に成功した場合にのみ、抽出したデータを既存のワークブックに書き込もうとします。また、処理済みのメールを別のフォルダーに移動します。これらの変更を行う必要がある場所を示しましたが、それ以上の助けはありません。この情報が必要なところまで来たら、補足質問にお答えします。

幸運を。

元のテキストに含まれるマクロの最新バージョン

Option Explicit
Public Sub SaveEmailDetails()

  ' This macro creates a new Excel workbook and writes to it details
  ' of every email in the Inbox.

  ' Lines starting with hashes either MUST be changed before running the
  ' macro or suggest changes you might consider appropriate.

  Dim AttachCount As Long
  Dim AttachDtl() As String
  Dim ExcelWkBk As Excel.Workbook
  Dim FileName As String
  Dim FolderTgt As MAPIFolder
  Dim HtmlBody As String
  Dim InterestingItem As Boolean
  Dim InxAttach As Long
  Dim InxItemCrnt As Long
  Dim PathName As String
  Dim ReceivedTime As Date
  Dim RowCrnt As Long
  Dim SenderEmailAddress As String
  Dim SenderName As String
  Dim Subject As String
  Dim TextBody As String
  Dim xlApp As Excel.Application

  ' The Excel workbook will be created in this folder.
  ' ######## Replace "C:\DataArea\SO" with the name of a folder on your disc.
  PathName = "C:\DataArea\SO"

  ' This creates a unique filename.
  ' #### If you use a version of Excel 2003, change the extension to "xls".
  FileName = Format(Now(), "yymmdd hhmmss") & ".xlsx"

  ' Open own copy of Excel
  Set xlApp = Application.CreateObject("Excel.Application")
  With xlApp
    ' .Visible = True         ' This slows your macro but helps during debugging
    .ScreenUpdating = False ' Reduces flash and increases speed
    ' Create a new workbook
    ' #### If updating an existing workbook, replace with an
    ' #### Open workbook statement.
    Set ExcelWkBk = xlApp.Workbooks.Add
    With ExcelWkBk
      ' #### None of this code will be useful if you are adding
      ' #### to an existing workbook.  However, it demonstrates a
      ' #### variety of useful statements.
      .Worksheets("Sheet1").Name = "Inbox"    ' Rename first worksheet
      With .Worksheets("Inbox")
        ' Create header line
        With .Cells(1, "A")
          .Value = "Field"
          .Font.Bold = True
        End With
        With .Cells(1, "B")
          .Value = "Value"
          .Font.Bold = True
        End With
        .Columns("A").ColumnWidth = 18
        .Columns("B").ColumnWidth = 150
      End With
    End With
    RowCrnt = 2
  End With

  ' FolderTgt is the folder I am going to search.  This statement says
  ' I want to seach the Inbox.  The value "olFolderInbox" can be replaced
  ' to allow any of the standard folders to be searched.
  ' See FindSelectedFolder() for a routine that will search for any folder.
  Set FolderTgt = CreateObject("Outlook.Application"). _
              GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
  ' #### Use the following the access a non-default Inbox.
  ' #### Change "Xxxx" to name of one of your store you want to access.
  Set FolderTgt = Session.Folders("Xxxx").Folders("Inbox")

  ' This examines the emails in reverse order. I will explain why later.
  For InxItemCrnt = FolderTgt.Items.Count To 1 Step -1
    With FolderTgt.Items.Item(InxItemCrnt)
      ' A folder can contain several types of item: mail items, meeting items,
      ' contacts, etc.  I am only interested in mail items.
      If .Class = olMail Then
        ' Save selected properties to variables
        ReceivedTime = .ReceivedTime
        Subject = .Subject
        SenderName = .SenderName
        SenderEmailAddress = .SenderEmailAddress
        TextBody = .Body
        HtmlBody = .HtmlBody
        AttachCount = .Attachments.Count
        If AttachCount > 0 Then
          ReDim AttachDtl(1 To 7, 1 To AttachCount)
          For InxAttach = 1 To AttachCount
            ' There are four types of attachment:
            '  *   olByValue       1
            '  *   olByReference   4
            '  *   olEmbeddedItem  5
            '  *   olOLE           6
            Select Case .Attachments(InxAttach).Type
              Case olByValue
            AttachDtl(1, InxAttach) = "Val"
              Case olEmbeddeditem
            AttachDtl(1, InxAttach) = "Ebd"
              Case olByReference
            AttachDtl(1, InxAttach) = "Ref"
              Case olOLE
            AttachDtl(1, InxAttach) = "OLE"
              Case Else
            AttachDtl(1, InxAttach) = "Unk"
            End Select
            ' Not all types have all properties.  This code handles
            ' those missing properties of which I am aware.  However,
            ' I have never found an attachment of type Reference or OLE.
            ' Additional code may be required for them.
            Select Case .Attachments(InxAttach).Type
              Case olEmbeddeditem
                AttachDtl(2, InxAttach) = ""
              Case Else
                AttachDtl(2, InxAttach) = .Attachments(InxAttach).PathName
            End Select
            AttachDtl(3, InxAttach) = .Attachments(InxAttach).FileName
            AttachDtl(4, InxAttach) = .Attachments(InxAttach).DisplayName
            AttachDtl(5, InxAttach) = "--"
            ' I suspect Attachment had a parent property in early versions
            ' of Outlook. It is missing from Outlook 2016.
            On Error Resume Next
            AttachDtl(5, InxAttach) = .Attachments(InxAttach).Parent
            On Error GoTo 0
            AttachDtl(6, InxAttach) = .Attachments(InxAttach).Position
            ' Class 5 is attachment.  I have never seen an attachment with
            ' a different class and do not see the purpose of this property.
            ' The code will stop here if a different class is found.
            Debug.Assert .Attachments(InxAttach).Class = 5
            AttachDtl(7, InxAttach) = .Attachments(InxAttach).Class
          Next
        End If
        InterestingItem = True
      Else
        InterestingItem = False
      End If
    End With
    ' The most used properties of the email have been loaded to variables but
    ' there are many more properies.  Press F2.  Scroll down classes until
    ' you find MailItem.  Look through the members and note the name of
    ' any properties that look useful.  Look them up using VB Help.

    ' #### You need to add code here to eliminate uninteresting items.
    ' #### For example:
    'If SenderEmailAddress <> "JohnDoe@AcmeSoftware.co.zy" Then
    '  InterestingItem = False
    'End If
    'If InStr(Subject, "Accounts payable") = 0 Then
    '  InterestingItem = False
    'End If
    'If AttachCount = 0 Then
    '  InterestingItem = False
    'End If

    ' #### If the item is still thought to be interesting I
    ' #### suggest extracting the required data to variables here.

    ' #### You should consider moving processed emails to another
    ' #### folder.  The emails are being processed in reverse order
    ' #### to allow this removal of an email from the Inbox without
    ' #### effecting the index numbers of unprocessed emails.

    If InterestingItem Then
      With ExcelWkBk
        With .Worksheets("Inbox")
          ' #### This code creates a dividing row and then
          ' #### outputs a property per row.  Again it demonstrates
          ' #### statements that are likely to be useful in the final
          ' #### version
          ' Create dividing row between emails
          .Rows(RowCrnt).RowHeight = 5
          .Range(.Cells(RowCrnt, "A"), .Cells(RowCrnt, "B")) _
                                      .Interior.Color = RGB(0, 255, 0)
          RowCrnt = RowCrnt + 1
          .Cells(RowCrnt, "A").Value = "Sender name"
          .Cells(RowCrnt, "B").Value = SenderName
          RowCrnt = RowCrnt + 1
          .Cells(RowCrnt, "A").Value = "Sender email address"
          .Cells(RowCrnt, "B").Value = SenderEmailAddress
          RowCrnt = RowCrnt + 1
          .Cells(RowCrnt, "A").Value = "Received time"
          With .Cells(RowCrnt, "B")
            .NumberFormat = "@"
            .Value = Format(ReceivedTime, "mmmm d, yyyy h:mm")
          End With
          RowCrnt = RowCrnt + 1
          .Cells(RowCrnt, "A").Value = "Subject"
          .Cells(RowCrnt, "B").Value = Subject
          RowCrnt = RowCrnt + 1
          If AttachCount > 0 Then
            .Cells(RowCrnt, "A").Value = "Attachments"
            .Cells(RowCrnt, "B").Value = "Inx|Type|Path name|File name|Display name|Parent|Position|Class"
            RowCrnt = RowCrnt + 1
            For InxAttach = 1 To AttachCount
              .Cells(RowCrnt, "B").Value = InxAttach & "|" & _
                                           AttachDtl(1, InxAttach) & "|" & _
                                           AttachDtl(2, InxAttach) & "|" & _
                                           AttachDtl(3, InxAttach) & "|" & _
                                           AttachDtl(4, InxAttach) & "|" & _
                                           AttachDtl(5, InxAttach) & "|" & _
                                           AttachDtl(6, InxAttach) & "|" & _
                                           AttachDtl(7, InxAttach)
              RowCrnt = RowCrnt + 1
            Next
          End If
          If TextBody <> "" Then

            ' ##### This code was in the original version of the macro
            ' ##### but I did not find it as useful as the other version of
            ' ##### the text body.  See below
            ' This outputs the text body with CR, LF and TB obeyed
            'With .Cells(RowCrnt, "A")
            '  .Value = "text body"
            '  .VerticalAlignment = xlTop
            'End With
            'With .Cells(RowCrnt, "B")
            '  ' The maximum size of a cell 32,767
            '  .Value = Mid(TextBody, 1, 32700)
            '  .WrapText = True
            'End With
            'RowCrnt = RowCrnt + 1

            ' This outputs the text body with NBSP, CR, LF and TB
            ' replaced by strings.
            With .Cells(RowCrnt, "A")
              .Value = "text body"
              .VerticalAlignment = xlTop
            End With
            TextBody = Replace(TextBody, Chr(160), "[NBSP]")
            TextBody = Replace(TextBody, vbCr, "[CR]")
            TextBody = Replace(TextBody, vbLf, "[LF]")
            TextBody = Replace(TextBody, vbTab, "[TB]")
            With .Cells(RowCrnt, "B")
              ' The maximum size of a cell 32,767
              .Value = Mid(TextBody, 1, 32700)
              .WrapText = True
            End With
            RowCrnt = RowCrnt + 1
          End If

          If HtmlBody <> "" Then

            ' ##### This code was in the original version of the macro
            ' ##### but I did not find it as useful as the other version of
            ' ##### the html body.  See below
            ' This outputs the html body with CR, LF and TB obeyed
            'With .Cells(RowCrnt, "A")
            '  .Value = "Html body"
            '  .VerticalAlignment = xlTop
            'End With
            'With .Cells(RowCrnt, "B")
            '  .Value = Mid(HtmlBody, 1, 32700)
            '  .WrapText = True
            'End With
            'RowCrnt = RowCrnt + 1

            ' This outputs the html body with NBSP, CR, LF and TB
            ' replaced by strings.
            With .Cells(RowCrnt, "A")
              .Value = "Html body"
              .VerticalAlignment = xlTop
            End With
            HtmlBody = Replace(HtmlBody, Chr(160), "[NBSP]")
            HtmlBody = Replace(HtmlBody, vbCr, "[CR]")
            HtmlBody = Replace(HtmlBody, vbLf, "[LF]")
            HtmlBody = Replace(HtmlBody, vbTab, "[TB]")
            With .Cells(RowCrnt, "B")
              .Value = Mid(HtmlBody, 1, 32700)
              .WrapText = True
            End With
            RowCrnt = RowCrnt + 1

          End If
        End With
      End With
    End If
  Next

  With xlApp
    With ExcelWkBk
      ' Write new workbook to disc
      If Right(PathName, 1) <> "\" Then
        PathName = PathName & "\"
      End If
      .SaveAs FileName:=PathName & FileName
      .Close
    End With
    .Quit   ' Close our copy of Excel
  End With

  Set xlApp = Nothing       ' Clear reference to Excel

End Sub

元の投稿には含まれていませんが、上記のマクロの一部のユーザーが有用であると判断したマクロ。

Public Sub FindSelectedFolder(ByRef FolderTgt As MAPIFolder, _
                              ByVal NameTgt As String, ByVal NameSep As String)

  ' This routine (and its sub-routine) locate a folder within the hierarchy and
  ' returns it as an object of type MAPIFolder

  ' NameTgt   The name of the required folder in the format:
  '              FolderName1 NameSep FolderName2 [ NameSep FolderName3 ] ...
  '           If NameSep is "|", an example value is "Personal Folders|Inbox"
  '           FolderName1 must be an outer folder name such as
  '           "Personal Folders". The outer folder names are typically the names
  '           of PST files.  FolderName2 must be the name of a folder within
  '           Folder1; in the example "Inbox".  FolderName2 is compulsory.  This
  '           routine cannot return a PST file; only a folder within a PST file.
  '           FolderName3, FolderName4 and so on are optional and allow a folder
  '           at any depth with the hierarchy to be specified.
  ' NameSep   A character or string used to separate the folder names within
  '           NameTgt.
  ' FolderTgt On exit, the required folder.  Set to Nothing if not found.

  ' This routine initialises the search and finds the top level folder.
  ' FindSelectedSubFolder() is used to find the target folder within the
  ' top level folder.

  Dim InxFolderCrnt As Long
  Dim NameChild As String
  Dim NameCrnt As String
  Dim Pos As Long
  Dim TopLvlFolderList As Folders

  Set FolderTgt = Nothing   ' Target folder not found

  Set TopLvlFolderList = _
          CreateObject("Outlook.Application").GetNamespace("MAPI").Folders

  ' Split NameTgt into the name of folder at current level
  ' and the name of its children
  Pos = InStr(NameTgt, NameSep)
  If Pos = 0 Then
    ' I need at least a level 2 name
    Exit Sub
  End If
  NameCrnt = Mid(NameTgt, 1, Pos - 1)
  NameChild = Mid(NameTgt, Pos + 1)

  ' Look for current name.  Drop through and return nothing if name not found.
  For InxFolderCrnt = 1 To TopLvlFolderList.Count
    If NameCrnt = TopLvlFolderList(InxFolderCrnt).Name Then
      ' Have found current name. Call FindSelectedSubFolder() to
      ' look for its children
      Call FindSelectedSubFolder(TopLvlFolderList.Item(InxFolderCrnt), _
                                            FolderTgt, NameChild, NameSep)
      Exit For
    End If
  Next

End Sub
Public Sub FindSelectedSubFolder(FolderCrnt As MAPIFolder, _
                      ByRef FolderTgt As MAPIFolder, _
                      ByVal NameTgt As String, ByVal NameSep As String)

  ' See FindSelectedFolder() for an introduction to the purpose of this routine.
  ' This routine finds all folders below the top level

  ' FolderCrnt The folder to be seached for the target folder.
  ' NameTgt    The NameTgt passed to FindSelectedFolder will be of the form:
  '               A|B|C|D|E
  '            A is the name of outer folder which represents a PST file.
  '            FindSelectedFolder() removes "A|" from NameTgt and calls this
  '            routine with FolderCrnt set to folder A to search for B.
  '            When this routine finds B, it calls itself with FolderCrnt set to
  '            folder B to search for C.  Calls are nested to whatever depth are
  '            necessary.
  ' NameSep    As for FindSelectedSubFolder
  ' FolderTgt  As for FindSelectedSubFolder

  Dim InxFolderCrnt As Long
  Dim NameChild As String
  Dim NameCrnt As String
  Dim Pos As Long

  ' Split NameTgt into the name of folder at current level
  ' and the name of its children
  Pos = InStr(NameTgt, NameSep)
  If Pos = 0 Then
    NameCrnt = NameTgt
    NameChild = ""
  Else
    NameCrnt = Mid(NameTgt, 1, Pos - 1)
    NameChild = Mid(NameTgt, Pos + 1)
  End If

  ' Look for current name.  Drop through and return nothing if name not found.
  For InxFolderCrnt = 1 To FolderCrnt.Folders.Count
    If NameCrnt = FolderCrnt.Folders(InxFolderCrnt).Name Then
      ' Have found current name.
      If NameChild = "" Then
        ' Have found target folder
        Set FolderTgt = FolderCrnt.Folders(InxFolderCrnt)
      Else
        'Recurse to look for children
        Call FindSelectedSubFolder(FolderCrnt.Folders(InxFolderCrnt), _
                                            FolderTgt, NameChild, NameSep)
      End If
      Exit For
    End If
  Next

  ' If NameCrnt not found, FolderTgt will be returned unchanged.  Since it is
  ' initialised to Nothing at the beginning, that will be the returned value.

End Sub
于 2012-08-27T17:05:45.213 に答える