Code: Select all
Sub OnAcceptMessage(oClient, oMessage)
On Error Resume Next
If oClient.Username <> "" Then
If LCase(oClient.Username) <> LCase(oMessage.FromAddress) Then
Dim obBaseApp
Set obBaseApp = CreateObject("hMailServer.Application")
Call obBaseApp.Authenticate("Administrator","password") 'PUT HERE YOUR PASSWORD
StrClientDomain = Mid(oClient.Username,InStr(oClient.Username,"@") + 1)
StrFromDomain = Mid(oMessage.FromAddress,InStr(oMessage.FromAddress,"@") + 1)
Dim obDomain
Set obDomain = obBaseApp.Domains.ItemByName(StrClientDomain)
Dim obAliases
Dim obAlias
AliasFound = False
If LCase(StrClientDomain) <> LCase(StrFromDomain) Then
Set obAliases = obDomain.DomainAliases
For iAliases = 0 To (obAliases.Count - 1)
Set obAlias = obAliases.Item(iAliases)
if LCase(obAlias.AliasName) = LCase(StrFromDomain) Then
AliasFound = True
Exit For
End If
Next
If AliasFound Then
StrFromAddress = Left(oMessage.FromAddress, Len(oMessage.FromAddress) - Len(StrFromDomain)) + StrClientDomain
End If
Else
StrFromAddress = oMessage.FromAddress
AliasFound = True
End If