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...
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
