以下是我在尋找：從Outlook郵件正文和出口超鏈接複製到Excel或記事本
我在Outlook 20頁不同的文件夾，每個人都有相同的電子郵件車身結構和格式。 每個電子郵件正文有3到7個超鏈接 我想要導出這些超鏈接之一（它易於識別，因爲它具有相同的起始/特定的單詞 - 如果我們導出這個特定的超鏈接或全部都沒關係因爲我們以後可以在Excel中編輯它們）。
我想這些超鏈接被導出到細胞中的excel表
我在做什麼現在：
我使用剪貼板去每封電子郵件。右鍵單擊複製鏈接，然後粘貼到記事本或Excel中。
讓我知道你們是否有任何建議。這將真正簡化我的工作......當然還有其他可能尋找類似解決方案的人。
問候，
AA
夥計們我使用codetwo outlook exporter來執行此任務。我以某種方式偶然發現了它。謝謝Marc nd Expfresh！你的解決方案是偉大的，但我甚至在嘗試他們之前找到了另一種方式..這是非常好的，這個論壇有幫助的人。只針對面臨同樣問題的人：使用CODETWO展望出口商。 - 做這份工作。問候 - 艾迪
您可以導出到Excel，但複製到Excel之前，
- >你必須選擇其中的超鏈接存在的電子郵件。通過選擇電子郵件righclick並選擇發送到一個註釋。
- >單筆記將打開。翻閱One-note的本節（右側）中的頁面標籤。選擇所有郵件（頁面）並右鍵單擊 - >複製。
你可以找到或應用過濾器，過濾器 - > textfilter->包含所需的單詞或短語（其容易識別，因爲它有一個同一個起跑線/特定字內）。
如果你直接複製onenote爲excel意味着所有的表格，附件等將被粘貼，那麼很難過濾或找到所需的超鏈接。
，因爲你說的20個文件夾是不可能的文件夾發送到的OneNote，u需要打開文件夾20則U可以選擇任意數量的每個文件夾中的電子郵件。
:)
因爲它超出了大小限制，我不能適合我的一個答案解決方案。 這是我答案的第一部分。我已將一段代碼移至第二個答案。
這是一個VBA解決方案。你給出了一個很好的規格，所以我相信這將接近你的要求。我希望我已經包含了足夠的意見，讓你做出最後的調整。如果沒有，問。
這第一塊代碼包含我爲我寫的子例程。他們執行我認爲有用的任務。他們包括評論，但他們寫的評論是爲了提醒我他們不會幫助別人理解他們。我爲你寫的宏使用它們，並解釋如何使用它們。目前我建議你不要擔心這些子程序如何去做。
我也許應該警告你，我很少在自己的宏中使用錯誤處理功能，因爲我不希望它們優雅地失敗;我希望他們停下來解決問題，以便我能理解並糾正原因。
在Outlook中，打開VBA編輯器，插入一個模塊並將第一個代碼塊複製到其中。您還需要點擊Tools，然後點擊References。在頂部附近是否是「Microsoft Excel nn.n Object Library」？是否打勾？如果未勾選，您必須滾動完成列表，找到該參考並勾選它。 「nn.n」的值將取決於您使用的Excel版本。只有當你安裝了多個版本的Excel時，你纔有選擇。
繼續下面的代碼。
此代碼移至答案的第二部分。
下面是四個宏。前三個是教程，第四個是我的解決方案。
如果您的Outlook安裝像我這樣的，你將有文件夾個人文件夾，存檔文件夾也許還有其他。在個人文件夾您將擁有標準文件夾收件箱,發件箱等。您可能已在這些標準文件夾中添加了自己的文件夾，或者您可能已將它們添加到個人文件夾。在我自己的系統中，我有各種文件夾，包括！家庭和！Tony。每個包含子文件夾和內的其中一個子文件夾！Tony是Amazon亞馬遜。
在第一個宏，你最需要了解它的語句：
Call FindInterestingFolders(FolderList, True, False, "|", _
"Personal Folders|!Family", "Personal Folders|!Tony|Amazon")
FindInterestingFolders是包括在上面的代碼中的子例程之一。本聲明的第二行以我認爲方便的樣式指定了我提到的兩個文件夾的名稱。宏FindInterestingFolders返回有關這兩個文件夾及其可能具有的任何子文件夾或子子文件夾的信息。您必須將這兩個名稱替換爲您要搜索的文件夾。如果20個文件夾全部在一個父代下，則可以指定該單個父代。如果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:[email protected]">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
標題行包含發件人，ReceivedTime和郵件項目的主題。
將此宏添加到模塊中，將修改後的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
我再次希望這很容易。我不確定下一個宏是多麼有用。這是我發展的一個步驟，但它沒有包含任何重要性，這也不在最終的宏觀範圍內。這可能是值得您研究的，因爲最終的宏將從宏2有兩個重要更改。
宏3所做的是從錨標記中提取URL並放棄那些啓動「mailto：」的URL。 Html允許比我允許的更多的變化，因爲我從來沒有看到過利用這種靈活性的電子郵件。如果您的電子郵件與我期望的不同，那麼您可能需要增強我的代碼。您只需要從每封電子郵件中選擇一個網址，以便您可以添加代碼以放棄其他網址。
再次，將此宏添加到模塊，將修改後的呼叫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
對於最終的宏我我用於開發答案簿之一創建工作表。
在最後的宏，你會發現聲明：
Const WkBkPathFile As String = "C:\DataArea\Play\Combined 10 V02.xls"
你需要與你的工作簿的路徑和文件名來替換這一點。
你還會發現這樣的說法：
Const WkShtName As String = "URLs"
我已經使用工作表網址。我建議你先創建一個像我的工作表。一旦你獲得了最終的宏觀工作，你可以根據你的要求進行調整。
我有我的工作表四列：文件夾名稱，發件人名稱，接收時間和網址。第三欄保存完整的日期和時間，但我將其格式化爲僅顯示短日期。在你的問題中沒有什麼建議你想要這些額外的列。我認爲這是值得展示你能做什麼，並讓你刪除代碼，如果它不感興趣。
我認爲你需要做的接收時間的東西。除非您將已處理的電子郵件從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
我無法在單個答案中使用我的解決方案，因爲它超過了大小限制。 這是我答案的第2部分。它包含第1部分中描述的代碼塊。首先閱讀Part 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展望出口商。 - 做這份工作。 關於 - Addy – AddyTiger