'File: SignatureEventSink.vbs
'Author: Ben Blackmore (bjblackmore@hotmail.com)
'Created: November 20th 2006 - Version: 1.1
'SMTP Event Sink to query Active Directory for user information based on senders
'email address, and then create both HTML & Plain Text signatures.
'Based on Microsofts EventSinkScript.vbs at http://support.microsoft.com/kb/317680
'If you have any improvements, please let me know.
'My thanks to Richard Mueller for all his help in microsoft.public.adsi.general
'Notes : To register this script you will need the smtpreg.vbs file from the Exchange SDK.
'Open a command prompt and cd\ to the directory containing smtpreg.vbs, type:
'cscript smtpreg.vbs /add 1 onarrival SMTPScriptingHost CDO.SS_SMTPOnArrivalSink "mail from=*@your-domain-here.com"
'cscript smtpreg.vbs /setprop 1 onarrival SMTPScriptingHost Sink ScriptName "C:\path to file\SignatureEventSink.vbs"
'To unregister the Event Sink type
'cscript smtpreg.vbs /remove 1 OnArrival SMTPScriptingHost

<SCRIPT LANGUAGE="VBScript">
Sub ISMTPOnArrival_OnArrival(ByVal Msg, EventStatus)
	'Create AD connection
	set oComm=createObject("ADODB.Command") 
	Set oConnect = CreateObject("ADODB.Connection") 
	oConnect.Provider = "ADsDSOObject"
	oConnect.Properties("User ID") = "cn=Administrator,cn=Users,DC=domain,DC=com"
	oConnect.Properties("Password") = "password"
	oConnect.Properties("Encrypt Password") = True 
	oConnect.Open "Active Directory Provider"
	Set oRs = CreateObject("ADODB.Recordset") 
	oRs.ActiveConnection = oConnect
	oComm.activeConnection=oConnect

	'Strip email address from message & set as search variable
	sStart = "<"
	sEnd = ">"    
	sData = Msg.From
	startpoint = (instr(sData,"<") + len(sStart))
	endpoint = instr(sData,sEnd)
	epoint = endpoint - startpoint
	strFrom = mid(sData, startpoint, epoint)

	'Set Query Parameters
	sADsPath = "<LDAP://server.domain.com/DC=domain,DC=com>;" 
	sFilter = "(&(objectCategory=person)(mail="&strFrom&"));" 
	sAttrs = "displayName,description,title,telephoneNumber,mobile;" 
	sScope = "SubTree" 
	
	'Run AD query
	sQuery = sADsPath&sFilter&sAttrs&sScope 
	oComm.commandText=sQuery
	set oRs=oComm.execute 

	'Set variables from query
	If Not oRs.EOF then
		strName = oRs.Fields("displayName") 
		strDescription = oRs.Fields("description").value
		strTitle = oRs.Fields("Title") 
		strPhone = oRs.Fields("TelephoneNumber") 
		strMobile = oRs.Fields("Mobile") 
		strPhone = "+44 (0)" & Right(strPhone, 11)
		strMobile = "+44 (0)" & Right(strMobile, 10)
	End If

	'Defind forward or reply prefix, we dont want to append a signature to these emails
	Dim strSub(2)
	strSub(0) = "re:"
	strSub(1) = "fw:"
	strSub(2) = "fwd"
	strString = LCase(Msg.Subject)

	For Each x in strSub
	strSearch = instr(strString,x)
	If strSearch > "0" Then
	CreateSig = "1"
	End if
	Next

	If CreateSig < "1" Then	
		'Create text signature
	TextSignature = strName
	If Not IsNull(oRs.Fields("description").value) Then
		TextSignature = TextSignature & ", " & strDescription(0)
	end if
	TextSignature = TextSignature & vbCrLf & strTitle & vbCrLf & "Company Name" & vbCrLf & "Tel:" & vbTab & strPhone 
	if oRs.Fields("Mobile") Then
		TextSignature = TextSignature & vbCrLf & "Mobile:" & vbTab & strMobile
	end if
	TextSignature = TextSignature & vbCrLf & "E-mail:" & vbTab & strFrom & vbCrLf & "www.domain.com" & vbCrLf

	'Create HTML signature
	HTMLSignature = "<font face=""Arial"" size=""2""><p>" & strName & ", " & strDescription(0) &"<br>"& strTitle & "<br><font color=""#003093""><b>Company Name</b></font><br>Tel:" & vbTab & strPhone & _
			"<br>Mobile:" & vbTab & strMobile &"<br>E-mail:" & vbTab & strFrom & _
			"<br><A href=""http://www.domain.com"">www.domain.com</A></p></font>"

   If Msg.HTMLBody <> "" Then
      'Search for the "</body>" tag and insert our Signature before that tag.
      pos = InStr(1, Msg.HTMLBody, "</body>", vbTextCompare)
      szPartI = Left(Msg.HTMLBody, pos - 1)
      szPartII = Right(Msg.HTMLBody, Len(Msg.HTMLBody) - (pos - 1))
      Msg.HTMLBody = szPartI + HTMLSignature + szPartII
   End If

   If Msg.TextBody <> "" Then
      Msg.TextBody = Msg.TextBody & vbCrLf & TextSignature & vbCrLf
   End If
    
   'Commit the content changes to the transport ADO Stream object.
   Msg.DataSource.Save ' Commit the changes into the transport Stream

   EventStatus = cdoRunNextSink
End Sub
</SCRIPT>