VBA Outlook 2010从Active Directory检索信息(VBA Outlook 2010 retrieving information from Active Directory)

VBA Outlook 2010从Active Directory检索信息(VBA Outlook 2010 retrieving information from Active Directory)

我在Outlook 2010中使用VBA，我正在尝试创建一个函数，该函数将从Active Directory检索选定的用户主文件夹路径。

以下代码是一个具有保存目标的简单弹出窗口。

Sub SaveSelected() 'Declaration Dim myItems, myItem, myAttachments, myAttachment Dim myOrt As String Dim myOLApp As New Outlook.Application Dim myOlExp As Outlook.Explorer Dim myOlSel As Outlook.Selection Dim objFSO As Object Dim intCount As Integer 'Ask for destination folder myOrt = InputBox("Destination", "Save Attachments", "\\server\home\VARIABLE\") End Sub

我希望VARIABLE来自AD，具体取决于当前选择的电子邮件。 例如，我收到了来自Jimmy@home.com的电子邮件，然后我从jimmy@home.com选择了电子邮件，我希望能够检索

\服务器\ home目录\吉米

并使用“jimmy”作为我的VARIABLE。 如果这是可能的，任何帮助将不胜感激。

I’m using VBA in Outlook 2010 and I’m trying to create a function that will retrieve a selected user Home folder path from Active Directory.

The following code is a simple pop up that has the saving destination.

Sub SaveSelected() 'Declaration Dim myItems, myItem, myAttachments, myAttachment Dim myOrt As String Dim myOLApp As New Outlook.Application Dim myOlExp As Outlook.Explorer Dim myOlSel As Outlook.Selection Dim objFSO As Object Dim intCount As Integer 'Ask for destination folder myOrt = InputBox("Destination", "Save Attachments", "\\server\home\VARIABLE\") End Sub

I want the VARIABLE to come from AD depending on the currently selected email. for example I received an email from Jimmy@home.com and then I select the email from jimmy@home.com, I want to be able to retrieve

\server\homedirectory\jimmy

and use "jimmy" as my VARIABLE. If this is possible any help would be greatly appreciated.

最满意答案

遵循代码是有效的

Sub GetSelectedItems()  Dim myOlExp As Outlook.Explorer  Dim myOlSel As Outlook.Selection  Dim mySender As Outlook.AddressEntry  Dim oMail As Outlook.MailItem  Dim oAppt As Outlook.AppointmentItem  Dim oPA As Outlook.propertyAccessor  Dim strSenderID As String  Dim myOrt As String  Dim user As String  Const PR_SENT_REPRESENTING_ENTRYID As String ="http://schemas.microsoft.com/mapi/proptag/0x00410102"  Set myOlExp = Application.ActiveExplorer  Set myOlSel = myOlExp.Selection  For x = 1 To myOlSel.Count  If myOlSel.item(x).Class = OlObjectClass.olMail Then  ' For mail item, use the SenderName property.  Set oMail = myOlSel.item(x)  ElseIf myOlSel.item(x).Class = OlObjectClass.olAppointment Then  ' For appointment item, use the Organizer property.  Set oAppt = myOlSel.item(x)  Else  Set oPA = myOlSel.item(x).propertyAccessor  strSenderID = oPA.GetProperty(PR_SENT_REPRESENTING_ENTRYID)  Set mySender = Application.Session.GetAddressEntryFromID(strSenderID)  End If  Next x Set objConnection = CreateObject("ADODB.Connection") Set objCommand = CreateObject("ADODB.Command") objConnection.Open "Provider=ADsDSOObject;" objCommand.ActiveConnection = objConnection strDomainName = "ou=company,dc=mydc,dc=com" strUserCN = oMail.SenderName & "" objCommand.CommandText = "<LDAP://" & strDomainName & ">;(& (objectCategory=person)(objectClass=user)(cn=" & strUserCN & "));samAccountName;subtree" Set objRecordSet = objCommand.Execute If Not objRecordSet.EOF Then user = objRecordSet.Fields("samAccountName") myOrt = InputBox("Destination", "Save Attachments", "\\server\home\" &user & "") End If objConnection.Close Set objRecordSet = Nothing Set objConnection = Nothing Set objCommand = Nothing 'free variables Set myItems = Nothing Set myItem = Nothing Set myAttachments = Nothing Set myAttachment = Nothing Set myOLApp = Nothing Set myOlExp = Nothing Set myOlSel = Nothing Set user = Nothing End Sub

THe follow code works

 

Sub GetSelectedItems()  Dim myOlExp As Outlook.Explorer  Dim myOlSel As Outlook.Selection  Dim mySender As Outlook.AddressEntry  Dim oMail As Outlook.MailItem  Dim oAppt As Outlook.AppointmentItem  Dim oPA As Outlook.propertyAccessor  Dim strSenderID As String  Dim myOrt As String  Dim user As String  Const PR_SENT_REPRESENTING_ENTRYID As String ="http://schemas.microsoft.com/mapi/proptag/0x00410102"  Set myOlExp = Application.ActiveExplorer  Set myOlSel = myOlExp.Selection  For x = 1 To myOlSel.Count  If myOlSel.item(x).Class = OlObjectClass.olMail Then  ' For mail item, use the SenderName property.  Set oMail = myOlSel.item(x)  ElseIf myOlSel.item(x).Class = OlObjectClass.olAppointment Then  ' For appointment item, use the Organizer property.  Set oAppt = myOlSel.item(x)  Else  Set oPA = myOlSel.item(x).propertyAccessor  strSenderID = oPA.GetProperty(PR_SENT_REPRESENTING_ENTRYID)  Set mySender = Application.Session.GetAddressEntryFromID(strSenderID)  End If  Next x Set objConnection = CreateObject("ADODB.Connection") Set objCommand = CreateObject("ADODB.Command") objConnection.Open "Provider=ADsDSOObject;" objCommand.ActiveConnection = objConnection strDomainName = "ou=company,dc=mydc,dc=com" strUserCN = oMail.SenderName & "" objCommand.CommandText = "<LDAP://" & strDomainName & ">;(& (objectCategory=person)(objectClass=user)(cn=" & strUserCN & "));samAccountName;subtree" Set objRecordSet = objCommand.Execute If Not objRecordSet.EOF Then user = objRecordSet.Fields("samAccountName") myOrt = InputBox("Destination", "Save Attachments", "\\server\home\" &user & "") End If objConnection.Close Set objRecordSet = Nothing Set objConnection = Nothing Set objCommand = Nothing 'free variables Set myItems = Nothing Set myItem = Nothing Set myAttachments = Nothing Set myAttachment = Nothing Set myOLApp = Nothing Set myOlExp = Nothing Set myOlSel = Nothing Set user = Nothing End Sub