Hyperlink Removal from emails Received-CodePudding

I want to remove hyperlinks by VBA from emails that is received. I found a website which provided some code piece to remove hyperlinks.

I modified it to the codes below as I want to run it from the selected email of the inbox. i.e the email appears in the preview pane.

the code is finding the hyperlinks but can not delete them. what is the problem?

EDIT: When I click forward button and the email is displayed in edit/prepare forward email, and run the code the hyperlinks are deleted.

...
Set objSelection = objOL.ActiveExplorer.Selection
For Each objMsg In objSelection
    
    
    Set objInspector = objMsg.GetInspector
    x = objInspector.IsWordMail
    
    If (objInspector.IsWordMail) Then
    
    
       Set objDocument = objInspector.WordEditor
       Set objHyperlinks = objDocument.Hyperlinks
    
       On Error Resume Next
    
       If objHyperlinks.count > 0 Then
          strPrompt = "Are you sure to remove all the hyperlinks in this email?"
          nResponse = MsgBox(strPrompt, vbYesNo   vbQuestion, "Remove All Hyperlinks")
          If nResponse = vbYes Then
             While objHyperlinks.count > 0
                   objHyperlinks(1).Delete
             Wend
             objMsg.Save
         End If
       End If
    End If.....

CodePudding user response：

In the loop where you iterate over selected items in Outlook the objMsg object is used:

For Each objMsg In objSelection

But to apply changes the objMail object is used instead.

objMail.Save

To save your changes you need to call the Save method on the item - in your case it is the objMsg instance.

Be aware, Outlook may not display changes immediately. Most probably you need to change the folder by setting the CurrentFolder property of the Explorer class to any other folder in Outlook and then return back to refresh the view on the reading pane, or just change the selection to make changes visible.

CodePudding user response：

I found objHyperlinks.count to be zero.

With code adjusted to apply to open items, objHyperlinks.count remained unchanged. This construct deletes the first hyperlink in an infinite loop.

While objHyperlinks.count > 0
    objHyperlinks(1).Delete
Wend

In my setup, to run the code I have to display the selected items outside of the main code.
(Debugging can trigger whatever is needed to generate a non-zero objHyperlinks.count.)

Sub RemoveAllHyperlinksInSelection()

    ' If Debug.Print objHyperlinks.count gives zero,
    '  open all applicable items first.
    ' objMail.Display inside this sub is insufficient
    
    ' Sub OpenSelection() is a separate subroutine to display selected items
    
    Dim objItem As Object
    Dim objMail As mailItem
    
    Dim objInspector As Inspector
    
    Dim objDocument As Word.Document
    Dim objHyperlinks As Word.Hyperlinks
    Dim objHyperlink As Word.Hyperlink
    
    Dim strPrompt As String
    Dim nResponse As VbMsgBoxResult
    
    Dim objSelection As Selection
    
    Set objSelection = ActiveExplorer.Selection
        
    For Each objItem In objSelection
                
        If objItem.Class = olMail Then
            
            Set objMail = objItem
            Debug.Print objMail.subject
            
            Set objInspector = objMail.GetInspector
            Set objDocument = objInspector.WordEditor
            Set objHyperlinks = objDocument.Hyperlinks
            
            Debug.Print objHyperlinks.count
            
            objMail.Display
            
            ' If you find this is zero run Sub OpenSelection() first
            Debug.Print objHyperlinks.count
            
            If objHyperlinks.count > 0 Then
                            
                strPrompt = "Are you sure to remove all the hyperlinks in this email?"
                nResponse = MsgBox(strPrompt, vbYesNo   vbQuestion, "Remove All Hyperlinks")
                If nResponse = vbYes Then
          
                    Dim i As Long
                    For i = objHyperlinks.count To 1 Step -1
                    
                        objHyperlinks(i).Delete
                        
                        ' This remains unchanged
                        ' While Wend with objHyperlinks(1).Delete will remove
                        '  the first hyperlink in an infinite loop
                        Debug.Print objHyperlinks.count
                        
                    Next
                    
                    'objMail.Close olSave

                Else
                    objMail.Close olDiscard
                    
                End If
                
            Else
                objMail.Close olDiscard
                
            End If
            
        End If
        
    Next
    
End Sub


Sub OpenSelection()

    ' Run this before RemoveAllHyperlinksInSelection
    '  if you find hyperlinks are not found
    
    Dim objItem As Object
    Dim objSelection As Selection
    
    Set objSelection = ActiveExplorer.Selection
    
    For Each objItem In objSelection
        If objItem.Class = olMail Then
            objItem.Display
        End If
    Next
        
End Sub