Sub Unsubscribe

Use this forum if you have problems with a hMailServer script, such as hMailServer WebAdmin or code in an event handler.
Post Reply
palinka
Senior user
Senior user
Posts: 4461
Joined: 2017-09-12 17:57

Sub Unsubscribe

Post by palinka » 2019-05-25 15:43

First, this doesn't have its own topic, so now it does (was buried within other topics).

Now, I've been using this for a while and it works well. However, I noticed a couple of things.

1) Some unsubscribes require the recipient address. Original script has a set from address (unsubscribe@mydomain.tld)
2) I noticed that once in a while legit mailing list senders trigger the unsubscribe rule, which is IF spam score > 0 THEN run unsubscribe. So I want a whitelist.

In this case the message was clean but was triggered by "ransomware" because it contained a discussion about ransomware spam. ugh... :roll:

I think the whitelist part is easy enough, but I'm not sure exactly if my "send from original recipient" bit will work. What do you think?

Code: Select all

Sub Unsubscribe(oMessage)
   '
   ' RFC6068 The 'mailto' URI Scheme: subject, cc, bcc, in-reply-to, body etc.. ?first &second &third etc...
   '
   Const            m_To = "List Administrator"
   Const        m_Sender = "Unsubscriber Daemon"
   Set m_SenderAddress = oMessage.OriginalAddress  '<--------- WILL THIS WORK????

   Dim a, b, strRegEx, Match, Matches, sMailTo, sURL, m_Subject, m_Body, doMail, doURL

   strRegEx = "apache.org|horde.org|lists.sourceforge.net"  '<--------- LOOKUP WHITELISTED DOMAIN
   If (Lookup(strRegEx, oClient.From) = True) Then Exit Sub  '<--------- IF WHITELISTED DOMAIN THEN EXIT

   strRegEx = "^[0-1]:[0-1]$"
   If Lookup(strRegEx, oMessage.HeaderValue("X-hMailServer-Unsubscribe")) Then
      a = Split(oMessage.HeaderValue("X-hMailServer-Unsubscribe"), ":")
      doMail = a(0)
      doURL = a(1)
   Else
      doMail = True
      doURL = True
   End If
   If doMail Then
      strRegEx = "([^\<]*?)(mailto:[\s\S]*?)(?=\>)"
      Set Matches = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), True)
      If Matches.Count > 0 Then
         For Each Match In Matches
            ' On Error Resume Next
            sMailTo = Mid(Trim(Match.Value), 8)
            a = Split(sMailTo, "?")
            If UBound(a) > 0 Then
               b = Split(a(1), "&")
               If (InStr(1, b(0), "subject=", 1) > 0) Then m_Subject = Replace(b(0), "subject=", "")
               If (InStr(1, b(0), "body=", 1) > 0) Then m_Body = Replace(b(0), "body=", "")
               If UBound(b) > 0 Then
                  If (InStr(1, b(1), "subject=", 1) > 0) Then m_Subject = Replace(b(1), "subject=", "")
                  If (InStr(1, b(1), "body=", 1) > 0) Then m_Body = Replace(b(1), "body=", "")
               End If
            End If
            With CreateObject("hMailServer.Message")
               .From = Chr(34) & m_Sender & Chr(34) & " <" & m_SenderAddress & ">"
               .FromAddress = m_SenderAddress
               .AddRecipient a(0), a(0)
               .AddRecipient m_Sender, m_SenderAddress
               .HeaderValue("To") = Chr(34) & m_To & Chr(34) & " <" & a(0) & ">"
               .HeaderValue("CC") = Chr(34) & m_Sender & Chr(34) & " <" & m_SenderAddress & ">"
                If Not m_Subject = Empty Then
                   .Subject = m_Subject
                Else
                   .Subject = "Unsubscribe Me"
                End If
                If Not m_Body    = Empty Then
                   .Body = m_Body
                Else
                   .Body = "This is an automated message generated by our unsubscriber algorithym. Please do not respond to this email as it will be ignored."
                End If
               .Save
            End With
            ' On Error Goto 0
            If (Err.Number <> 0) Then
               EventLog.Write( "ERROR: Sub Unsubscribe(oMessage)" )
               EventLog.Write( "Error       : " & Err.Number )
               EventLog.Write( "Error (hex) : 0x" & Hex(Err.Number) )
               EventLog.Write( "Source      : " & Err.Source )
               EventLog.Write( "Description : " & Err.Description )
               Err.Clear
               Exit Sub
            End If
         Next
      End If
   End If
   If doURL Then
      strRegEx = "([^\<]*?)((http|https):[\s\S]*?)(?=\>)"
      Set Matches = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), True)
      If Matches.Count > 0 Then
         For Each Match In Matches
            sURL = Trim(Match.Value)
            On Error Resume Next
            With CreateObject("MSXML2.ServerXMLHTTP.6.0")
               .setoption(2) = (.getoption(2) & " - SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS")
               .open "GET", sURL, False
               .setrequestheader "User-Agent", "online link validator (http://www.dead-links.com/)"
               .send ("")
            End With
            On Error Goto 0
            If (Err.Number <> 0) Then
               EventLog.Write( "ERROR: Sub Unsubscribe(oMessage)" )
               EventLog.Write( "Error       : " & Err.Number )
               EventLog.Write( "Error (hex) : 0x" & Hex(Err.Number) )
               EventLog.Write( "Source      : " & Err.Source )
               EventLog.Write( "Description : " & Err.Description )
               Err.Clear
               Exit Sub
            End If
         Next
      End If
   End If
End Sub

palinka
Senior user
Senior user
Posts: 4461
Joined: 2017-09-12 17:57

Re: Sub Unsubscribe

Post by palinka » 2019-05-26 07:37

I think this may work. Still not sure if I'm using the correct recipient object.

Code: Select all

Sub Unsubscribe(oMessage)
   '
   ' RFC6068 The 'mailto' URI Scheme: subject, cc, bcc, in-reply-to, body etc.. ?first &second &third etc...
   '
   Const            m_To = "List Administrator"
   Const        m_Sender = "Unsubscriber Daemon"
   ' Const m_SenderAddress = "unsubscribe@mydomain.tld"

   Dim a, b, strRegEx, Match, Matches, sMailTo, sURL, m_Subject, m_Body, doMail, doURL

   strRegEx = "apache\.org|horde\.org|lists\.sourceforge\.net"  '<--------- LOOKUP WHITELISTED DOMAIN
   If (Lookup(strRegEx, oMessage.From) = True) Then Exit Sub  '<--------- IF WHITELISTED DOMAIN THEN EXIT

   strRegEx = "(([A-Za-z0-9\.\-\+]+)\@(mydomain1\.us|mydomain2\.com|mydomain3\.net))"  '<--------- LOOKUP LOCAL ADDRESSES
   If (Lookup(strRegEx, oMessage.Recipients) = True) Then m_SenderAddress = Match.Value  '<--------- IF ORIGINAL MESSAGE TO = LOCAL ADDRESS
   Else Exit Sub  '<--------- IF NOT LOCAL ADDRESS THEN EXIT
   End If

	<--SNIP-->

palinka
Senior user
Senior user
Posts: 4461
Joined: 2017-09-12 17:57

Re: Sub Unsubscribe

Post by palinka » 2019-05-26 14:57

I realized the when I changed the sender address to the original recipient that the postmaster would not be copied, so I added that.

Here's the whole thing including rule to call and functions that were not shown.

My changes to Soren's excellent and working script are un-tested so far (haven't received an unsubscribe message yet) and I'm still not sure if I have the recipient part nailed down. Anyway, here's what I have.

Code: Select all

GLOBAL RULE
CRITERIA: USE AND
CUSTOM HEADER FIELD: X-hMailServer-Spam = YES
CUSTOM HEADER FIELD: X-hMailServer-Reason-Score < 8 (whatever your delete threshold is - there's no point in unsubscribing to deleted junk)

ACTION
SET HEADER VALUE: X-hMailServer-Unsubscribe = 1:0
RUN FUNCTION: Unsubscribe

Function Lookup(strRegEx, strMatch) : Lookup = False
   With CreateObject("VBScript.RegExp")
      .Pattern = strRegEx
      .Global = False
      .MultiLine = True
      .IgnoreCase = True
      If .Test(strMatch) Then Lookup = True
   End With
End Function

Function oLookup(strRegEx, strMatch, bGlobal)
   If strRegEx = "" Then strRegEx = StrReverse(strMatch)
   With CreateObject("VBScript.RegExp")
      .Pattern = strRegEx
      .Global = bGlobal
      .MultiLine = True
      .IgnoreCase = True
      Set oLookup = .Execute(strMatch)
   End With
End Function

Sub Unsubscribe(oMessage)
   '
   ' RFC6068 The 'mailto' URI Scheme: subject, cc, bcc, in-reply-to, body etc.. ?first &second &third etc...
   '
   Const                m_To = "List Administrator"
   Const            m_Sender = "Unsubscriber Daemon"
   'Const    m_SenderAddress = "unsubscribe@mydomain.tld"
   Const        m_Postmaster = "Postmaster"
   Const m_PostmasterAddress = "postmaster@mydomain.tld"

   Dim a, b, strRegEx, Match, Matches, sMailTo, sURL, m_Subject, m_Body, doMail, doURL

   strRegEx = "apache\.org|horde\.org|lists\.sourceforge\.net"  '<--------- LOOKUP WHITELISTED DOMAIN
   If (Lookup(strRegEx, oMessage.From) = True) Then Exit Sub  '<--------- IF WHITELISTED DOMAIN THEN EXIT

   strRegEx = "(([A-Za-z0-9\.\-\+]+)\@(mydomain1\.us|mydomain2\.com|mydomain3\.net))"  '<--------- LOOKUP LOCAL ADDRESSES
   If (Lookup(strRegEx, oMessage.Recipients) = True) Then   '<--------- IF ORIGINAL MESSAGE TO = LOCAL ADDRESS
      m_SenderAddress = Match.Value    '<--------- SET SENDER ADDRESS AS ORIGINAL RECIPIENT IN MESSAGE THAT TRIGGERED SUB
   Else 
      Exit Sub
   End If

   strRegEx = "^[0-1]:[0-1]$"
   If Lookup(strRegEx, oMessage.HeaderValue("X-hMailServer-Unsubscribe")) Then
      a = Split(oMessage.HeaderValue("X-hMailServer-Unsubscribe"), ":")
      doMail = a(0)
      doURL = a(1)
   Else
      doMail = True
      doURL = True
   End If
   If doMail Then
      strRegEx = "([^\<]*?)(mailto:[\s\S]*?)(?=\>)"
      Set Matches = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), True)
      If Matches.Count > 0 Then
         For Each Match In Matches
            ' On Error Resume Next
            sMailTo = Mid(Trim(Match.Value), 8)
            a = Split(sMailTo, "?")
            If UBound(a) > 0 Then
               b = Split(a(1), "&")
               If (InStr(1, b(0), "subject=", 1) > 0) Then m_Subject = Replace(b(0), "subject=", "")
               If (InStr(1, b(0), "body=", 1) > 0) Then m_Body = Replace(b(0), "body=", "")
               If UBound(b) > 0 Then
                  If (InStr(1, b(1), "subject=", 1) > 0) Then m_Subject = Replace(b(1), "subject=", "")
                  If (InStr(1, b(1), "body=", 1) > 0) Then m_Body = Replace(b(1), "body=", "")
               End If
            End If
            With CreateObject("hMailServer.Message")
               .From = Chr(34) & m_Sender & Chr(34) & " <" & m_SenderAddress & ">"
               .FromAddress = m_SenderAddress
               .AddRecipient a(0), a(0)
               .AddRecipient m_Postmaster, m_PostmasterAddress   '<--------- COPY POSTMASTER, NOT ORIGINAL RECIPIENT
               .HeaderValue("To") = Chr(34) & m_To & Chr(34) & " <" & a(0) & ">"
               .HeaderValue("CC") = Chr(34) & m_Postmaster & Chr(34) & " <" & m_PostmasterAddress & ">"
                If Not m_Subject = Empty Then
                   .Subject = m_Subject
                Else
                   .Subject = "Unsubscribe Me"
                End If
                If Not m_Body    = Empty Then
                   .Body = m_Body
                Else
                   .Body = "This is an automated message generated by our unsubscriber algorithym. Please do not respond to this email as it will be ignored."
                End If
               .Save
            End With
            ' On Error Goto 0
            If (Err.Number <> 0) Then
               EventLog.Write( "ERROR: Sub Unsubscribe(oMessage)" )
               EventLog.Write( "Error       : " & Err.Number )
               EventLog.Write( "Error (hex) : 0x" & Hex(Err.Number) )
               EventLog.Write( "Source      : " & Err.Source )
               EventLog.Write( "Description : " & Err.Description )
               Err.Clear
               Exit Sub
            End If
         Next
      End If
   End If
   If doURL Then
      strRegEx = "([^\<]*?)((http|https):[\s\S]*?)(?=\>)"
      Set Matches = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), True)
      If Matches.Count > 0 Then
         For Each Match In Matches
            sURL = Trim(Match.Value)
            On Error Resume Next
            With CreateObject("MSXML2.ServerXMLHTTP.6.0")
               .setoption(2) = (.getoption(2) & " - SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS")
               .open "GET", sURL, False
               .setrequestheader "User-Agent", "online link validator (http://www.dead-links.com/)"
               .send ("")
            End With
            On Error Goto 0
            If (Err.Number <> 0) Then
               EventLog.Write( "ERROR: Sub Unsubscribe(oMessage)" )
               EventLog.Write( "Error       : " & Err.Number )
               EventLog.Write( "Error (hex) : 0x" & Hex(Err.Number) )
               EventLog.Write( "Source      : " & Err.Source )
               EventLog.Write( "Description : " & Err.Description )
               Err.Clear
               Exit Sub
            End If
         Next
      End If
   End If
End Sub


palinka
Senior user
Senior user
Posts: 4461
Joined: 2017-09-12 17:57

Re: Sub Unsubscribe

Post by palinka » 2019-05-28 15:07

OK, I'm not very good at this. Finally got some hits. Was getting mismatch errors on Lookup. Also sorted out the recipient as unsubscriber sender. Had the wrong syntax. These things are corrected below. Should be working now.

Thanks again to Soren for this awesome and very useful script. All I did was tweak a couple of things.

Code: Select all

Dim a, b, strRegEx, Match, Matches, sMailTo, sURL, m_Subject, m_Body, doMail, doURL, m_SenderAddress

   strRegEx = "spamassassin\.apache\.org|lists\.horde\.org|lists\.sourceforge\.net"
   If Lookup(strRegEx, oMessage.From) Then Exit Sub

   strRegEx = "(([A-Za-z0-9\.\-\+]+)\@(mydomain1\.us|mydomain2\.com|mydomain3\.net))"
   Set Matches = oLookup(strRegEx, oMessage.Recipients(0).OriginalAddress, False)
   For Each Match In Matches
     m_SenderAddress = Match.Value
   Next

palinka
Senior user
Senior user
Posts: 4461
Joined: 2017-09-12 17:57

Re: Sub Unsubscribe

Post by palinka » 2019-05-28 19:19

Just got my first hit. Confirmed working. Original recipient of the message that triggered the rule became the sender of the unsubscribe message. :D

User avatar
SorenR
Senior user
Senior user
Posts: 6315
Joined: 2006-08-21 15:38
Location: Denmark

Re: Sub Unsubscribe

Post by SorenR » 2019-05-29 14:33

palinka wrote:
2019-05-25 15:43
First, this doesn't have its own topic, so now it does (was buried within other topics).

Now, I've been using this for a while and it works well. However, I noticed a couple of things.

1) Some unsubscribes require the recipient address. Original script has a set from address (unsubscribe@mydomain.tld)
2) I noticed that once in a while legit mailing list senders trigger the unsubscribe rule, which is IF spam score > 0 THEN run unsubscribe. So I want a whitelist.

In this case the message was clean but was triggered by "ransomware" because it contained a discussion about ransomware spam. ugh... :roll:

I think the whitelist part is easy enough, but I'm not sure exactly if my "send from original recipient" bit will work. What do you think?

Code: Select all

Sub Unsubscribe(oMessage)
   '
   ' RFC6068 The 'mailto' URI Scheme: subject, cc, bcc, in-reply-to, body etc.. ?first &second &third etc...
   '
   Const            m_To = "List Administrator"
   Const        m_Sender = "Unsubscriber Daemon"
   Set m_SenderAddress = oMessage.OriginalAddress  '<--------- WILL THIS WORK????

   Dim a, b, strRegEx, Match, Matches, sMailTo, sURL, m_Subject, m_Body, doMail, doURL

   strRegEx = "apache.org|horde.org|lists.sourceforge.net"  '<--------- LOOKUP WHITELISTED DOMAIN
   If (Lookup(strRegEx, oClient.From) = True) Then Exit Sub  '<--------- IF WHITELISTED DOMAIN THEN EXIT

   strRegEx = "^[0-1]:[0-1]$"
   If Lookup(strRegEx, oMessage.HeaderValue("X-hMailServer-Unsubscribe")) Then
      a = Split(oMessage.HeaderValue("X-hMailServer-Unsubscribe"), ":")
      doMail = a(0)
      doURL = a(1)
   Else
      doMail = True
      doURL = True
   End If
   If doMail Then
      strRegEx = "([^\<]*?)(mailto:[\s\S]*?)(?=\>)"
      Set Matches = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), True)
      If Matches.Count > 0 Then
         For Each Match In Matches
            ' On Error Resume Next
            sMailTo = Mid(Trim(Match.Value), 8)
            a = Split(sMailTo, "?")
            If UBound(a) > 0 Then
               b = Split(a(1), "&")
               If (InStr(1, b(0), "subject=", 1) > 0) Then m_Subject = Replace(b(0), "subject=", "")
               If (InStr(1, b(0), "body=", 1) > 0) Then m_Body = Replace(b(0), "body=", "")
               If UBound(b) > 0 Then
                  If (InStr(1, b(1), "subject=", 1) > 0) Then m_Subject = Replace(b(1), "subject=", "")
                  If (InStr(1, b(1), "body=", 1) > 0) Then m_Body = Replace(b(1), "body=", "")
               End If
            End If
            With CreateObject("hMailServer.Message")
               .From = Chr(34) & m_Sender & Chr(34) & " <" & m_SenderAddress & ">"
               .FromAddress = m_SenderAddress
               .AddRecipient a(0), a(0)
               .AddRecipient m_Sender, m_SenderAddress
               .HeaderValue("To") = Chr(34) & m_To & Chr(34) & " <" & a(0) & ">"
               .HeaderValue("CC") = Chr(34) & m_Sender & Chr(34) & " <" & m_SenderAddress & ">"
                If Not m_Subject = Empty Then
                   .Subject = m_Subject
                Else
                   .Subject = "Unsubscribe Me"
                End If
                If Not m_Body    = Empty Then
                   .Body = m_Body
                Else
                   .Body = "This is an automated message generated by our unsubscriber algorithym. Please do not respond to this email as it will be ignored."
                End If
               .Save
            End With
            ' On Error Goto 0
            If (Err.Number <> 0) Then
               EventLog.Write( "ERROR: Sub Unsubscribe(oMessage)" )
               EventLog.Write( "Error       : " & Err.Number )
               EventLog.Write( "Error (hex) : 0x" & Hex(Err.Number) )
               EventLog.Write( "Source      : " & Err.Source )
               EventLog.Write( "Description : " & Err.Description )
               Err.Clear
               Exit Sub
            End If
         Next
      End If
   End If
   If doURL Then
      strRegEx = "([^\<]*?)((http|https):[\s\S]*?)(?=\>)"
      Set Matches = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), True)
      If Matches.Count > 0 Then
         For Each Match In Matches
            sURL = Trim(Match.Value)
            On Error Resume Next
            With CreateObject("MSXML2.ServerXMLHTTP.6.0")
               .setoption(2) = (.getoption(2) & " - SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS")
               .open "GET", sURL, False
               .setrequestheader "User-Agent", "online link validator (http://www.dead-links.com/)"
               .send ("")
            End With
            On Error Goto 0
            If (Err.Number <> 0) Then
               EventLog.Write( "ERROR: Sub Unsubscribe(oMessage)" )
               EventLog.Write( "Error       : " & Err.Number )
               EventLog.Write( "Error (hex) : 0x" & Hex(Err.Number) )
               EventLog.Write( "Source      : " & Err.Source )
               EventLog.Write( "Description : " & Err.Description )
               Err.Clear
               Exit Sub
            End If
         Next
      End If
   End If
End Sub
The only reason you end up here is because the mail is tagged as SPAM... Do the "green thing" and whitelist in your SPAM handling - save some CPU cycles. :mrgreen:
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

palinka
Senior user
Senior user
Posts: 4461
Joined: 2017-09-12 17:57

Re: Sub Unsubscribe

Post by palinka » 2019-05-29 16:07

SorenR wrote:
2019-05-29 14:33
The only reason you end up here is because the mail is tagged as SPAM... Do the "green thing" and whitelist in your SPAM handling - save some CPU cycles. :mrgreen:
Yep. Sure enough. But fortunately, the unsubscribe that kicked off the thought process was to the spamassassin list, which kindly sent me back a message that unsubscribe@mydomain.tld was not on the list and couldn't be unsubscribed. So that got me thinking maybe that's why so many others keep sending mail after unsubscribing. The sender address is the one they try to unsubscribe.

I think this part is an improvement. :mrgreen:

User avatar
SorenR
Senior user
Senior user
Posts: 6315
Joined: 2006-08-21 15:38
Location: Denmark

Re: Sub Unsubscribe

Post by SorenR » 2019-05-29 16:58

palinka wrote:
2019-05-29 16:07
SorenR wrote:
2019-05-29 14:33
The only reason you end up here is because the mail is tagged as SPAM... Do the "green thing" and whitelist in your SPAM handling - save some CPU cycles. :mrgreen:
Yep. Sure enough. But fortunately, the unsubscribe that kicked off the thought process was to the spamassassin list, which kindly sent me back a message that unsubscribe@mydomain.tld was not on the list and couldn't be unsubscribed. So that got me thinking maybe that's why so many others keep sending mail after unsubscribing. The sender address is the one they try to unsubscribe.

I think this part is an improvement. :mrgreen:
I've got something cooking on that matter as we speak ... Progress is however VERY slow as I've received 6 spam mails this month (!) with a "mailto" list thingy... :roll:
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

palinka
Senior user
Senior user
Posts: 4461
Joined: 2017-09-12 17:57

Re: Sub Unsubscribe

Post by palinka » 2019-05-29 17:33

SorenR wrote:
2019-05-29 16:58
I've got something cooking on that matter as we speak ... Progress is however VERY slow as I've received 6 spam mails this month (!) with a "mailto" list thingy... :roll:
LOL me too. Not many spasms getting through since i implemented your rules. And 2 gorillion autobans. :mrgreen:

User avatar
SorenR
Senior user
Senior user
Posts: 6315
Joined: 2006-08-21 15:38
Location: Denmark

Re: Sub Unsubscribe

Post by SorenR » 2019-06-05 14:41

The way I use this Sub is on a forwarded message by my SPAM account.
For this to work I have to record the original recipient of the message so I added this Sub

Code: Select all

Sub XEnvelope(oMessage)
   Dim i, strTo, strOriginalTo
   For i = 0 To oMessage.Recipients.Count-1
      If (i = 0) Then
         strTo = oMessage.Recipients(i).Address
         strOriginalTo = oMessage.Recipients(i).OriginalAddress
      Else
         strTo = strTo & ", " & oMessage.Recipients(i).Address
         strOriginalTo = strOriginalTo & ", " & oMessage.Recipients(i).OriginalAddress
      End If
   Next
   oMessage.HeaderValue("X-Envelope-To") = strTo
   oMessage.HeaderValue("X-Envelope-OriginalTo") = strOriginalTo
   oMessage.HeaderValue("X-Envelope-From") = oMessage.FromAddress
   oMessage.Save
End Sub
and call it ...

Code: Select all

Sub OnAcceptMessage(oClient, oMessage)
   '
   '   Add X-Envelope... headers
   '
   Call XEnvelope(oMessage)
End Sub
The Unsubscribe code ...

Code: Select all

Sub Unsubscribe(oMessage)
   '
   ' RFC6068 The 'mailto' URI Scheme: subject, cc, bcc, in-reply-to, body etc.. ?first &second &third etc...
   '
   Const     sBcc = "Automated SPAM Handler"
   Const sBccAddr = "spam@lolle.org"
   Dim a, b, c, i, j, strRegEx, Match, Matches, sMailTo, sTo, sFrom, sSubject, sBody, sURL, doMail, doURL
   strRegEx = "^[0-1]:[0-1]$"
   If Lookup(strRegEx, oMessage.HeaderValue("X-hMailServer-Unsubscribe")) Then
      a = Split(oMessage.HeaderValue("X-hMailServer-Unsubscribe"), ":")
      doMail = a(0)
      doURL = a(1)
   Else
      doMail = True
      doURL = True
   End If
   If doMail Then
      strRegEx = "([^\<]*?)(mailto:[\s\S]*?)(?=\>)"
      Set Matches = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), True)
      For Each Match In Matches
         sMailTo = Mid(Trim(Match.Value), 8)
         a = Split(sMailTo, "?")
         If (UBound(a) > 0) Then
            b = Split(a(1), "&")
            For i = LBound(b) To UBound(b)
               If (InStr(1, b(i), "subject=", 1) > 0) Then sSubject = Replace(b(i), "subject=", "")
               If (InStr(1, b(i), "body=", 1) > 0) Then sBody = Replace(b(i), "body=", "")
            Next
         End If
         sTo = Trim(a(0))

         '
         '   ==> This is a forwarded message ! <==
         '   X-Envelope-OriginalTo may contain more that one address, process all of them.
         '
         c = Split(oMessage.HeaderValue("X-Envelope-OriginalTo"), ",")
         For j = LBound(c) To UBound(c)
            sFrom = Trim(c(j))

'        '
'        '   ==> This is the orginal inbound message ! <==
'        '   oMessage.Recipients(j).OriginalAddress may contain more that one address, process all of them.
'        '
'        For j = 0 To oMessage.Recipients.Count-1
'           sFrom = Trim(oMessage.Recipients(j).OriginalAddress)

            With CreateObject("hMailServer.Message")
               .AddRecipient sTo, sTo
               .AddRecipient sBcc, sBccAddr
               .FromAddress = sFrom
               .HeaderValue("To") = Chr(34) & sTo & Chr(34) & " <" & sTo & ">"
               .HeaderValue("From") = Chr(34) & sFrom & Chr(34) & " <" & sFrom & ">"
               If Not IsEmpty(sSubject) Then .Subject = sSubject
               If Not IsEmpty(sBody) Then .Body = sBody
               .Save
            End With
         Next
      Next
   End If
   If doURL Then
      strRegEx = "([^\<]*?)((http|https):[\s\S]*?)(?=\>)"
      Set Matches = oLookup(strRegEx, oMessage.HeaderValue("List-Unsubscribe"), True)
      For Each Match In Matches
         sURL = Trim(Match.Value)
         With CreateObject("MSXML2.ServerXMLHTTP.6.0")
            .setoption(2) = (.getoption(2) & " - SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS")
            .open "GET", sURL, False
            .setrequestheader "User-Agent", "online link validator (http://www.dead-links.com/)"
            .send ("")
         End With
      Next
   End If
End Sub
IF you are using this code on the original message you need to put comments on this code section ...

Code: Select all

         '
         '   ==> This is a forwarded message ! <==
         '   X-Envelope-OriginalTo may contain more that one address, process all of them.
         '
         c = Split(oMessage.HeaderValue("X-Envelope-OriginalTo"), ",")
         For j = LBound(c) To UBound(c)
            sFrom = Trim(c(j))
and remove the comments on this code section.

Code: Select all


'        '
'        '   ==> This is the orginal inbound message ! <==
'        '   oMessage.Recipients(j).OriginalAddress may contain more that one address, process all of them.
'        '
'        For j = 0 To oMessage.Recipients.Count-1
'           sFrom = Trim(oMessage.Recipients(j).OriginalAddress)
Normally Sub Unsubscribe() will unsubscribe from whatever is listed in the header "List-Unsubscribe". There is a way to control if Sub Unsubscribe() should only unsubscribe via mailto or via url.

Before running the rule that execute Sub Unsubscribe() you can "Set header value" [X-hMailServer-Unsubscribe] to:

0:0 ==> Do nothing.
1:0 ==> Unsubscribe MailTo only
0:1 ==> Unsubscribe URL only
1:1 ==> Unsubscribe MailTo and URL (default)

Happy hunting!
I assumes no responsibility or liability for any errors or omissions in the content of this post. The information contained in this post is provided on an "as is" basis with no guarantees of completeness, accuracy, usefulness or timeliness...
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

palinka
Senior user
Senior user
Posts: 4461
Joined: 2017-09-12 17:57

Re: Sub Unsubscribe

Post by palinka » 2019-06-05 22:19

Maybe a dumb question, buuutttt…..

Code: Select all

'        '   ==> This is the orginal inbound message ! <==
'        '   oMessage.Recipients(j).OriginalAddress may contain more that one address, process all of them.
Is there any chance that ANY original recipient could be from an outside domain?

palinka
Senior user
Senior user
Posts: 4461
Joined: 2017-09-12 17:57

Re: Sub Unsubscribe

Post by palinka » 2019-06-05 22:47

And don't forget this:

Code: Select all

               If Not IsEmpty(sSubject) Then .Subject = sSubject
               Else
                  .Subject = "Unsubscribe Me"
               End If
               If Not IsEmpty(sBody) Then .Body = sBody
               Else
                  .Body = "This is an automated message generated by our unsubscriber algorithym. Please do not respond to this email as it will be ignored."
               End If
              .Save
Just in case they run a spam check. Empty body and subject don't do too well against that. Also, "Unsubscribe Me" vs plain "Unsubscribe" lets me know that the target subject was empty. :mrgreen:

User avatar
SorenR
Senior user
Senior user
Posts: 6315
Joined: 2006-08-21 15:38
Location: Denmark

Re: Sub Unsubscribe

Post by SorenR » 2019-06-05 23:36

palinka wrote:
2019-06-05 22:47
And don't forget this:

Code: Select all

               If Not IsEmpty(sSubject) Then .Subject = sSubject
               Else
                  .Subject = "Unsubscribe Me"
               End If
               If Not IsEmpty(sBody) Then .Body = sBody
               Else
                  .Body = "This is an automated message generated by our unsubscriber algorithym. Please do not respond to this email as it will be ignored."
               End If
              .Save
Just in case they run a spam check. Empty body and subject don't do too well against that. Also, "Unsubscribe Me" vs plain "Unsubscribe" lets me know that the target subject was empty. :mrgreen:
Spammers doing spam checks on people unsubscribing their spam mails ... who would have thought :roll:

RFC6068 specify the layout of the MailTo: command and if they do not include "body=" or "subject=" then either they made provisions to receive the mail without triggering their SPAM system ... OR ... they don't really give a sh... er ... Damn.

Anyways, found another problem. Got hit today with an address "h-opxqe_ewljs_bavosdw_rirkjve_qx@bounce.pharmacy-zb.com.ua" ... "bounce.pharmacy-zb.com.ua" do not exist but "pharmacy-zb.com.ua" do ... so I'll be addressing this issue. Perhaps doing a DNS lookup before generating the mail and maybe ... maybe altering the domain by removing the obvious "bounce".
SørenR.

Woke is Marxism advancing through Maoist cultural revolution.

palinka
Senior user
Senior user
Posts: 4461
Joined: 2017-09-12 17:57

Re: Sub Unsubscribe

Post by palinka » 2019-06-06 02:42

SorenR wrote:
2019-06-05 23:36
Spammers doing spam checks on people unsubscribing their spam mails ... who would have thought :roll:

RFC6068 specify the layout of the MailTo: command and if they do not include "body=" or "subject=" then either they made provisions to receive the mail without triggering their SPAM system ... OR ... they don't really give a sh... er ... Damn.
Certainly you've been on God's green earth long enough to know that quite often the left hand doesn't always talk to the right hand. :mrgreen:

Anyway, what's the point of unsubscribing spam? My trigger rule is for spam < delete threshold, so it's almost all commercial messages that are poorly formatted and get tripped up in SA jam-link and stuff like that. Plus some false positives from spamcop. Nothing malicious - the stuff you actually want to unsubscribe. Anyway, all the bases are covered with anything in the subject and body. Doesn't hurt anything and it could help in the left hand/ right hand/ no coordination organizations.

Post Reply