VBA Outlook 2010檢索Active Directory中的信息

Question

我在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。 如果這是可能的任何幫助將不勝感激。

Answer 1

後續代碼的工作

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