超链接在个人.xlsb中触发macros
我有一个excel中的一些文本（date，发件人，主题）引用一个电子邮件的列。 问题是（据我所知），你可以超链接到公共文件夹的Outlook电子邮件，因为电子邮件可能会移动（链接从PC到PC）。
所以我的想法是获得这个电子邮件是build立一个超级链接，在personal.xlsb中触发一个macros，然后search该电子邮件并显示它。
我唯一的问题是，我不知道如何链接文本来启动一个macros， Worksheet_FollowHyperlink意味着我需要将该代码放在我的文本是工作表。
我想我可以做到这一点，但这实现了我需要创build此代码时打开工作簿，并在工作簿closures时将其删除，除非我必须重命名所有文件xlsx到xlsm，并且我不确定是否其他同事有链接到我希望避免这样做的Excel表。
所以我的问题是，有没有什么办法可以使一个超链接到personal.xlsb!ShowEmail(cellValue) ？ 或者是否可以直接链接到公用文件夹中的电子邮件？ 以下是创build电子邮件文本的代码：
Function getEpostField(projectNumber As String, drawingNumber As String, partNumber As String) As String On Error Resume Next Dim myFolderArray() As String Dim i As Long Dim j As Long Dim k As Long Dim OutApp As Object Dim myNameSpace As Object Dim myFolder As Object Dim myNewFolder As Object Dim TopPublicFolder As Object Dim olMail As Variant Dim myTasks Dim strFilter As String Set OutApp = CreateObject("Outlook.Application") Set myNameSpace = OutApp.GetNamespace("MAPI") Set TopPublicFolder = myNameSpace.GetDefaultFolder(18) getEpostField = "" ' array with all subfolders where the item might be... myFolderArray = Post.helpRequest("XXXXXXXXX") For i = LBound(myFolderArray) To UBound(myFolderArray) Set myFolder = TopPublicFolder.Folders("Prototech").Folders(myFolderArray(i, 2)).Folders For j = 1 To myFolder.Count If InStr(myFolder(j).Name, projectNumber) Then If drawingNumber <> "" And partNumber <> "" Then strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:textdescription" & Chr(34) & " like '%" & drawingNumber & "%' " _ & "or " & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & drawingNumber & "%'" _ & "or " & Chr(34) & "urn:schemas:httpmail:attachmentfilename" & Chr(34) & " like '%" & drawingNumber & "%'" _ & "or " & Chr(34) & "urn:schemas:httpmail:textdescription" & Chr(34) & " like '%" & partNumber & "%' " _ & "or " & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & partNumber & "%'" _ & "or " & Chr(34) & "urn:schemas:httpmail:attachmentfilename" & Chr(34) & " like '%" & partNumber & "%'" ElseIf drawingNumber <> "" Then strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:textdescription" & Chr(34) & " like '%" & drawingNumber & "%' " _ & "or " & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & drawingNumber & "%'" _ & "or " & Chr(34) & "urn:schemas:httpmail:attachmentfilename" & Chr(34) & " like '%" & drawingNumber & "%'" ElseIf partNumber <> "" Then strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:textdescription" & Chr(34) & " like '%" & partNumber & "%' " _ & "or " & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & partNumber & "%'" _ & "or " & Chr(34) & "urn:schemas:httpmail:attachmentfilename" & Chr(34) & " like '%" & partNumber & "%'" Else getEpostField = "No emails found" Exit Function End If Set filteredItems = myFolder(j).Items.Restrict(strFilter) If filteredItems.Count = 0 Then Debug.Print "No emails found" getEpostField = "No emails found" found = False Else found = True ' this loop is optional, it displays the list of emails by subject. For Each itm In filteredItems attachmentString = "" If itm.Attachments.Count > 0 Then For Each temp In itm.Attachments temp2 = InStr(temp.filename, drawingNumber) If temp2 > 0 Then attachmentString = attachmentString & temp.filename & " " End If Next temp End If Debug.Print "Dato:" & Format(itm.CreationTime, "mm.dd.yyyy") & " Subject:" & itm.Subject & " From:" & itm.SenderName & " Attachment:" & attachmentString getEpostField = getEpostField + "Dato:" & Format(itm.CreationTime, "mm.dd.yyyy") & " Subject:" & itm.Subject & " From:" & itm.SenderName & " Attachment:" & attachmentString Next End If 'If the subject isn't found: If Not found Then 'NoResults.Show Else Debug.Print "Found " & filteredItems.Count & " items." End If Exit Function End If Next j Next i End Function
=HYPERLINK("#personal.xlsb!modUtility.TestHL()","Test")
和一个testing函数（返回一个范围a就会导致链接select已经select的单元格）
Function TestHL() Debug.Print "OK" Set TestHL = Selection End Function