SharePoint 电子邮件链接提取
5.00/5 (1投票)
从 SharePoint 电子邮件通知中提取超链接并在 HTML 树中显示它们。
免责声明：这是我用VBA写过的最复杂的一段代码。然而，这个任务本身很愚蠢，而且在我休假两周看到几百封这样的SharePoint电子邮件通知后，我决定自动化它。
引言
我们订阅了几个SharePoint服务器的网页（多个站点和页面），当文件内容更新时（每天都会更新很多），我们会收到它们的通知。如果使用树控件或制表符和空格，将文件名和路径列表递归地转换并添加到树中是相当简单的。然而，将其转换为HTML却很麻烦，因为弄清楚关闭HTML标签的正确位置有点复杂。
Using the Code
必备组件
要启用此代码并读取所有超链接，需要启用两项内容
- 在Microsoft Visual Basic for Applications中，选择“工具”|“引用”，启用“Microsoft VBScript Regular Expressions 5.5”。
- 在Microsoft Visual Basic for Applications中，选择“工具”|“引用”，启用“Microsoft Word 16.0 Object Library”。
限制
- 可能会出现一个错误，提示“您的服务器管理员限制了您可以同时打开的项目数量。”这会将Outlook文件夹的搜索限制为250封电子邮件。
- 选择您希望从中提取超链接的MS Outlook电子邮件。这仅适用于MS Outlook的桌面版本。
- 不幸的是，我们并不总是能访问文件，有些文件夹是空的，但我们对文件和文件夹都会收到相同的通知。无法检查最后一个节点是没有任何扩展名的文件还是带有句点的文件夹。
MS Outlook VBA
- 在MS Outlook中，转到“文件”|“选项”|“自定义功能区”，并在右侧启用“开发工具”选项卡。
- 在MS Outlook中，转到“文件”|“选项”|“信任中心”|“信任中心设置”|“宏设置”，然后选择“所有宏的通知”。
- 在MS Outlook的“开发工具”选项卡下，选择“Visual Basic”并打开
ThisOutlookSession文档。将源代码复制并粘贴到ThisOutlookSession文档中，然后保存。关闭MS Outlook时，可能会再次提示您保存。
代码结构
代码包含两个函数和两个子程序。
- 函数
GetBoiler在GetURLLinks函数的末尾使用，用于在电子邮件中添加您的签名。 Sub GetSite1Links是用于从SITE1 服务器提取所有超链接的。Sub GetSite2Links是用于从 SITE2 服务器提取所有超链接的。- 函数
GetURLLinks是所有混乱发生的地方。- 创建电子邮件模板。
- 获取所有电子邮件中的所有超链接（最多250封电子邮件）。
- 仅添加来自站点URL的超链接（以防您不小心包含错误的电子邮件）。
- 仅添加以“
View”（包含空格）开头的超链接。- 如果此超链接先前已添加或是一个存在的目录路径，则不添加。
- 每封电子邮件中有几个超链接。我们感兴趣的只有文本中总是以“
View”为前缀的那些。我不确定这在SharePoint中是否可自定义，所以您可能需要更改这一部分。回想起来，我本可以将它设为一个变量。
- 按字母顺序（不区分大小写）对超链接进行排序。这样，当我们构建树时，我们就完成了一半的工作。
- 以HTML结构显示链接文件。
- 重新定义所有目录路径到最深的目录路径。这使得遍历所有路径目录更加容易。
- 在遍历路径时，分别保存父级（作为
string）和自身级别（作为integer）。这使得自身级别可以轻松地递增。父级string是最后一个公共父级和下一个自身级别编号的连接，以句点为分隔符（为简单起见，简称为 P.O）。- 所有级别的第一个自身元素都设置为一。
- 所有级别的第一个父级元素都设置为一。
- 检查当前节点的父级（P.O）和前一个节点的父级（P.O）是否相同。
- 如果当前节点路径与前一个节点路径相同，则将新自身级别设置为前一个级别。否则，将其加一。
- 如果前一个节点不相关，则将新自身级别重置为一；并将当前节点的自身级别附加到父级。
- 下一步是构建带有路径和超链接的HTML代码。超链接仅添加到文件而不是文件夹结构中。文件夹名称会加粗。这通过三个循环完成：（1）打开标签，（2）添加带链接的文件，（3）关闭标签。
- 打开标签
- 对于第一个节点，我们打开一个
UL和LI标签。 - 对于每个后续节点，如果当前节点的 P.O 与前一个节点的 P.O 不相等且自身级别为一，则打开一个
UL标签。为每个后续节点打开一个LI标签。
- 对于第一个节点，我们打开一个
- 添加带链接的文件
- 如果当前节点是根节点，则打开一个
UL标签。否则，如果当前节点不是根节点且当前节点的父级不等于前一个节点的父级，则打开一个UL标签。 - 将带链接的文件添加到
LI标签中 - 如果当前节点是叶节点，则关闭一个
UL标签。否则，如果当前节点不是叶节点且当前节点的父级不等于下一个节点的父级，则关闭一个UL标签。
- 如果当前节点是根节点，则打开一个
- 关闭标签
- 如果当前节点是叶节点，则关闭一个
LI和UL标签。否则，如果当前节点的父级不等于下一个节点的父级，则关闭一个LI和UL标签。否则，如果当前节点的自身级别不等于下一个节点的自身级别，则仅关闭一个LI标签。最后一个表示下一个文件属于与当前文件相同的目录。 - 当同一父目录中不再存在其他文件时，所有
UL标签都会关闭。
- 如果当前节点是叶节点，则关闭一个
- 打开标签
- 使用签名文件创建
HTMLBody。 - 显示消息。
源代码
将代码复制并粘贴到您的Outlook VBA中，并根据需要修改站点和页面。
需要修改的变量
Site- 站点名称的简写sRootFolder- 我感兴趣的根文件夹sURL- 站点URLiStartSlash- 开始解析的站点URL节点。不同的站点有不同的路径深度。objMsg模板 - 电子邮件模板Signature- MS Outlook签名文件
' In Microsoft Visual Basic for Applications,
' under Tools | References, enable Microsoft VBScript Regular Expressions 5.5.
' Limitations: An error may appear stating that "Your server administrator has
' limited the number of items you can open simultaneously.".
' This limits searching Outlook folders to 250 emails.
Sub GetVoiceMessages()
' Set reference to VB Script library.
' Microsoft VBScript Regular Expressions 5.5
Dim Selection As Selection
Dim olMail As Outlook.MailItem
Dim obj As Object
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Set Selection = Application.ActiveExplorer.Selection
For Each obj In Selection
Set olMail = obj
Set Reg1 = New RegExp
For i = 1 To 3
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
With Reg1
Select Case i
Case 1
.Pattern = "You received a voice message from (\d+)"
.Global = True
Case 2
.Pattern = "You received a voice message from [\w, ]+ at (\d+)"
.Global = True
Case 3
.Pattern = "You missed a call from (.*)"
.Global = True
End Select
End With
If Reg1.Test(olMail.Body) Then
Set M1 = Reg1.Execute(olMail.Body)
For Each M In M1
Debug.Print olMail.SentOn & ";" & M
Next
End If
Next i
Next
End Sub
Sub GetSubjects()
' Set reference to VB Script library.
' Microsoft VBScript Regular Expressions 5.5
Dim Selection As Selection
Dim olMail As Outlook.MailItem
Dim obj As Object
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Dim strRecipients As String
Set Selection = Application.ActiveExplorer.Selection
For Each obj In Selection
Set olMail = obj
strRecipients = ""
For i = 1 To olMail.Recipients.Count
strRecipients = strRecipients & olMail.Recipients(i) & ","
Next i
strRecipients = Left(strRecipients, Len(strRecipients) - 1)
Debug.Print olMail.SentOn & ";" & olMail.Sender & ";" & _
olMail.Subject & ";" & strRecipients
Next
End Sub
Sub GetHistoricalPNBs()
' Set reference to VB Script library.
' Microsoft VBScript Regular Expressions 5.5
Dim Selection As Selection
Dim olMail As Outlook.MailItem
'Dim obj As Object
Dim Reg1 As RegExp
Dim Reg2 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Dim iFile As Integer
Dim sFile As String
Dim LastDate As Date
Dim sLastSubject As String
Dim objViews As Outlook.Views
Dim objPreviousView As Outlook.View
Dim objView As Outlook.View
Dim i As Long
' Applies view to select folder.
Set objViews = Application.ActiveExplorer.CurrentFolder.Views
' Get the view.
Set objPreviousView = Application.ActiveExplorer.CurrentFolder.CurrentView
Set objView = objViews.Item("Date")
' Apply the view.
'objView.Apply
LastDate = vbNull
sLastSubject = ""
' Set this to wherever you want the output to be saved.
sFile = "C:\Users\Bassam CTR AbdulBaki\Desktop\WAAS_PNBs.txt"
iFile = FreeFile
Open sFile For Output As #iFile
Set Selection = Application.ActiveExplorer.Selection
If Selection.Count = 0 Then
'Application.ActiveExplorer.SelectAllItems
'Selection = Application.ActiveExplorer.Selection
End If
For i = 1 To Selection.Count ' Do reverse for older emails.
DoEvents
Set olMail = Selection.Item(i)
Set Reg1 = New RegExp
' \d* = match digits
' \n = new lines
' \r = carriage return
' \s* = invisible spaces
' \w* = match alphanumeric
' \xa0 = non-breaking space
With Reg1
.Pattern = "PNB[\s|\xa0]+(\d+-\d+-\d+-\d+[a-zA-Z]*)[\s|\xa0]+(.*)[\r|\n]+\((.*)\)"
.Global = True
End With
If Reg1.Test(olMail.Body) Then
Set M1 = Reg1.Execute(olMail.Body)
For Each M In M1
Set Reg2 = New RegExp
' Set Case Insensitivity.
Reg2.IgnoreCase = True
With Reg2
.Pattern = "historical"
.Global = True
End With
If Reg2.Test(M.SubMatches(2)) Then
If LastDate <> olMail.SentOn Or sLastSubject <> olMail.Subject Then
LastDate = olMail.SentOn
sLastSubject = olMail.Subject
Print #iFile, Format(olMail.SentOn, "YYYY-MM-DD hh:mm:ss") & _
vbTab & olMail.Subject
End If
Print #iFile, vbTab & "PNB " & M.SubMatches(0) & _
vbTab & M.SubMatches(1) & vbCr & vbLf & vbTab & vbTab & M.SubMatches(2)
End If
Next
End If
Set Reg1 = Nothing
Set olMail = Nothing
Next
Set Selection = Nothing
MsgBox "Task complete!"
' Restore the previous view.
objPreviousView.Apply
Close #iFile
End Sub
Sub GetPNBsPerRelease()
' Set reference to VB Script library.
' Microsoft VBScript Regular Expressions 5.5
Dim Selection As Selection
Dim olMail As Outlook.MailItem
'Dim obj As Object
Dim Reg1 As RegExp
Dim Reg2 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Dim iFile As Integer
Dim sFile As String
Dim LastDate As Date
Dim sLastSubject As String
Dim objViews As Outlook.Views
Dim objPreviousView As Outlook.View
Dim objView As Outlook.View
Dim i As Long
' Applies view to select folder.
Set objViews = Application.ActiveExplorer.CurrentFolder.Views
' Get the view.
Set objPreviousView = Application.ActiveExplorer.CurrentFolder.CurrentView
Set objView = objViews.Item("Date")
' Apply the view.
'objView.Apply
LastDate = vbNull
sLastSubject = ""
' Set this to wherever you want the output to be saved.
sFile = "C:\Users\Bassam CTR AbdulBaki\Desktop\WAAS_PNBs.txt"
iFile = FreeFile
Open sFile For Output As #iFile
Set Selection = Application.ActiveExplorer.Selection
If Selection.Count = 0 Then
'Application.ActiveExplorer.SelectAllItems
'Selection = Application.ActiveExplorer.Selection
End If
For i = 1 To Selection.Count ' Do reverse for older emails.
DoEvents
Set olMail = Selection.Item(i)
Set Reg1 = New RegExp
' \d* = match digits
' \n = new lines
' \r = carriage return
' \s* = invisible spaces
' \w* = match alphanumeric
' \xa0 = non-breaking space
With Reg1
.Pattern = "PNB[\s|\xa0]+(\d+-\d+-\d+-\d+[a-zA-Z]*)[\s|\xa0]+(.*)[\r|\n]+\((.*)\)"
.Global = True
End With
If Reg1.Test(olMail.Body) Then
Set M1 = Reg1.Execute(olMail.Body)
For Each M In M1
Set Reg2 = New RegExp
' Set Case Insensitivity.
Reg2.IgnoreCase = True
With Reg2
.Pattern = "Release 5"
.Global = True
End With
If Reg2.Test(M.SubMatches(2)) Then
If LastDate <> olMail.SentOn Or sLastSubject <> olMail.Subject Then
LastDate = olMail.SentOn
sLastSubject = olMail.Subject
Print #iFile, Format(olMail.SentOn, "YYYY-MM-DD hh:mm:ss") & _
vbTab & olMail.Subject
End If
Print #iFile, vbTab & "PNB " & M.SubMatches(0) & _
vbTab & M.SubMatches(1) & vbCr & vbLf & vbTab & vbTab & M.SubMatches(2)
End If
Next
End If
Set Reg1 = Nothing
Set olMail = Nothing
Next
Set Selection = Nothing
MsgBox "Task complete!"
' Restore the previous view.
objPreviousView.Apply
Close #iFile
End Sub
Sub GetPNBs()
' Set reference to VB Script library.
' Microsoft VBScript Regular Expressions 5.5
Dim Selection As Selection
Dim olMail As Outlook.MailItem
Dim obj As Object
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Dim iFile As Integer
Dim sFile As String
Dim LastDate As Date
Dim sLastSubject As String
Dim objViews As Outlook.Views
Dim objPreviousView As Outlook.View
Dim objView As Outlook.View
' Applies view to select folder.
Set objViews = Application.ActiveExplorer.CurrentFolder.Views
' Get the view.
Set objPreviousView = Application.ActiveExplorer.CurrentFolder.CurrentView
Set objView = objViews.Item("Date")
' Apply the view.
'objView.Apply
LastDate = vbNull
sLastSubject = ""
' Set this to wherever you want the output to be saved.
sFile = "C:\Users\Bassam CTR AbdulBaki\Desktop\WAAS_PNBs.txt"
iFile = FreeFile
Open sFile For Output As #iFile
Set Selection = Application.ActiveExplorer.Selection
If Selection.Count = 0 Then
'Application.ActiveExplorer.SelectAllItems
'Selection = Application.ActiveExplorer.Selection
End If
For Each obj In Selection
Set olMail = obj
Set Reg1 = New RegExp
' \d* = match digits
' \n = new lines
' \r = carriage return
' \s* = invisible spaces
' \w* = match alphanumeric
' \xa0 = non-breaking space
With Reg1
.Pattern = "PNB\s*(\d+-\d+-\d+-\d+[a-zA-Z]*)[\s\xa0]+(.*)[\r|\n]+\((.*)\)"
.Global = True
End With
If Reg1.Test(olMail.Body) Then
Set M1 = Reg1.Execute(olMail.Body)
For Each M In M1
If LastDate <> olMail.SentOn Or sLastSubject <> olMail.Subject Then
LastDate = olMail.SentOn
sLastSubject = olMail.Subject
Print #iFile, Format(olMail.SentOn, "YYYY-MM-DD hh:mm:ss") & _
vbTab & olMail.Subject
End If
Print #iFile, vbTab & "PNB " & M.SubMatches(0) & _
vbTab & M.SubMatches(1) & vbCr & vbLf & vbTab & vbTab & M.SubMatches(2)
Next
End If
Next
' Restore the previous view.
objPreviousView.Apply
Close #iFile
End Sub
Sub GetCDRLs()
' Set reference to VB Script library.
' Microsoft VBScript Regular Expressions 5.5
Dim Selection As Selection
Dim olMail As Outlook.MailItem
Dim obj As Object
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Dim iFile As Integer
Dim sFile As String
' Set this to wherever you want the output to be saved.
sFile = "C:\Users\Bassam CTR AbdulBaki\Desktop\WAAS_CDRLs.txt"
iFile = FreeFile
Open sFile For Output As #iFile
Set Selection = Application.ActiveExplorer.Selection
For Each obj In Selection
Set olMail = obj
Set Reg1 = New RegExp
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
With Reg1
.Pattern = "(.*)CDRL A(\d+-\d+[a-zA-Z]?)([ ,]*)(.*)"
.Global = True
End With
If Reg1.Test(olMail.Subject) Then
Set M1 = Reg1.Execute(olMail.Subject)
For Each M In M1
Print #iFile, Format(olMail.SentOn, "YYYY-MM-DD hh:mm:ss") & _
vbTab & olMail.Subject
Print #iFile, vbTab & "CDRL A" & M.SubMatches(1) & vbTab & M.SubMatches(3)
Next
End If
Next
Close #iFile
End Sub
' Read file. Used to enter signature in an email.
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
' In Microsoft Visual Basic for Applications,
' under Tools | References, enable Microsoft Word 16.0 Object Library.
' The general format for DCE links is http://sp1.ecs.raytheon.com/type4/waasdfo/<sRootFolder>/.
Sub GetDCELinks()
GetURLLinks ("DCE")
End Sub
' In Microsoft Visual Basic for Applications,
' under Tools | References, enable Microsoft Word 16.0 Object Library.
' The general format for KSN links is https://ksn2.faa.gov/ajw/ajw-1/ajw14B/<sRootFolder>/.
Sub GetKSNLinks()
GetURLLinks ("KSN")
End Sub
' In Microsoft Visual Basic for Applications,
' under Tools | References, enable Microsoft Word 16.0 Object Library.
Function GetURLLinks(Site As String)
On Error GoTo Error_Handler
Dim Selection As Selection
Dim objMsg As MailItem
Dim objMailDocument As Document
Dim objHyperlink As Hyperlink
Dim obj As Object
Dim sMsg As String
Dim sHyperlinksList() As String
Dim countHyperlinks As Integer
Dim i As Integer
Dim iTemp As Integer
Dim j As Integer
Dim k As Integer
Dim iFailedMsg As Integer
Dim iTotalMsgs As Integer
Dim sLink As String
Dim sRootFolder() ' This array is used as a placeholder on where to start displaying.
' The iStartSlash kind of makes this unnecessary, but I may need it for other subsites.
Dim bValidPath As Boolean
Dim bHyperlinkExists As Boolean
Dim iStartSlash As Integer
Dim sURL As String
If Site = "DCE" Then
sRootFolder = Array("DFO", "CTRCTS", "DELIV", "GSLCTRCTS", "GSLDELIV")
sURL = "sp1.ecs.raytheon.com"
iStartSlash = 5
ElseIf Site = "KSN" Then
sRootFolder = Array("")
sURL = "ksn2.faa.gov"
iStartSlash = 6
Else
Exit Function
End If
' sRootFolder = Array("")
' Create email message.
Set Selection = Application.ActiveExplorer.Selection
Set objMsg = Application.CreateItem(olMailItem)
iTotalMsgs = Selection.Count
sMsg = "<HTML><BODY><B>" & Site & "</B><BR/>"
With objMsg
.To = "Shapiro, Vadim CTR (FAA) <Vadim.CTR.Shapiro@faa.gov>; Edora, _
Emile CTR (FAA) <Emile.CTR.Edora@faa.gov>; Mills, Charlene CTR (FAA) _
<Charlene.CTR.Mills@faa.gov>; Farouki, Ibrahim (FAA) <ibrahim.farouki@faa.gov>; _
Cappelano, Peter CTR (FAA) <Peter.CTR.Cappelano@faa.gov>; Hunt, _
Charles R-CTR (FAA) <Charles.R-CTR.Hunt@faa.gov>"
.CC = "Ditchfield, Lori CTR (FAA) <Lori.CTR.Ditchfield@faa.gov>; Zhao, _
Peng CTR (FAA) <peng.ctr.zhao@faa.gov>; Govan, _
Vernon CTR (FAA) <Vernon.CTR.Govan@faa.gov>"
.Subject = "Latest WAAS Documents"
.BodyFormat = olFormatHTML
'.HTMLBody = "<HTML><BODY></BODY></HTML>"
'.Attachments.Add ("path-to-file.docx")
i = 0
iFailedMsg = 0
' Get all hyperlinks from all emails.
For Each obj In Selection
iFailedMsg = iFailedMsg + 1
Set objMailDocument = obj.GetInspector.WordEditor
countHyperlinks = objMailDocument.Hyperlinks.Count
If (countHyperlinks > 0) Then
For Each objHyperlink In objMailDocument.Hyperlinks
sLink = objHyperlink.Address
' Only add hyperlinks that contain the URL.
If InStr(sLink, sURL) > 0 Then
bValidPath = True
Dim sPath As String
sPath = UCase(Right(sLink, Len(sLink) - InStrRev(sLink, "/")))
For k = LBound(sRootFolder) To UBound(sRootFolder)
If sPath = sRootFolder(k) Then
bValidPath = False
Exit For
End If
Next k
' Only add hyperlinks that begin with "View ".
If bValidPath And (InStr(objHyperlink.TextToDisplay, "View ") > 0) Then
' Do not add if this hyperlink was previously added
' or it is a directory path that exists.
' The directory path check will fail
' if it is added before any other file with the same path
' since it is the first time being added. TODO: Fix this.
If (Len(Join(sHyperlinksList)) > 0) Then
bHyperlinkExists = False
For j = LBound(sHyperlinksList) To UBound(sHyperlinksList)
If (UCase(sLink) = UCase(sHyperlinksList(j))) _
Or (UCase(sLink) = Left(UCase(sHyperlinksList(j)), _
Len(sLink))) Then
bHyperlinkExists = True
Exit For
End If
Next j
End If
If bHyperlinkExists = False Then
ReDim Preserve sHyperlinksList(i)
sHyperlinksList(i) = objHyperlink.Address
i = i + 1
End If
End If
End If
Next
' Sort the hyperlinks alphabetically (case-insensitive).
If (Len(Join(sHyperlinksList)) > 0) Then
Dim First As Integer, Last As Long
Dim i2 As Long, j2 As Long
Dim Temp As String
Dim str1 As String, str2 As String
First = LBound(sHyperlinksList)
Last = UBound(sHyperlinksList)
If (First < Last) Then
For i2 = First To Last - 1
For j2 = i2 + 1 To Last
str1 = sHyperlinksList(i2)
str2 = sHyperlinksList(j2)
If (UCase(str1) > UCase(str2)) Then
Temp = sHyperlinksList(j2)
sHyperlinksList(j2) = sHyperlinksList(i2)
sHyperlinksList(i2) = Temp
ElseIf (UCase(str1) = UCase(Left(str2, Len(str1)))) Then
sHyperlinksList(i2) = "" ' Attempting to fix the
' duplicate path directory.
' The dangling path issue still remains.
ElseIf (UCase(str2) = UCase(Left(str1, Len(str2)))) Then
sHyperlinksList(j2) = "" ' Attempting to fix
' the duplicate path directory.
' The dangling path issue still remains.
End If
Next j2
Next i2
End If
End If
End If
Set objMailDocument = Nothing
Set obj = Nothing
Next obj
' Display linked files in structures.
If (Len(Join(sHyperlinksList)) > 0) Then
Dim sDirectoryPath() As String
Dim sPrevDirPath() As String
Dim sNextDirPath() As String
Dim sParentLevel() As String
Dim iOwnLevel() As Integer
Dim bStructurePath As Boolean
Dim iLargestPath, iPreviousLength As Integer
iLargestPath = 0
' ReDim all directory paths to the deepest directory path.
For i = LBound(sHyperlinksList) To UBound(sHyperlinksList)
If (sHyperlinksList(i) <> "") Then ' Needed since duplicate paths
' were blanked during sort above.
sDirectoryPath = Split(sHyperlinksList(i), "/")
iPreviousLength = UBound(sDirectoryPath) - LBound(sDirectoryPath)
If iLargestPath < iPreviousLength Then
iLargestPath = iPreviousLength
End If
End If
Next i
' Save the (string) parent level and (integer) own level separately.
' This allows own level to be incremented easily.
ReDim sParentLevel(UBound(sHyperlinksList) - LBound(sHyperlinksList), iLargestPath)
ReDim iOwnLevel(UBound(sHyperlinksList) - LBound(sHyperlinksList), iLargestPath)
For i = LBound(sHyperlinksList) To UBound(sHyperlinksList)
If (sHyperlinksList(i) <> "") Then
sDirectoryPath = Split(sHyperlinksList(i), "/")
sPrevDirPath = sDirectoryPath
Exit For
End If
Next i
For j = iStartSlash To UBound(sDirectoryPath)
' The first own element is set to one for all levels.
iOwnLevel(LBound(sHyperlinksList), j) = 1
For k = iStartSlash To j - 1
If (sParentLevel(LBound(sHyperlinksList), j) <> "") Then
sParentLevel(LBound(sHyperlinksList), j) = _
sParentLevel(LBound(sHyperlinksList), j) & "."
End If
' The first parent element is set to one for all levels.
sParentLevel(LBound(sHyperlinksList), j) = _
sParentLevel(LBound(sHyperlinksList), j) & _
iOwnLevel(LBound(sHyperlinksList), k)
Next k
Next j
Erase sDirectoryPath
For i = LBound(sHyperlinksList) + 1 To UBound(sHyperlinksList)
If (sHyperlinksList(i) <> "") Then
sDirectoryPath = Split(sHyperlinksList(i), "/")
For j = iStartSlash To UBound(sDirectoryPath)
' Check if the current node's parent level
' (current parent and its level) and the previous node's
' parent level (previous parent and its level) are the same.
If ((sParentLevel(i, j - 1) & "." & iOwnLevel(i, j - 1)) = _
(sParentLevel(iTemp, j - 1) & "." & iOwnLevel(iTemp, j - 1))) Then
' If the current node path are the same,
' set the new own level to the previous one.
If (sDirectoryPath(j) = sPrevDirPath(j)) Then
iOwnLevel(i, j) = iOwnLevel(iTemp, j)
Else ' Increment it by one.
iOwnLevel(i, j) = iOwnLevel(iTemp, j) + 1
End If
Else ' If the previous node is unrelated, reset the new own level to one.
iOwnLevel(i, j) = 1
End If
For k = iStartSlash To j - 1
If (sParentLevel(i, j) <> "") Then
sParentLevel(i, j) = sParentLevel(i, j) & "."
End If
' Append the current node's own level to the parent level.
sParentLevel(i, j) = sParentLevel(i, j) & iOwnLevel(i, k)
Next k
Next j
sPrevDirPath = sDirectoryPath
iTemp = i
End If
Next i
Erase sDirectoryPath
' Condense the directory paths.
For i = LBound(sHyperlinksList) To UBound(sHyperlinksList)
If (sHyperlinksList(i) <> "") Then
sDirectoryPath = Split(sHyperlinksList(i), "/")
'ReDim Preserve sDirectoryPath(iLargestPath)
' TODO: Change the hardcoded 5 to a while loop.
Dim strTemp As String
strTemp = ""
For j = iStartSlash To UBound(sDirectoryPath) - 1
' TODO: Since the list is alphabetical,
' you can start from the last root element.
If i = LBound(sHyperlinksList) Then
strTemp = strTemp & "<UL><LI>_
<B>" & sDirectoryPath(j) & "</B>"
Else
If ((sParentLevel(i, j) & "." & iOwnLevel(i, j)) _
<> (sParentLevel(iTemp, j) & "." & iOwnLevel(iTemp, j))) Then
If (iOwnLevel(i, j) = 1) Then
strTemp = strTemp & "<UL>"
End If
strTemp = strTemp & "<LI><B>" _
& sDirectoryPath(j) & "</B>"
End If
End If
Next j
If InStr(sHyperlinksList(i), sURL) > 0 Then
sLink = sHyperlinksList(i)
If (i = LBound(sHyperlinksList)) Then
strTemp = strTemp + "<UL>"
ElseIf ((i > LBound(sHyperlinksList)) And _
(sParentLevel(i, j) <> sParentLevel(iTemp, j))) Then
strTemp = strTemp + "<UL>"
End If
strTemp = strTemp & "<LI><A HREF='" & _
sLink & "'>" & Right(sLink, Len(sLink) - InStrRev(sLink, "/")) _
& "</A></LI>"
If (i = UBound(sHyperlinksList)) Then
strTemp = strTemp + "</UL>"
ElseIf ((i < UBound(sHyperlinksList)) _
And (sParentLevel(i, j) <> sParentLevel(i + 1, j))) Then
strTemp = strTemp + "</UL>"
End If
End If
bStructurePath = False
' TODO: Change the hardcoded 5 to a while loop.
For j = UBound(sDirectoryPath) - 1 To iStartSlash Step -1
' TODO: Since the list is alphabetical,
' you can start from the last root element.
If sDirectoryPath(j) <> "" Then
If i = UBound(sHyperlinksList) Then
strTemp = strTemp & "</LI></UL>"
Else
If (sParentLevel(i, j) <> sParentLevel(i + 1, j)) Then
strTemp = strTemp & "</LI></UL>"
ElseIf (iOwnLevel(i, j) <> iOwnLevel(i + 1, j)) Then
strTemp = strTemp & "</LI>"
End If
End If
End If
Next j
sMsg = sMsg + strTemp
iTemp = i
End If
Next i
.HTMLBody = sMsg & "<BR>" & _
GetBoiler(Environ("AppData") & _
"\Microsoft\Signatures\Signature (FAA).htm") & "</BODY></HTML>"
.Display
End If
End With
Set objMsg = Nothing
Exit Function
Error_Handler:
Msg = "The following error has occurred:" & vbCrLf & vbCrLf
If Err.Number <> 0 Then
Msg = Msg & vbTab & "Error Number:" & vbTab & Str(Err.Number) & vbCrLf & _
vbTab & "Error Source:" & vbTab & Err.Source & vbCrLf & _
vbTab & "Error Line: " & vbTab & Erl & vbCrLf & _
vbTab & "Error Description: " & vbTab & Err.Description & vbCrLf & vbCrLf
End If
Msg = Msg & vbTab & "Email #: " _
& vbTab & vbTab & iFailedMsg & " of " & iTotalMsgs & vbCrLf & _
vbTab & "Subject: " & vbTab & vbTab & obj.Subject
MsgBox Msg, vbCritical, "Error", Err.HelpFile, Err.HelpContext
End Function
关注点
- 无。用于(X)HTML的VBA编码很痛苦。
历史
- 2019-07-09 - 修复了第一个路径为空的bug
- 2019-04-12 - 初始提交