Question

我在excel中有一个列，其中包含一些引用电子邮件的文本（日期，发件人，主题）。问题是（据我所知）你可以超链接到公共文件夹中的Outlook电子邮件，因为电子邮件可能会移动（链接因PC而异）。

所以我获取该电子邮件的想法是创建一个超链接，触发personal.xlsb中的宏，然后搜索该电子邮件并显示它。

我唯一的问题是我无法弄清楚如何链接文本以启动宏，Worksheet_FollowHyperlink意味着我需要将该代码放在我的文本所在的工作表中。

我想我可以做到这一点，但这实现了我需要在工作簿打开时创建此代码并在工作簿关闭时删除它，除非我必须将所有文件xlsx重命名为xlsm，并且因为我是不确定其他同事是否有链接到excel表我想避免这样做。

所以我的问题是，有没有办法建立到personal.xlsb!ShowEmail(cellValue)的超链接？或者是否可以直接链接到公用文件夹中的电子邮件？以下是创建电子邮件文本的代码：

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

Answer 1

=HYPERLINK("#personal.xlsb!modUtility.TestHL()","Test")

和测试函数（返回范围a只会导致链接选择已经选择的单元格）

Function TestHL()
    Debug.Print "OK"
    Set TestHL = Selection
End Function

在personal.xlsb中激活宏的超级链接

1 个答案: