[zero55]

оказывается можно.
нашел у себя в архиве вот такой скриптик.
Скажу сразу не проболвал...

Код:

Const PR_STORE_PROVIDERS = &H3D000102 
Const PR_PROVIDER_UID = &H300C0102 
Const PR_DISPLAY_NAME = &H3001001E 
Const PR_PROFILE_MAILBOX = &H660B001E 
Const PR_PROFILE_SERVER = &H660C001E 
Const PR_PROFILE_SERVER_DN = &H6614001E 
Const PR_EMAIL_ADDRESS = &H3003001E 
Dim sTitle,sMessage, iKount 
sMailBoxName = InputBox("Enter the name of the mailbox to add","Add 
Additional Mailbox") 
' look up in ad to see if it exists 
Set Conn = CreateObject("ADODB.Connection") 
Conn.Open "Provider=ADsDSOObject;" 
Set Cmd = CreateObject("ADODB.Command") 
Cmd.ActiveConnection = Conn 
Cmd.CommandText = "<GC://dc=example,dc=com>;(&(objectCategory=person) 
(|(displayName=*" & sMailBoxName & "*) (sAMAccountName=*" &sMailBoxName & 
"*)));displayName,sAMAccountName;subtree" 
Set Rst = Cmd.Execute 
If Rst.RecordCount = 1 Then 
   ' found exact match 
   ' assume mailbox id is the sAMAccountName 
   sMailBoxID = Rst.Fields("sAMAccountName") 
   sMailSvr = "MAILSERVER1" ' the mail server the mailbox is on 
   sMailBoxDN = "/o=example/ou=staff/cn=Recipients/cn=" & sMailBoxID 
   sServerDN = "/O=example/OU=staff/cn=Configuration/cn=Servers/cn=" & 
sMailSvr 
   AddMailBox "",sMailBoxName,sMailBoxDN,sMailSvr,sServerDN 
   MsgBox "The mailbox for " & Rst.Fields("displayName") & "has been added. 
Please check that it has been added to your profile " & _ 
          "correctly. If there is still a problem please report it to the 
Service Desk ",0,"Finished" 
Else 
   If Rst.RecordCount = 0 Then 
      ' not found 
      sTitle = "Mailbox not found" 
      sMessage = "Unable to add mailbox for " & sMailBoxName & ". The 
mailbox cannot be found." 
   Else 
      ' multiple entries found 
      sTitle = Rst.RecordCount & " mailbox" 
      If Rst.RecordCount > 1 Then 
         sTitle = sTitle & "es" 
      End If 
      sTitle = sTitle & " found" 
      sMessage = "Unable to add mailbox for " & sMailBoxName & ". There are 
multiple mailboxes that meet the " & _ 
                 "specified criteria " 
      If Rst.RecordCount < 30 Then 
         sMessage = "Unable to add mailbox for " & sMailBoxName & ". There 
are multiple mailboxes that meet the " & _ 
                 "specified criteria as listed below:" & vbCrLf & vbCrLf 
         For iKount = 1 To Rst.RecordCount 
            If iKount < 10 Then 
               sMessage = sMessage & "     " 
            Else 
               sMessage = sMessage & "   " 
            End If 
            sMessage = sMessage & CStr(iKount) & ". " & 
Rst.Fields("displayName") & " - " & Rst.Fields("sAMAccountName") & vbCrLf 
            Rst.MoveNext 
         Next 
      Else 
         sMessage = "Unable to add mailbox for " & sMailBoxName & ". There 
are too many mailboxes that " & _ 
                    "matched the criteria to list." & vbCrLf 
      End If 
      sMessage = sMessage & vbCrLf & "Please re-run this program and enter a 
more specific mailbox name." 
   End If 
   MsgBox sMessage, 0, sTitle 
End If 
' clean up 
Rst.Close 
Set Rst = Nothing 
Set Cmd = Nothing 
Conn.Close 
Set Conn = Nothing 
Sub AddMailBox(strProfile, strDisplayName, strMailboxDN, strServer, 
strServerDN) 
  Set Profiles=CreateObject("ProfMan.Profiles") 
  If strProfile = "" Then 
    Set Profile = Profiles.DefaultProfile 
  Else 
    Set Profile = Profiles.Item(strProfile) 
   End If 
  'find the Exchange service 
  Set Services = Profile.Services 
  For i = 1 To Services.Count 
    Set Service = Services.Item(i) 
    If Service.ServiceName = "MSEMS" Then 
      'Add "EMSDelegate" provider 
      Set Properties = CreateObject("ProfMan.PropertyBag") 
      Properties.Add PR_DISPLAY_NAME, strDisplayName 
      Properties.Add PR_PROFILE_MAILBOX, strMailboxDN 
      Properties.Add PR_PROFILE_SERVER, strServer 
      Properties.Add PR_PROFILE_SERVER_DN, strServerDN 
      Set Provider = Service.Providers.Add("EMSDelegate", Properties) 
      'update the old value of PR_STORE_PROVIDERS so that Outlook 
      'will show the mailbox in the list in Tools | Services 
      Set GlobalProfSect = Profile.GlobalProfSect 
      OldProviders = GlobalProfSect.Item(PR_STORE_PROVIDERS) 
      strUID = Provider.UID 
      GlobalProfSect.Item(PR_STORE_PROVIDERS) = OldProviders & strUID 
    End If 
  Next 
End Sub