Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim arrEID As Variant, varEID As Variant, olkItm As Object, olkPrp As Object, olkExu As Object, strUsr As String
    On Error Resume Next
    arrEID = Split(EntryIDCollection, ",")
    For Each varEID In arrEID
        Set olkItm = Session.GetItemFromID(varEID)
        If olkItm.Class = olMail Then
            Set olkExu = olkItm.Sender.GetExchangeUser
            If TypeName(olkExu) = "Nothing" Then
                strUsr = ""
            Else
                strUsr = GetUsernameFromAlias(olkExu.Alias)
            End If
            Set olkPrp = olkItm.UserProperties.Add("Username", olText, True)
            olkPrp.Value = strUsr
            olkItm.Save
            Set olkPrp = Nothing
        End If
    Next
    On Error GoTo 0
    Set olkItm = Nothing
    Set olkExu = Nothing
End Sub

Function GetUsernameFromAlias(strAls As String) As String
    Dim adoCon As Object, adoRec As Object, objDSE As Object, strDNC As String, strSrc As String
    Set objDSE = GetObject("LDAP://RootDSE")
    strDNC = objDSE.get("defaultnamingcontext")
    strSrc = "'LDAP://" & strDNC & "'"
    Set adoCon = CreateObject("ADODB.Connection")
    adoCon.Provider = "ADsDSOObject"
    adoCon.CursorLocation = 3
    adoCon.Open "ADSI"
    Set adoRec = adoCon.Execute("SELECT sAMAccountName, extensionAttribute2 FROM " & strSrc & " Where objectClass='user' AND objectCategory='Person' AND mailNickname='" & strAls & "'")
    If Not adoRec.BOF And Not adoRec.EOF Then
        GetUsernameFromAlias = adoRec.Fields("samAccountName").Value
        GetUsernameFromAlias = GetUsernameFromAlias & " ; "
        GetUsernameFromAlias = GetUsernameFromAlias & adoRec.Fields("extensionAttribute2").Value
    Else
        GetUsernameFromAlias = "Not Found"
    End If
    adoRec.Close
    adoCon.Close
    Set adoRec = Nothing
    Set adoCon = Nothing
    Set objDSE = Nothing
End Function