これが私が探しているものです：
Outlookには20の異なるフォルダーがあり、それぞれが同じメール本文の構造と形式を持っています。各メール本文には3〜7個のハイパーリンクがあります。これらのハイパーリンクの1つをエクスポートします（同じ開始/特定の単語が含まれているため、簡単に識別できます。この特定のハイパーリンクをエクスポートするか、すべてをエクスポートするかは関係ありません。後でExcel内で編集できます）。
これらのハイパーリンクをExcelシートのセルにエクスポートしたい
私が今していること：
クリップボードを使用して各メールにアクセスしています。コピーリンクを右クリックして、メモ帳またはExcelに貼り付けます。
何か提案があれば教えてください。これは本当に私の仕事を単純化するでしょう..そして確かに同様の解決策を探すかもしれない他の人の。
よろしく、
AA
Excelにエクスポートできますが、Excelにコピーする前に、
->ハイパーリンクが存在する電子メールを選択する必要があります。電子メールを選択し て右クリックし、[ one-note に送信] を選択します。
→ワンノートが開きます。One-note のこのセクション (右側) のページ タブをめくります。すべてのメール (ページ) を選択し、右クリック -> コピーします。
フィルターを検索または適用できます。フィルター- >テキストフィルター->必要な単語またはフレーズが含まれています (同じ開始/特定の単語が含まれているため、簡単に識別できます)。
OneNoteから Excel に直接コピーすると、すべての表、添付ファイル、その他が貼り付けられることになり、必要なハイパーリンクをフィルター処理したり見つけたりするのが難しくなります。
20個のフォルダーをonenoteに送信することはできないと言っているので、20個のフォルダーを開く必要があり、各フォルダーで任意の数の電子メールを選択できます。
:)
サイズ制限を超えているため、ソリューションを 1 つの回答に収めることができません。 これは私の答えのパート1です。 コードの 1 つのブロックを 2 番目の回答に移動しました。
これは VBA ソリューションです。あなたは良い仕様を与えているので、これはあなたの要件に近いと思います. 最終的な調整ができるように、十分なコメントが含まれていることを願っています。そうでない場合は、尋ねてください。
この最初のコード ブロックには、私が私のために書いたサブルーチンが含まれています。彼らは私が役立つと思うタスクを実行します。それらにはコメントが含まれていますが、他の誰かがそれらを理解するのを助けるために何をしていないかを思い出させるために書かれたコメントです. 私があなたのために書いたマクロはそれらを使用し、それらの使用方法を説明します。今のところ、これらのサブルーチンがどのように動作するかについて心配しないことをお勧めします。
私自身のマクロでエラー処理機能を使用することはめったにないことを警告しておく必要があります。原因を理解して修正できるように、問題の説明をやめてもらいたい。
Outlook 内で VBA エディタを開き、モジュールを挿入して、この最初のコード ブロックをモジュールにコピーします。Toolsまた、 をクリックする必要がありますReferences。「Microsoft Excel nn.n Object Library」が一番上にあり、チェックされていますか? チェックされていない場合は、リストをスクロールし、この参照を見つけてチェックする必要があります。「nn.n」の値は、使用する Excel のバージョンによって異なります。複数のバージョンの Excel がインストールされている場合にのみ、選択肢があります。
答えはコードの下に続きます。
このコードは、回答の 2 番目の部分に移動しました。
以下に 4 つのマクロを示します。最初の 3 つはチュートリアルで、4 番目は私のソリューションです。
Outlook のインストールが私のようなものである場合、個人用フォルダー、アーカイブ フォルダー、およびおそらくその他のフォルダーがあります。個人用フォルダ内には、受信トレイ、送信トレイなどの標準フォルダがあります。これらの標準フォルダ内に独自のフォルダを追加したか、個人用フォルダに追加した可能性があります。私自身のシステムには、 !Familyや!Tonyなどのさまざまなフォルダーがあります。それぞれにサブフォルダーが含まれており、 !Tony内のサブフォルダーの 1 つがAmazonです。
最初のマクロで、最も理解する必要があるステートメントは次のとおりです。
Call FindInterestingFolders(FolderList, True, False, "|", _
"Personal Folders|!Family", "Personal Folders|!Tony|Amazon")
FindInterestingFolders上記のコードに含まれるサブルーチンの 1 つです。このステートメントの 2 行目は、私が便利だと思うスタイルで、前述の 2 つのフォルダーの名前を指定しています。マクロFindInterestingFoldersは、これら 2 つのフォルダーと、それらが持つ可能性のあるサブフォルダーまたはサブサブフォルダーに関する情報を返します。これら 2 つの名前を、検索するフォルダーに置き換える必要があります。20 個のフォルダーがすべて 1 つの親の下にある場合は、その 1 つの親を指定できます。20 個のフォルダーが分散している場合は、20 個すべての名前を指定する必要がある場合があります。
最初のマクロは、 によって検出されたすべてのフォルダーの名前をイミディエイト ウィンドウに出力しますFindInterestingFolders。私のシステムでは、次のように出力されます。
Personal Folders|!Family|Chloe & Euan
Personal Folders|!Family|Geoff
Personal Folders|!Family|Lucy & Mark
Personal Folders|!Tony|Amazon
Personal Folders|!Tony|Amazon|Trueshopping Ltd
このマクロを上で作成したモジュールにコピーし、検索する 20 個のフォルダーのリストを作成するまで操作します。
答えはコードの下に続きます。
Sub ExtractHyperLinks1()
' Outputs a sorted list of interesting folders to the Immediate Window.
Dim FolderList() As MAPIFolderDtl
Dim InxFL As Long
' Set FolderList to a list of interesting folders.
' The True means a folder has to containing mail items to be interesting.
' The False means I am uninterested in meeting items.
' The "|" defines the name separator used in the list of folder names
' that follow.
Call FindInterestingFolders(FolderList, True, False, "|", _
"Personal Folders|!Family", "Personal Folders|!Tony|Amazon")
For InxFL = LBound(FolderList) To UBound(FolderList)
With FolderList(InxFL)
Debug.Print .NameParent & "|" & .Folder.Name
End With
Next
End Sub
それがそれほど難しくなかったことを願っています。修正FindInterestingFoldersした呼び出しを次のマクロにコピーする必要があります。
マクロ 2 は、マクロ 1 に基づいて構築されています。Html 本文を含むメール アイテムの対象フォルダーを検索します。Html ボディごとに、アンカー タグを検索し、各タグと次の 58 文字をイミディエイト ウィンドウに出力します。イミディエイト ウィンドウには、最後の 200 行程度しか表示されないため、出力の下部しか表示されない場合があります。これは問題ではありません。アイデアは、マクロが見ることができるものを最初に見ることです。私のシステムでは、出力は次のように終了します。
Tony Dallimore 13/02/2012 15:42:00 RE: Product details enquiry from Amazon customer ...
<A HREF="mailto:16dhtcxlxwbh7fx@marketplace.amazon.co.uk">ma
<A HREF="http://www.amazon.co.uk/gp/help/customer/display.ht
<A HREF="http://www.amazon.co.uk/gp/help/customer/display.ht
Trueshopping Ltd - Amazon Marketplace 14/02/2012 09:08:39 RE: Product details enquiry ...
<A HREF="http://www.amazon.co.uk/gp/help/customer/display.ht
<A HREF="http://www.amazon.co.uk/gp/help/customer/display.ht
ヘッダー行には、メール アイテムの Sender、ReceivedTime、および Subject が含まれます。
このマクロをモジュールに追加し、修正された呼び出しFindInterestingFoldersを私の呼び出しの上にコピーして実行します。ほとんどすぐに、マクロが電子メールにアクセスしているという警告が表示されます。マクロの続行を許可し、続行する期間を選択する必要があります。セキュリティ レベルが標準の [中] に設定されていると仮定します。別のものに設定した場合は、別のオプションが表示されます。
答えはコードの下に続きます。
Sub ExtractHyperLinks2()
' Gets a list of interesting folders.
' Searches the list for mail items with Html bodies that contain an anchor.
' For each such mail item it outputs to the Immediate Window:
' Name of folder (if not already output for an earlier mail item)
' Sender ReceivedTime Subject
' First 60 characters of first anchor
' First 60 characters of second anchor
' First 60 characters of third anchor
Dim FolderList() As MAPIFolderDtl
Dim FolderNameOutput As Boolean
Dim InxFL As Long
Dim InxItem As Long
Dim PosAnchor As Long
Call FindInterestingFolders(FolderList, True, False, "|", _
"Personal Folders|!Family", "Personal Folders|!Tony|Amazon")
For InxFL = LBound(FolderList) To UBound(FolderList)
FolderNameOutput = False
With FolderList(InxFL).Folder
For InxItem = 1 To .Items.Count
With .Items.Item(InxItem)
If .Class = olMail Then
If .HtmlBody <> "" Then
' This mail item has an Html body so might have a hyperlink.
If InStr(1, LCase(.HtmlBody), "<a ") <> 0 Then
' It has at least one anchor
If Not FolderNameOutput Then
Debug.Print FolderList(InxFL).NameParent & "|" & _
FolderList(InxFL).Folder.Name
FolderNameOutput = True
End If
Debug.Print " " & .SenderName & " " & _
.ReceivedTime & " " & .Subject
PosAnchor = InStr(1, LCase(.HtmlBody), "<a ")
Do While PosAnchor <> 0
Debug.Print " " & Mid(.HtmlBody, PosAnchor, 60)
PosAnchor = InStr(PosAnchor + 1, LCase(.HtmlBody), "<a ")
Loop
End If
End If
End If
End With
Next
End With
Next
End Sub
繰り返しますが、それが簡単だったことを願っています。次のマクロがどれほど役立つかわかりません。これは私の開発の 1 ステップでしたが、最終的なマクロに含まれていない重要なものは何も含まれていません。最終的なマクロには、マクロ 2 からの 2 つの重要な変更点があるため、検討する価値があるかもしれません。
マクロ 3 が行うことは、アンカー タグから URL を抽出し、「mailto:」で始まる URL を破棄することです。Html は、私が許容できる以上のバリエーションを許容します。なぜなら、その柔軟性を利用した電子メールを見たことがないからです。あなたの電子メールが私が期待するものと異なる場合、私のコードを強化する必要がある可能性があります. 各電子メールから URL の 1 つだけが必要なため、他の URL を破棄するコードを追加することができます。
再度、このマクロをモジュールに追加し、修正された呼び出しFindInterestingFoldersを私の呼び出しの上にコピーして実行します。私のシステムでは、出力の最後の数行は次のとおりです。
Tony Dallimore 13/02/2012 15:42:00 RE: Product details enquiry from ...
http://www.amazon.co.uk/gp/help/customer/display.html?nodeId=11081621
http://www.amazon.co.uk/gp/help/customer/display.html?nodeId=3149571
Trueshopping Ltd - Amazon Marketplace 14/02/2012 09:08:39 RE: Product ...
http://www.amazon.co.uk/gp/help/customer/display.html?nodeId=11081621
http://www.amazon.co.uk/gp/help/customer/display.html?nodeId=3149571
答えはコードの下に続きます。
Sub ExtractHyperLinks3()
' Gets a list of interesting folders.
' Searches the list for mail items with Html bodies that contain an
' acceptable anchor. An acceptable anchor is one for which the url
' does not start "mailto:".
' For each acceptable anchor it outputs to the Immediate Window:
' Name of folder (if not already output for an earlier mail item)
' Sender ReceivedTime Subject (if not already output)
' Url from acceptable anchor
Dim FolderList() As MAPIFolderDtl
Dim FolderNameOutput As Boolean
Dim InxFL As Long
Dim InxItem As Long
Dim ItemHeaderOutput As Boolean
Dim LcHtmlBody As String
Dim PosAnchor As Long
Dim PosTrailingQuote As Long
Dim PosUrl As Long
Dim Quote As String
Dim Url As String
Call FindInterestingFolders(FolderList, True, False, "|", _
"Personal Folders|!Family", "Personal Folders|!Tony|Amazon")
For InxFL = LBound(FolderList) To UBound(FolderList)
FolderNameOutput = False
With FolderList(InxFL).Folder
For InxItem = 1 To .Items.Count
ItemHeaderOutput = False
With .Items.Item(InxItem)
If .Class = olMail Then
If .HtmlBody <> "" Then
' This mail item has an Html body so might contain hyperlinks.
LcHtmlBody = LCase(.HtmlBody)
If InStr(1, LcHtmlBody, "<a ") <> 0 Then
' It has at least one anchor
PosAnchor = InStr(1, LCase(.HtmlBody), "<a ")
Do While PosAnchor <> 0
PosUrl = InStr(PosAnchor, LcHtmlBody, "href=")
PosUrl = PosUrl + 5
Quote = Mid(LcHtmlBody, PosUrl, 1) ' Extract quote used in html
PosUrl = PosUrl + 1
PosTrailingQuote = InStr(PosUrl, LcHtmlBody, Quote)
Url = Mid(.HtmlBody, PosUrl, PosTrailingQuote - PosUrl)
If Left(LCase(Url), 7) <> "mailto:" Then
' I am interested in this url
If Not FolderNameOutput Then
Debug.Print FolderList(InxFL).NameParent & "|" & _
FolderList(InxFL).Folder.Name
FolderNameOutput = True
End If
If Not ItemHeaderOutput Then
Debug.Print " " & .SenderName & " " & _
.ReceivedTime & " " & .Subject
ItemHeaderOutput = True
End If
Debug.Print " " & Url
End If
PosAnchor = InStr(PosTrailingQuote, LCase(.HtmlBody), "<a ")
Loop
End If
End If
End If
End With
Next
End With
Next
End Sub
最後のマクロでは、回答を作成するために使用するワークブックの 1 つにワークシートを作成しました。
最後のマクロ内には、次のステートメントがあります。
Const WkBkPathFile As String = "C:\DataArea\Play\Combined 10 V02.xls"
これをワークブックのパスとファイル名に置き換える必要があります。
次のステートメントもあります。
Const WkShtName As String = "URLs"
ワークシートのURLを使用しました。私のようなワークシートを作成することから始めることをお勧めします。最終的なマクロが機能するようになったら、それを要件に適合させることができます。
ワークシートには、フォルダー名、送信者名、受信時刻、および URL の 4 つの列があります。3 番目の列には完全な日付と時刻が含まれていますが、短い日付のみを表示するようにフォーマットしました。あなたの質問には、これらの追加の列が必要であることを示唆するものは何もありません。何ができるかを実証し、興味がない場合はコードを削除するように任せる価値があると思いました。
受信時間で何かをする必要があると思います。処理済みの電子メールを 20 個のフォルダーから移動しない限り、マクロを実行するたびに URL の完全なセットが再度追加されます。メールを再処理しないためのテクニックはたくさんあります。たとえば、処理済みの電子メールにユーザー カテゴリを追加できます。ただし、最も簡単な方法は次のとおりだと思います。
最終的なマクロには、データを蓄積してワークシートに書き込む方法を説明する多くのコメントが含まれているので、ここでは繰り返しません。幸運を祈って、最初の指示を繰り返して、不明な点があれば尋ねます。
再度、このマクロをモジュールに追加し、修正された呼び出しFindInterestingFoldersを私の呼び出しの上にコピーします。今回は、マクロを実行する前に定数ステートメントの一方または両方を更新する必要もあります。
Sub ExtractHyperLinks()
' Open destination workbook.
' Find last used row in destination worksheet.
' Gets a list of interesting folders.
' Searches the list for mail items with Html bodies that contain an
' acceptable anchor. An acceptable anchor is one for which the url
' does not start "mailto:".
' For each acceptable anchor it outputs to the workbook:
' Column 1 := Name of folder
' Column 2 := Sender
' Column 3 := ReceivedTime
' Column 4 := Url
Dim ExcelWkBk As Excel.Workbook
Dim FolderList() As MAPIFolderDtl
Dim FolderName As String
Dim InterestingURL As Boolean
Dim InxOutput As Long
Dim InxFL As Long
Dim InxItem As Long
Dim ItemCrnt As MailItem
Dim LcHtmlBody As String
Dim OutputValue(1 To 50, 1 To 4)
Dim PosAnchor As Long
Dim PosTrailingQuote As Long
Dim PosUrl As Long
Dim Quote As String
Dim RowNext As Long
Dim TargetAddr As String
Dim Url As String
' Replace constant value with path and file name of your workbook.
Const WkBkPathFile As String = "C:\DataArea\Play\Combined 10 V02.xls"
Const WkShtName As String = "URLs"
Set ExcelWkBk = Application.CreateObject("Excel.Application"). _
Workbooks.Open(WkBkPathFile)
With ExcelWkBk
.Application.Visible = True ' Slows the macro but helps during testing
With .Worksheets(WkShtName)
' Find last used row in destination worksheet by going to bottom of sheet
' then moving up until a non-empty row is found then going down one.
' .End(xlUp) is VBA equivalent of Ctrl+Up.
RowNext = .Cells(Rows.Count, "A").End(xlUp).Row + 1
End With
End With
Call FindInterestingFolders(FolderList, True, False, "|", _
"Personal Folders|!Family", "Personal Folders|!Tony|Amazon")
InxOutput = 0
For InxFL = LBound(FolderList) To UBound(FolderList)
FolderName = FolderList(InxFL).NameParent & "|" & FolderList(InxFL).Folder.Name
With FolderList(InxFL).Folder
For InxItem = 1 To .Items.Count
With .Items.Item(InxItem)
If .Class = olMail Then
If .HtmlBody <> "" Then
' This mail item has an Html body so might contain hyperlinks.
LcHtmlBody = LCase(.HtmlBody)
If InStr(1, LcHtmlBody, "<a ") <> 0 Then
' It has at least one anchor
PosAnchor = InStr(1, LCase(.HtmlBody), "<a ")
Do While PosAnchor <> 0
PosUrl = InStr(PosAnchor, LcHtmlBody, "href=")
PosUrl = PosUrl + 5
Quote = Mid(LcHtmlBody, PosUrl, 1) ' Extract quote used in html
PosUrl = PosUrl + 1
PosTrailingQuote = InStr(PosUrl, LcHtmlBody, Quote)
Url = Mid(.HtmlBody, PosUrl, PosTrailingQuote - PosUrl)
InterestingURL = True ' Assume interesting until find otherwise
If Left(LCase(Url), 7) = "mailto:" Then
InterestingURL = False
End If
' **********************************************************
' Set InterestingURL = False for any other urls you want
' to reject. If you can tell a URL is ininteresting by
' looking at it, you can use code like mine.
' **********************************************************
If InterestingURL Then
' This URL and supporting data is to be output to the
' workbook.
' Rather than output data to the workbook cell by cell,
' which can be slow, I build it up in the array
' OutputValue(1 to 50, 1 To 4). It is normal in a 2D array
' for the first dimension to be for columns and the second
' for rows. Arrays to be read from or written to a worksheet
' are the other way round. You can resize the second
' dimension of a dynamic array but not the first so you
' cannot resize an array being built for a workbook. I
' cannot resize the array so I have fixed its size at
' compile time.
' This code fills the array, writes it out to the workbook
' and resets the array index. I have 50 rows because I
' wanted to test the filling and refilling of the array. I
' would suggest you make it bigger.
InxOutput = InxOutput + 1
If InxOutput > UBound(OutputValue, 1) Then
' Array is fill. Output it to workbook
TargetAddr = "A" & RowNext & ":D" & _
RowNext + UBound(OutputValue, 1) - 1
ExcelWkBk.Worksheets(WkShtName). _
Range(TargetAddr).Value = OutputValue
RowNext = RowNext + 50
InxOutput = 1
End If
OutputValue(InxOutput, 1) = FolderName
OutputValue(InxOutput, 2) = .SenderName
OutputValue(InxOutput, 3) = .ReceivedTime
OutputValue(InxOutput, 4) = Url
End If
PosAnchor = InStr(PosTrailingQuote, LCase(.HtmlBody), "<a")
Loop
End If
End If
End If
End With
Next
End With
Next
ExcelWkBk.Save ' Save changes over the top of the original file.
ExcelWkBk.Close (False) ' Don't save changes
Set ExcelWkBk = Nothing ' Release resource
End Sub
サイズ制限を超えているため、ソリューションを 1 つの回答に収めることができません。 これは私の答えのパート2です。 これには、パート 1 で説明したコード ブロックが含まれています。まずパート 1をお読みください。
Option Explicit
Public Type MAPIFolderDtl
NameParent As String
Folder As MAPIFolder
NumMail As Long
NumMeet As Long
End Type
' -----------------------------------------------------------------------
' ## Insert other routines here
' -----------------------------------------------------------------------
Sub FindInterestingFolders(ByRef IntFolderList() As MAPIFolderDtl, _
WantMail As Boolean, WantMeet As Boolean, _
NameSep As String, _
ParamArray NameFullList() As Variant)
' * Return a list of interesting folders.
' * To be interesting a folder must be named or be a subfolder of a named
' folder and contain mail and or meeting items if wanted.
' * Note: a top level folder cannot be returned as interesting because such
' folders are not of type MAPIFolder.
' * IntFolders() The list of interesting folders. See Type MAPIFolderDtl for
' contents.
' * WantMail True if a folder containing mail items is to be classified
' as interesting.
' * WantMeet True if a folder containing meeting items is to be classified
' as interesting.
' * NameSep SubFolder Names in NameList are of the form:
' "Personal Folders" & NameSep & "Inbox"
' NameSep can be any character not used in a folder name. It
' appears any character could be used in a folder name including
' punctuation characters. If in doubt, try Tab.
' * NameFullList One or more full names of folders which might themselves be
' interesting or might be the parent an interesting folders.
Dim InxTLFList() As Long
Dim InxIFLCrnt As Long
Dim InxNFLCrnt As Long
Dim InxTLFCrnt As Variant
Dim NameFullCrnt As String
Dim NamePartFirst As String
Dim NamePartRest As String
Dim Pos As Long
Dim TopLvlFolderList As Folders
InxIFLCrnt = 0 ' Nothing in IntFolderList()
Set TopLvlFolderList = CreateObject("Outlook.Application").GetNamespace("MAPI").Folders
For InxNFLCrnt = LBound(NameFullList) To UBound(NameFullList)
NameFullCrnt = NameFullList(InxNFLCrnt) ' Get next name
' Split name into first part and the rest. For Example,
' "Personal Folders|NHSIC|Commisioning" will be split into:
' NamePartFirst: Personal Folders
' NamePartRest: NHSIC|Commissioning
Pos = InStr(1, NameFullCrnt, NameSep)
If Pos = 0 Then
NamePartFirst = NameFullCrnt
NamePartRest = ""
Else
NamePartFirst = Mid(NameFullCrnt, 1, Pos - 1)
NamePartRest = Mid(NameFullCrnt, Pos + 1)
End If
' Create list of indices into TopLvlFolderList in
' ascending sequence by folder name
Call SimpleSortFolders(TopLvlFolderList, InxTLFList)
' NamePartFirst should be the name of a top level
' folder or empty. Ignore if it is not.
For Each InxTLFCrnt In InxTLFList
If NamePartFirst = "" Or _
TopLvlFolderList.Item(InxTLFCrnt).Name = NamePartFirst Then
' All subfolders are a different type so they
' are handled by FindInterestingSubFolder
Call FindInterestingSubFolders(IntFolderList, InxIFLCrnt, _
"", TopLvlFolderList.Item(InxTLFCrnt), WantMail, _
WantMeet, NameSep, NamePartRest)
End If
Next
Next
If InxIFLCrnt = 0 Then
' No folders found
ReDim IntFolderList(0 To 0)
Else
ReDim Preserve IntFolderList(1 To InxIFLCrnt) ' Discard unused entries
'For InxIFLCrnt = 1 To UBound(IntFolderList)
' Debug.Print IntFolderList(InxIFLCrnt).NameParent & "|" & _
' IntFolderList(InxIFLCrnt).Folder.Name & " " & _
' IntFolderList(InxIFLCrnt).NumMail & " " & _
' IntFolderList(InxIFLCrnt).NumMeet
'Next
End If
End Sub
Sub FindInterestingSubFolders(ByRef IntFolderList() As MAPIFolderDtl, _
InxIFLCrnt As Long, NameParent As String, _
MAPIFolderCrnt As MAPIFolder, WantMail As Boolean, _
WantMeet As Boolean, NameSep As String, _
NameChild As String)
' * NameFull = ""
' MAPIFolderCrnt and all its subfolders are potentially of interest
' * NameFull <> ""
' Look further down hierarchy for subfolders of potential interest
' This routine can be called repeately by a parent routine to explore different parts
' of the folder hierarchy. It calls itself recursively to work down the hierarchy.
' IntFolderList ' Array of interesting folders.
' InxIFLCrnt ' On the first call, InxIFLCrnt will be zero and the state of
' IntFolderList will be undefined.
' NameParent ' ... Grandparent & NameSep & Parent
' MAPIFolderCrnt ' The current folder that is to be explored.
' WantMail ' True if a folder has to contain mail to be interesting
' WantMeet ' True if a folder has to contain meeting items to be interesting
' NameSep ' The name separator character
' NameChild ' Suppose the original path was xxx|yyy|zzz. For each recurse down
' a name is removed from the start of NameChild and added to the end
' of NameParent. When NameChild is blank, the target folder has
' been reached.
Dim InxSFList() As Long
Dim InxSFCrnt As Variant
Dim NameCrnt As String
Dim NamePartFirst As String
Dim NamePartRest As String
Dim NumMail As Long
Dim NumMeet As Long
Dim Pos As Long
Pos = InStr(1, NameChild, NameSep)
If Pos = 0 Then
NamePartFirst = NameChild
NamePartRest = ""
Else
NamePartFirst = Mid(NameChild, 1, Pos - 1)
NamePartRest = Mid(NameChild, Pos + 1)
End If
If NameParent = "" Then
' This folder has no parent. It cannot be interesting.
NameCrnt = MAPIFolderCrnt.Name
Else
' This folder has a parent. It could be interesting.
NameCrnt = NameParent & NameSep & MAPIFolderCrnt.Name
If NamePartFirst = "" Then
If FolderHasRequiredItems(MAPIFolderCrnt, WantMail, _
WantMeet, NumMail, NumMeet) Then
' Debug.Print NameCrnt & " interesting"
If InxIFLCrnt = 0 Then
ReDim IntFolderList(1 To 100)
End If
InxIFLCrnt = InxIFLCrnt + 1
If InxIFLCrnt > UBound(IntFolderList) Then
ReDim Preserve IntFolderList(1 To 100 + UBound(IntFolderList))
End If
IntFolderList(InxIFLCrnt).NameParent = NameParent
Set IntFolderList(InxIFLCrnt).Folder = MAPIFolderCrnt
IntFolderList(InxIFLCrnt).NumMail = NumMail
IntFolderList(InxIFLCrnt).NumMeet = NumMeet
Else
' Debug.Print NameCrnt & " not interesting"
End If
End If
End If
If MAPIFolderCrnt.Folders.Count = 0 Then
' No subfolders
Else
Call SimpleSortMAPIFolders(MAPIFolderCrnt, InxSFList)
For Each InxSFCrnt In InxSFList
If NamePartFirst = "" Or _
MAPIFolderCrnt.Folders(InxSFCrnt).Name = NamePartFirst Then
Select Case NamePartFirst
' Ignore folders that can cause problems
Case "Sync Issues"
Case "RSS Feeds"
Case "Public Folders"
Case Else
' Recurse to analyse next level down
Call FindInterestingSubFolders(IntFolderList, InxIFLCrnt, NameCrnt, _
MAPIFolderCrnt.Folders(InxSFCrnt), WantMail, _
WantMeet, NameSep, NamePartRest)
End Select
End If
Next
End If
End Sub
Function FolderHasRequiredItems(MAPIFolderCrnt As MAPIFolder, WantMail As Boolean, _
WantMeet As Boolean, ByRef NumMail As Long, _
ByRef NumMeet As Long) As Boolean
' Return True if folder is interested. That is: at least one of the following is true:
' WantMail = True And NumMail > 0
' WantMeet = True And NumMeet > 0
' Values for NumMail and NumMeet are set whether or not the folder is interesting
Dim FolderItem As Object
Dim FolderItemClass As Long
Dim InxItemCrnt As Long
NumMail = 0
NumMeet = 0
' Count mail and meeting items in folder
For InxItemCrnt = 1 To MAPIFolderCrnt.Items.Count
Set FolderItem = MAPIFolderCrnt.Items.Item(InxItemCrnt)
' This seems to avoid syncronisation errors
FolderItemClass = 0
On Error Resume Next
FolderItemClass = FolderItem.Class
On Error GoTo 0
Select Case FolderItemClass
Case olMail
NumMail = NumMail + 1
Case olMeetingResponsePositive, olMeetingRequest, olMeetingCancellation, _
olMeetingResponseNegative, olMeetingResponseTentative
NumMeet = NumMeet + 1
End Select
Next
If WantMail And NumMail > 0 Then
FolderHasRequiredItems = True
Exit Function
End If
If WantMeet And NumMeet > 0 Then
FolderHasRequiredItems = True
Exit Function
End If
FolderHasRequiredItems = False
End Function
Sub SimpleSortMAPIFolders(MAPIFolderList As MAPIFolder, _
ByRef InxArray() As Long)
' On exit InxArray contains the indices into MAPIFolderList sequenced by
' ascending name. The sort is performed by repeated passes of the list
' of indices that swap adjacent entries if the higher come first.
' Not an efficient sort but adequate for short lists.
Dim InxIACrnt As Long
Dim InxIALast As Long
Dim NoSwap As Boolean
Dim TempInt As Long
Debug.Assert MAPIFolderList.Folders.Count >= 1 ' Must be at least one folder
ReDim InxArray(1 To MAPIFolderList.Folders.Count) ' One entry per folder
' Fill array with indices
For InxIACrnt = 1 To UBound(InxArray)
InxArray(InxIACrnt) = InxIACrnt
Next
' Each repeat of the loop movest the folder with the highest name
' to the end of the list. Each repeat checks one less entry.
' Each repeats partially sorts the leading entries and may result
' in the list being sorted before all loops have been performed.
For InxIALast = UBound(InxArray) To 1 Step -1
NoSwap = True
For InxIACrnt = 1 To InxIALast - 1
If MAPIFolderList.Folders(InxArray(InxIACrnt)).Name > _
MAPIFolderList.Folders(InxArray(InxIACrnt + 1)).Name Then
NoSwap = False
' Move higher entry one slot towards the end
TempInt = InxArray(InxIACrnt)
InxArray(InxIACrnt) = InxArray(InxIACrnt + 1)
InxArray(InxIACrnt + 1) = TempInt
End If
Next
If NoSwap Then
Exit For
End If
Next
End Sub
みんなこのタスクを実行するために codetwo Outlook exporter を使用しています。私はどういうわけかそれにつまずいた..ありがとうMarc nd Expfresh！あなたのソリューションは素晴らしいですが、試してみる前に別の方法を見つけました..このフォーラムに役立つ人々がいるのは素晴らしいことです. 同じ問題に直面している人々のために: CODETWO Outlook Exporter を使用してください。-仕事をします。よろしく - アディ