Automated Mailing List upgraded for 4.3

This section contains scripts that hMailServer has contributed with. hMailServer 4 is needed to use these.
Post Reply
Spm
Normal user
Normal user
Posts: 36
Joined: 2006-06-09 15:06

Automated Mailing List upgraded for 4.3

Post by Spm » 2007-03-01 21:30

Features
#Send Email to register on a distribution list.
#Send Email to be reomved from a distribution list.
#Mask Senders Email address.
#Works for version 4.3.1

Bugs
#sender receives a copy of the email they sent

How to use
Create a distribution List e.g Members manually add at least one user
Set Members List to Public * The scipt makes this list a private list any way!

change the admin password in the code below. Users can then subscribe to the disrtibution list by emailing the list with the word subscribe in the subject. They can also be removed from the lsit by having the word remove in the subject.

At the very top of the EventHandler.vbs file add the following

Code: Select all


dim adminpassword
dim subscribeword
dim removeword

'Settings
adminpassword = "Your_hamail_admin_password_Here"
subscribeword = "subscribe"
removeword = "remove"
Next In the "OnAcceptMessage(oClient, oMessage)" section in EventHandlers.vbs and type

Code: Select all

call signup_to_distributionList(domain, distribution list to join, mailing list name, oMessage)
e.g.

Code: Select all

call signup_to_distributionList("domainname.co.uk", "distributionlist@domainname.co.uk", "name of distributionlistlist", oMessage)
   call signup_to_distributionList("otherdomainname.com", "members@otherdomainname.com", "Name of Members Mailinglist", oMessage)
then add the following code to the EventHandlers.vbs

Code: Select all



Sub signup_to_distributionList(strDomain, distrtojoin, mailinglistname, oMessage)
	dim oMessagereply
	dim q
	dim rejectMessage
	dim htmlrejectMessage


	If InStr(oMessage.To, distrtojoin) Then 	
		
		'Check that domain exist
		Set oDomain    = GetDomainObjectByName(strDomain)
		If (oDomain is Nothing) Then
			WriteLog "Can't find the domain " + strDomain
		End If

	   'Check If Distribution List exists
	   Set oDList    = GetDistributionListObject(strDomain, distrtojoin)

		'Check If sender is in distribution List
		If InDistributionListObject(oDList, oMessage.fromaddress) or CleanAddress(oMessage.fromaddress)=distrtojoin Then
			'User Exisitsin List
			
			'If the subject has remove written in it then remove user
			If InStr(lcase(oMessage.Subject), removeword) Then
				'Remove email address from distribution list
					   address             = CleanAddress(oMessage.fromaddress)
					   qtyRecipients      = oDList.Recipients.Count
					   Set oRecipients    = oDList.Recipients
					   For iRecipient = 0 to qtyRecipients-1
	
					      If (address = CleanAddress(oRecipients(iRecipient).RecipientAddress)) Then
					         
						oRecipients.DeleteByDBID( oRecipients(iRecipient).ID )
					        'Exit Function
					      End If
					
					   Next
					   
					   q=chr(34)
						dim ByeMessage, HTMLByeMessage
						ByeMessage   = "Thank you for using "+ mailinglistname + " " & vbCRLF & vbCRLF
						HTMLByeMessage   = replace(ByeMessage,vbCRLF,"<br>")
						
						if oMessage.HasBodyType("text/html") Then
							oMessage.HTMLBody = HTMLByeMessage & oMessage.HTMLBody 
						ELSE
							oMessage.body   = ByeMessage & oMessage.body 
						End If 
						oMessage.Subject = "Your address has been removed from " + distrtojoin
		
						oMessage.Save() 
						oMessage.ClearRecipients()
						call oMessage.AddRecipient("", oMessage.FromAddress)
						oMessage.Save() 
					  
				
			ELSE
				'Send email to list
				 				 WriteLog "oMessage.FromAddress :" + oMessage.FromAddress
				 dim Signature, HTMLSignature
				Signature   = vbCRLF & vbCRLF & "To be removed from " + mailinglistname + ". " & vbCRLF & vbCRLF & "Simply send an email to " + distrtojoin + " with the word remove as the subject." & vbCRLF & vbCRLF
				HTMLSignature   = replace(Signature,vbCRLF,"<br></BODY>")
				
				if oMessage.HasBodyType("text/html") Then
					oMessage.HTMLBody = replace(oMessage.HTMLBody,"</body>","") + HTMLSignature
				ELSE
					oMessage.body   = oMessage.body + Signature
				End If 
				 
				 oMessage.From = replace(oMessage.From,oMessage.Fromaddress, distrtojoin)
				 oMessage.Save
				 
			END IF
			
		ELSE
			' User not in list
			If InStr(lcase(oMessage.Subject), subscribeword) Then
				Call AddDistributionListRecipient(oMessage.fromaddress, distrtojoin, strDomain)
				WriteLog fromaddress + " has been added"
				'Send Welcome Message
				q=chr(34)
				dim WelcomeMessage, HTMLWelcomMessage
				WelcomeMessage   = "Welcome to " + mailinglistname + ". " & vbCRLF & vbCRLF & "If you would like to be removed please send an email to " + distrtojoin + " with the word remove as the subject." & vbCRLF & vbCRLF
				HTMLWelcomeMessage   = replace(WelcomeMessage,vbCRLF,"<br>")
				
				if oMessage.HasBodyType("text/html") Then
					oMessage.HTMLBody = HTMLWelcomeMessage & oMessage.HTMLBody 
				ELSE
					oMessage.body   = WelcomeMessage & oMessage.body 
				End If 
				oMessage.Subject = "Your address has been added to " + distrtojoin

				oMessage.Save() 
				oMessage.ClearRecipients()
				call oMessage.AddRecipient("", oMessage.FromAddress)
				oMessage.Save() 
				

			ELSE
			
				'Drop email Email
				q=chr(34)

				rejectMessage   = "Rejected because you are not authorised to send to this email address" & vbCRLF & vbCRLF
				HTMLrejectMessage   = "Rejected because you are not authorised to send to this email address<br><br>"
				
				if oMessage.HasBodyType("text/html") Then
					oMessage.HTMLBody = HTMLrejectMessage & oMessage.HTMLBody 
				ELSE
					oMessage.body   = rejectMessage & oMessage.body 
				End If 
				oMessage.Subject = "Rejected: " + oMessage.Subject
				oMessage.Save() 
				oMessage.ClearRecipients()
				call oMessage.AddRecipient("", oMessage.FromAddress)
				oMessage.Save() 
				
			END IF
			
			WriteLog fromaddress + " is not in the distribution list"
		End If
	END IF
END SUb

	
Sub AddDistributionListRecipient(strRecipientAddress, strRecipientListAddress, strDomain)
	'WriteLog "AddDistributionListRecipient " + strRecipientAddress + " - " + strRecipientListAddress + " - " + strDomain
	
	
	Dim obApp
		Set obBaseApp = CreateObject("hMailServer.Application")

		' Authenticate. Without doing this, we won't have permission
		' to change any server settings or add any objects to the
		' installation.   
		Call obBaseApp.Authenticate("Administrator", adminpassword)
		
	Dim obBaseApp 
	Dim obDomain
	Dim obDistributionLists
	Dim obDistributionList
	Dim obDistributionListRecipients
	Dim obNewDistributionListRecipient
	
	'Set obBaseApp = CreateObject("hMailServer.Application") 
	Set obDomain = obBaseApp.Domains.ItemByName(strDomain)
	Set obDistributionLists = obDomain.DistributionLists
	Set obDistributionList = obDistributionLists.ItemByAddress(strRecipientListAddress)
	Set obDistributionListRecipients = obDistributionList.Recipients
	Set obNewDistributionListRecipient = obDistributionListRecipients.Add()
	
	Call obBaseApp.Authenticate("Administrator", adminpassword)
	
	obNewDistributionListRecipient.RecipientAddress = CleanAddress(strRecipientAddress)
	'recipientAddress
	obNewDistributionListRecipient.Save() 
	'saves distributionListRecipient
	
	Set obNewDistributionListRecipient = Nothing
	Set obDistributionListRecipients = Nothing
	Set obDistributionList = Nothing
	Set obDistributionLists = Nothing
	Set obDomain = Nothing

End Sub

'
' CleanAddress
'
' Do anything necessary to "clean up" an address:
'   1) make it lower case
'   2) remove angle brackets if any
'
' Clean addresses should be able to be compared to each other
'
' Usage:
'
'    If (CleanAddress(oMessage.FromAddress) = "joe@foo.com") Then
'      EventLog.Write("yes this is from Joe")
'    End If
'
' Returns the cleaned address
'
Function CleanAddress(originaladdress)

   address      = originaladdress

   ' remove any white space
   address         = Trim(address)

   ' make the address lower case
   address         = Lcase(address)

   ' remove a leading angle bracket
   pos      = InStrRev(address, "<")

   If (pos > 0) Then
      address      = Mid(address, pos+1)
   End IF


   ' remove a traiing angle bracket
   pos      = InStrRev(address, ">")

   If (pos > 0) Then
      address      = Mid(address, 1, pos-1)
   End If

   ' remove any white space again
   address         = Trim(address)

   ' return the now-clean address
   CleanAddress   = address

End Function 


' GetDomainObjectByName
'
' Returns the Domain object for the specified domain name
' Returns 'Nothing' if the domain can't be found
'
' usage:
'
'    Set oDomain    = GetDomainObjectByName("widgets.com")
'    If (oDomain is Nothing) Then
'        EventLog.Write("Can't find the domain widgets.com")
'    End If
Function GetDomainObjectByName(domain)

   Dim iDomain
   Dim oApp
   Dim oDomain
   Dim oDomains
   Dim qtyDomains

   ' get the application object
   '
   Set oApp = CreateObject("hMailServer.Application")
   Call oApp.Authenticate("Administrator", adminpassword)


   ' get the Domains object
   Set oDomains        = oApp.Domains


   ' get the number of domains
   qtyDomains          = oDomains.Count


   For  iDomain = 0 to qtyDomains-1
      Set oDomain         = oDomains.Item(iDomain)
      If (Lcase(oDomain.Name) = Lcase(domain)) Then
         '
         ' found it!  return the index number
         '
         Set GetDomainObjectByName   = oDomain
         Exit Function
      End If

   Next


   ' failure - domain not found
   '
   Set GetDomainObjectByName      = Nothing


End Function

Function GetDistributionListObject(domainName, listName)

   Dim iList
   Dim oDistributionList
   Dim oDomain
   Dim qtyDistLists


   ' get the domain object
   Set oDomain         = GetDomainObjectByName(domainName)
   If (oDomain Is Nothing) Then
      GetDistributionListObject      = Nothing
      Exit Function
   End If

   qtyDistLists        = oDomain.DistributionLists.Count
   For  iList = 0 to qtyDistLists-1
      Set oDistributionlist   = oDomain.DistributionLists(iList)
      If (oDistributionList.Address = listName) Then
         Set GetDistributionListObject   = oDistributionlist
         Exit Function
      End If
   Next

   GetDistributionListObject      = Nothing

End Function  

'
' InDistributionListObject
'
' Tests if an email address is in a distribution list object
'
' Usage:
'
'    If InDistributionListObject(oDList, oMessage.FromAddress) Then
'        EventLog.Write(oMessage.FromAddress & " is in the distribution list")
'    End If
'
' Returns 1 if the address is in the distribution list
' Returns 0 if it is not
'

Function InDistributionListObject(oDistributionList, address)

   ' make address lower-case, etc
   '
   address             = CleanAddress(address)

   qtyRecipients      = oDistributionList.Recipients.Count

   Set oRecipients    = oDistributionlist.Recipients

   For iRecipient = 0 to qtyRecipients-1

      If (address = CleanAddress(oRecipients(iRecipient).RecipientAddress)) Then
         InDistributionListObject   = 1
         Exit Function
      End If

   Next

   InDistributionListObject   = 0

End Function 

Sub WriteLog( cString)
      SET ofs = CreateObject("scripting.filesystemobject")
      SET ofil = ofs.OpenTextFile( "C:\Program Files\hMailServer\Logs\stephen.log", 8, True)
      ofil.writeline( Now & " - " & cString)
      oFil.close
      SET ofil=nothing
      SET ofs = nothing
end sub 

SUB SendMessage(toaddress,fromname,fromaddress,subject,messagebdy)
	dim oMessage
	Set oMessage = CreateObject("hMailServer.Message")
	
	oMessage.From = fromname & " <"& fromaddress & ">"
	oMessage.FromAddress = fromaddress
	oMessage.Subject = subject
	oMessage.AddRecipient toaddress
	oMessage.Body = messagebdy
	oMessage.Save
	

END SUB

bgssgk
New user
New user
Posts: 3
Joined: 2007-03-23 23:03

Post by bgssgk » 2007-04-04 23:00

Is there a way to limit who can send to the list, like the announce only type, I've got everything working as described but I only want one address to be able to post to the list.

Thanks

^DooM^
Site Admin
Posts: 13861
Joined: 2005-07-29 16:18
Location: UK

Post by ^DooM^ » 2007-04-04 23:01

In the distribution list options in hmail admin you can setup who is allowed to post to the list.

bgssgk
New user
New user
Posts: 3
Joined: 2007-03-23 23:03

Post by bgssgk » 2007-04-04 23:10

I did try that but i believe it broke the script above, as i could not do anything afterwards.

Spm
Normal user
Normal user
Posts: 36
Joined: 2006-06-09 15:06

Post by Spm » 2007-04-05 12:55

The script drops any mail to people who are not inthe distribution list. You need to leave the securtiy option in hmail off otherwise new members can not register.

If you would like remove the drop featire so that it is just a normal distrubtion list that anyone can email then I can re-write the script for you! But you would still not be able to use the security features in hmail.

Let me know if you need any more help.

Spm
Normal user
Normal user
Posts: 36
Joined: 2006-06-09 15:06

Post by Spm » 2007-04-05 13:17

bgssgk wrote:Is there a way to limit who can send to the list, like the announce only type, I've got everything working as described but I only want one address to be able to post to the list.

Thanks
I could do this for you it will take some time as I do not have alot of time on my hands just now (trying to get my house on the market to sell)

If you want to have a crack at it your self you will need to find this section of code

Code: Select all

		ELSE
		 
				'Send email to list
							  WriteLog "oMessage.FromAddress :" + oMessage.FromAddress
				 dim Signature, HTMLSignature
				Signature   = vbCRLF & vbCRLF & "To be removed from " + mailinglistname + ". " & vbCRLF & vbCRLF & "Simply send an email to " + distrtojoin + " with the word remove as the subject." & vbCRLF & vbCRLF
				HTMLSignature   = replace(Signature,vbCRLF,"<br></BODY>")
				
				if oMessage.HasBodyType("text/html") Then
				   oMessage.HTMLBody = replace(oMessage.HTMLBody,"</body>","") + HTMLSignature
				ELSE
				   oMessage.body   = oMessage.body + Signature
				End If
				
				 oMessage.From = replace(oMessage.From,oMessage.Fromaddress, distrtojoin)
				 oMessage.Save
            
        END IF
then replace it with

Code: Select all

 	ELSE
		 
			IF oMessage.fromaddress = "me@mydomain.com" then
				'Send email to list
							  WriteLog "oMessage.FromAddress :" + oMessage.FromAddress
				 dim Signature, HTMLSignature
				Signature   = vbCRLF & vbCRLF & "To be removed from " + mailinglistname + ". " & vbCRLF & vbCRLF & "Simply send an email to " + distrtojoin + " with the word remove as the subject." & vbCRLF & vbCRLF
				HTMLSignature   = replace(Signature,vbCRLF,"<br></BODY>")
				
				if oMessage.HasBodyType("text/html") Then
				   oMessage.HTMLBody = replace(oMessage.HTMLBody,"</body>","") + HTMLSignature
				ELSE
				   oMessage.body   = oMessage.body + Signature
				End If
				
				 oMessage.From = replace(oMessage.From,oMessage.Fromaddress, distrtojoin)
				 oMessage.Save
			 ELSE
				 'Drop email Email
				q=chr(34)
	
				rejectMessage   = "Rejected because you are not authorised to send to this email address" & vbCRLF & vbCRLF
				HTMLrejectMessage   = "Rejected because you are not authorised to send to this email address<br><br>"
				
				if oMessage.HasBodyType("text/html") Then
				   oMessage.HTMLBody = HTMLrejectMessage & oMessage.HTMLBody
				ELSE
				   oMessage.body   = rejectMessage & oMessage.body
				End If
				oMessage.Subject = "Rejected: " + oMessage.Subject
				oMessage.Save()
				oMessage.ClearRecipients()
				call oMessage.AddRecipient("", oMessage.FromAddress)
				oMessage.Save()
			END IF
            
         END IF
I have not tested this but in theroy that is all you should need to do.

bgssgk
New user
New user
Posts: 3
Joined: 2007-03-23 23:03

Post by bgssgk » 2007-04-05 21:15

I'm sure I can work with that thanks for the help and good luck with the house, mines been on the market for a year :(

Spm
Normal user
Normal user
Posts: 36
Joined: 2006-06-09 15:06

Post by Spm » 2007-04-06 00:02

bgssgk wrote:I'm sure I can work with that thanks for the help and good luck with the house, mines been on the market for a year :(
Damn thats not that great. the house down the road went in a week and we are in a bad area so I am just hoping. Thanks good luck. Let me know how you get on if you run into probs i'll try and help

Thomas Parvais
Normal user
Normal user
Posts: 111
Joined: 2004-12-17 12:21
Contact:

compatible with Release 4.4 ?

Post by Thomas Parvais » 2007-05-15 11:35

Spm wrote:
bgssgk wrote:I'm sure I can work with that thanks for the help and good luck with the house, mines been on the market for a year :(
Damn thats not that great. the house down the road went in a week and we are in a bad area so I am just hoping. Thanks good luck. Let me know how you get on if you run into probs i'll try and help
Hello, is your script compatible with Release 4.4 ?

Finally, what should we do to implement a newsletter distribution list ?

Tx

Thomas

Spm
Normal user
Normal user
Posts: 36
Joined: 2006-06-09 15:06

Post by Spm » 2007-05-19 17:34

Yes it should be. the only reason ppl have revised script for version 4.3 is that hmail was made more secure with vesion 4.3 so additional code was required for scripts.

Sorry for the delay in repling but my email was down! (not hmail) but a pop3 to SMTP collector I am using.

AJB111
Normal user
Normal user
Posts: 184
Joined: 2005-01-28 05:13
Location: Australia
Contact:

Re: Automated Mailing List upgraded for 4.3

Post by AJB111 » 2008-05-20 07:35

Hi Everyone

Just struggling with this script.
I keep getting the 550 Not authorized error.

The DL is set to Active
The DL is set to Announcments,
The allowed email IS set and it exists
The DL email address is NOT set in the Accounts or Aliases
Authentication is NOT set

Even if I create a member manually and then try to subscribe again (which is handled by the script)
I still get the 550 Not Authorised error.

I must have tried 100 times with different accounts etc, have checked the script settings and admin password
Nothing I do allows a person to subscribe by email - you simply get the 550 Not authorized error every time

Any help appreciated, I can not see what I am doing wrong

TIA, JB
Windows Server 2003, IIS6
HMail Server 5.3.1 B1748
MySQL 5.0.67

Spm
Normal user
Normal user
Posts: 36
Joined: 2006-06-09 15:06

Re: Automated Mailing List upgraded for 4.3

Post by Spm » 2008-05-20 13:52

DL should be set to Public

I never tested the script with Membership or announcements as when I wrote the script these features were not available.

Also to help debug you will find this section in the script

Code: Select all

Sub WriteLog( cString)
      SET ofs = CreateObject("scripting.filesystemobject")
      SET ofil = ofs.OpenTextFile( "C:\Program Files\hMailServer\Logs\stephen.log", 8, True)
      ofil.writeline( Now & " - " & cString)
      oFil.close
      SET ofil=nothing
      SET ofs = nothing
end sub 
open "C:\Program Files\hMailServer\Logs\stephen.log" and reveiw the log to see what the issue is or even email me the log!

Post Reply