在personal.xlsb中觸發宏的超鏈接

我在excel中使用了一些引用電子郵件的文本（日期，發件人，主題）。問題是（就我所知），您可以超鏈接到公共文件夾中的Outlook電子郵件，因爲電子郵件可能會移動（鏈接因PC而異）。在personal.xlsb中觸發宏的超鏈接

所以我的想法是獲取該電子郵件的目的是製作一個超鏈接，觸發personal.xlsb中的宏，然後搜索該電子郵件並顯示它。

我唯一的問題是，我不知道如何鏈接文本來啓動宏，Worksheet_FollowHyperlink意味着我需要將該代碼放在我的文本所在的工作表中。

我想我可以做到這一點，但這實現了我需要在工作簿打開時創建此代碼並在工作簿關閉時將其刪除，除非我必須將所有文件重命名爲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

來源

2016-08-09 skatun

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

和測試功能（返回一個範圍只是導致線路選擇已選中的單元）

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

來源

2016-08-09 16:11:49

在personal.xlsb中觸發宏的超鏈接

回答

相關問題