So this sniblet is a little something I wrote a few years back that I still use today. In our environment, we have a Public folder that is available to users on the exchange server. Within the Public folder drilling down is a list of Contact cards that are maintained by our secretary. This code will pull that information and apply faces from the HTTPS source matching the employee’s information. In the end, you basically get a nice clean list with employee images attached to see who you are communicating with.
As a head’s up you may also need VSTO for the import: https://visualstudio.microsoft.com/vs/features/office-tools/
Or if you already have visual studio installed use nuGet.
https://www.nuget.org/packages/Microsoft.Office.Interop.Outlook/
NuGet PM> Install-Package Microsoft.Office.Interop.Outlook -Version 15.0.4797.1003
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 |
Imports Microsoft.Office.Interop.Outlook Imports System.Runtime.InteropServices Public Class Form1 Private Sub LoadContacts() Dim Myresult = MessageBox.Show("Before Running this Program Please clear your local copy of STAFF contacts then press OK", "Are you Ready?", MessageBoxButtons.OKCancel) If Not Myresult = vbOK Then End Dim oApp = New Microsoft.Office.Interop.Outlook.Application() Dim oNS As Microsoft.Office.Interop.Outlook.NameSpace = oApp.GetNamespace("mapi") oNS.Logon(Nothing, Nothing, False, True) Dim PrivateFolder As Microsoft.Office.Interop.Outlook.MAPIFolder = oNS.GetDefaultFolder(OlDefaultFolders.olFolderContacts) Dim PublicContacts As Microsoft.Office.Interop.Outlook.MAPIFolder = oNS.GetDefaultFolder(OlDefaultFolders.olPublicFoldersAllPublicFolders).Folders("Staffing").Folders("staff") Dim Contacts As Microsoft.Office.Interop.Outlook.MAPIFolder Try Contacts = PrivateFolder.Folders("staffWpics") Catch ex As COMException 'it does not exist Contacts = PublicContacts.CopyTo(PrivateFolder) Contacts.Name = "isstaffWpics" Debug.WriteLine(Contacts.ShowAsOutlookAB) Contacts.ShowAsOutlookAB = True End Try Dim MyWebRequest As New System.Net.WebClient MyWebRequest.Credentials = System.Net.CredentialCache.DefaultCredentials System.IO.Directory.CreateDirectory("C:\Pics") Dim DidIFindPicture As Boolean = False For Each MyContact As Microsoft.Office.Interop.Outlook.ContactItem In Contacts.Items DidIFindPicture = False Dim EID As String Dim Email As String Try MyWebRequest.DownloadFile("https://Faces.Local/EmployeeFace.aspx?FULLNAME=" & MyContact.LastName & ",%20" & MyContact.FirstName, "C:\Pics\" & MyContact.LastName & ",%20" & MyContact.FirstName & ".jpg") DidIFindPicture = True Catch ex As System.Exception Try EID = MyContact.Email1Address.Substring(MyContact.Email1Address.LastIndexOf("=") + 1).PadLeft(5, "0") MyWebRequest.DownloadFile("https://Faces.Local/EmployeeFace.aspx?EID=" & EID, "C:\Pics\" & MyContact.LastName & ",%20" & MyContact.FirstName & ".jpg") DidIFindPicture = True Catch exa As System.Exception Try Dim UnCleanedEmail As String = MyContact.Email1DisplayName.Substring(MyContact.Email1DisplayName.LastIndexOf("(") + 1) Email = UnCleanedEmail.Substring(0, UnCleanedEmail.Length - 1) MyWebRequest.DownloadFile("https://Faces.Local/EmployeeFace.aspx?EID=" & Email, "C:\Pics\" & MyContact.LastName & ",%20" & MyContact.FirstName & ".jpg") DidIFindPicture = True Catch exaa As System.Exception Debug.WriteLine("No Picture Found for: " & MyContact.FirstName & " " & MyContact.LastName & " | " & EID & " - " & Email) For Each MyProp As ItemProperty In MyContact.ItemProperties Debug.WriteLine(MyProp.Name & " - " & MyProp.Value.ToString) Next End Try End Try End Try If DidIFindPicture Then MyContact.AddPicture("C:\Pics\" & MyContact.LastName & ",%20" & MyContact.FirstName & ".jpg") MyContact.Save() End If For Each Attachment As Microsoft.Office.Interop.Outlook.Attachment In MyContact.Attachments Debug.WriteLine(Attachment.DisplayName) If Attachment.DisplayName = "ContactPicture.jpg" Then 'MyContact.AddPicture("c:\120604_0000.jpg") 'MyContact.Save() End If Next Next MsgBox("All Pictures Imported as isstaffWpics") End For Each MyContact As Microsoft.Office.Interop.Outlook.ContactItem In PublicContacts.Items 'Contacts.Items.Add( Next End For Each MyFolder As Microsoft.Office.Interop.Outlook.MAPIFolder In PrivateFolder.Folders Debug.WriteLine(MyFolder.Name) Next End For Each MYContact As Microsoft.Office.Interop.Outlook.ContactItem In PublicContacts.Items Debug.WriteLine(MYContact.FirstName) Next End End Sub Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load LoadContacts() End Sub Private Sub Fail() Dim oApp = New Microsoft.Office.Interop.Outlook.Application() Dim oNS As Microsoft.Office.Interop.Outlook.NameSpace = oApp.GetNamespace("mapi") oNS.Logon(Nothing, Nothing, False, True) Dim oDLs As Microsoft.Office.Interop.Outlook.AddressLists Dim oGal As Microsoft.Office.Interop.Outlook.AddressList For Each MyFolder As MAPIFolder In oNS.Folders Debug.WriteLine(MyFolder.Name) If MyFolder.Name.StartsWith("Public Folders - ") Then For Each MySubFolder As MAPIFolder In MyFolder.Folders If MySubFolder.Name = "All Public Folders" Then Debug.WriteLine(MySubFolder.Name) For Each MySubFolder2 As MAPIFolder In MySubFolder.Folders Debug.WriteLine(MySubFolder2.Name) If MySubFolder2.Name = "Information Systems" Then For Each MySubFolder3 As MAPIFolder In MySubFolder2.Folders If MySubFolder3.Name = "isstaff" Then Dim outlookname As Microsoft.Office.Interop.Outlook.NameSpace outlookname = MySubFolder3.Items(0) Debug.WriteLine(outlookname.AddressLists(0).Name) oGal = MySubFolder3.Items.Item(0) Exit Sub End If Next End If Next End If Next End If Next Exit Sub For Each AL As Microsoft.Office.Interop.Outlook.AddressList In oDLs Debug.WriteLine(AL.Name) Next 'Dim oGal As Microsoft.Office.Interop.Outlook.AddressList = oDLs("Global Address List") 'Dim oGal As Microsoft.Office.Interop.Outlook.AddressList = oDLs("Contacts") 'Dim oGal As Microsoft.Office.Interop.Outlook.AddressList = oDLs("Suggested Contacts") 'Dim oGal As Microsoft.Office.Interop.Outlook.AddressList = oDLs("staff") 'Right click and show this folder as item in outlook 'Dim oGal As Microsoft.Office.Interop.Outlook.AddressList = oDLs("Public Folders") Dim oEntries As Microsoft.Office.Interop.Outlook.AddressEntries = oGal.AddressEntries For Each ADDREntry As Microsoft.Office.Interop.Outlook.AddressEntry In oEntries Debug.WriteLine(ADDREntry.Name) Dim MyEx = ADDREntry.GetContact Debug.WriteLine(MyEx.HasPicture) For Each Attachment As Microsoft.Office.Interop.Outlook.Attachment In MyEx.Attachments Debug.WriteLine(Attachment.DisplayName) If Attachment.DisplayName = "ContactPicture.jpg" Or ADDREntry.Name = "Hall, Nicholas (NickHall@Domain.Com)" Then 'Attachment.SaveAsFile("C:\Temp.jpg") PictureBox1.Image = Image.FromFile("C:\Temp.jpg") MyEx.RemovePicture() 'MyEx.AddPicture("c:\120604_0000.jpg") MyEx.Save() End If Next If MyEx.Attachments.Count = 0 Then 'MyEx.AddPicture("c:\120604_0000.jpg") 'MyEx.Save() End If Next End Sub Private Sub GoodCode() Dim oApp = New Microsoft.Office.Interop.Outlook.Application() Dim oNS As Microsoft.Office.Interop.Outlook.NameSpace = oApp.GetNamespace("mapi") oNS.Logon(Nothing, Nothing, False, True) Dim oDLs As Microsoft.Office.Interop.Outlook.AddressLists = oNS.AddressLists For Each AL As Microsoft.Office.Interop.Outlook.AddressList In oDLs Debug.WriteLine(AL.Name) Next 'Dim oGal As Microsoft.Office.Interop.Outlook.AddressList = oDLs("Global Address List") 'Dim oGal As Microsoft.Office.Interop.Outlook.AddressList = oDLs("Contacts") 'Dim oGal As Microsoft.Office.Interop.Outlook.AddressList = oDLs("Suggested Contacts") 'Dim oGal As Microsoft.Office.Interop.Outlook.AddressList = oDLs("isstaff") 'Right click and show this folder as item in outlook 'Dim oGal As Microsoft.Office.Interop.Outlook.AddressList = oDLs("Public Folders") Dim oGal As Microsoft.Office.Interop.Outlook.AddressList = oDLs("Public Folders\All Public Folders\Staffing") Dim oEntries As Microsoft.Office.Interop.Outlook.AddressEntries = oGal.AddressEntries For Each ADDREntry As Microsoft.Office.Interop.Outlook.AddressEntry In oEntries Debug.WriteLine(ADDREntry.Name) Dim MyEx = ADDREntry.GetContact Debug.WriteLine(MyEx.HasPicture) For Each Attachment As Microsoft.Office.Interop.Outlook.Attachment In MyEx.Attachments Debug.WriteLine(Attachment.DisplayName) If Attachment.DisplayName = "ContactPicture.jpg" Or ADDREntry.Name = "Hall, Nicholas (NickHall@Domain.Com)" Then 'Attachment.SaveAsFile("C:\Temp.jpg") PictureBox1.Image = Image.FromFile("C:\Temp.jpg") MyEx.RemovePicture() 'MyEx.AddPicture("c:\120604_0000.jpg") MyEx.Save() End If Next If MyEx.Attachments.Count = 0 Then 'MyEx.AddPicture("c:\120604_0000.jpg") 'MyEx.Save() End If Next Exit Sub Dim sDL As String = "Information Systems Desktop Support" Dim oDL As Microsoft.Office.Interop.Outlook.AddressEntry = oEntries(sDL) Dim oEntry As Microsoft.Office.Interop.Outlook.AddressEntry Dim I As Integer For I = 1 To oEntries.Count - 1 oEntry = oEntries(I) Debug.WriteLine(oEntry.Address) Dim MyEx = oEntry.GetExchangeUser MyEx.GetPicture() Next End Sub Private Sub WORKS() Dim oApp = New Microsoft.Office.Interop.Outlook.Application() Dim oNS As Microsoft.Office.Interop.Outlook.NameSpace = oApp.GetNamespace("mapi") oNS.Logon(Nothing, Nothing, False, True) Dim oDLs As Microsoft.Office.Interop.Outlook.AddressLists = oNS.AddressLists For Each AL As Microsoft.Office.Interop.Outlook.AddressList In oDLs Debug.WriteLine(AL.Name) Next 'Dim oGal As Microsoft.Office.Interop.Outlook.AddressList = oDLs("Global Address List") 'Dim oGal As Microsoft.Office.Interop.Outlook.AddressList = oDLs("Contacts") 'Dim oGal As Microsoft.Office.Interop.Outlook.AddressList = oDLs("Suggested Contacts") Dim oGal As Microsoft.Office.Interop.Outlook.AddressList = oDLs("staff") 'Right click and show this folder as item in outlook Dim oEntries As Microsoft.Office.Interop.Outlook.AddressEntries = oGal.AddressEntries For Each ADDREntry As Microsoft.Office.Interop.Outlook.AddressEntry In oEntries Debug.WriteLine(ADDREntry.Name) Dim MyEx = ADDREntry.GetContact Debug.WriteLine(MyEx.HasPicture) For Each Attachment As Microsoft.Office.Interop.Outlook.Attachment In MyEx.Attachments Debug.WriteLine(Attachment.DisplayName) If Attachment.DisplayName = "ContactPicture.jpg" Then Attachment.SaveAsFile("C:\Temp.jpg") PictureBox1.Image = Image.FromFile("C:\Temp.jpg") MyEx.AddPicture("c:\120604_0000.jpg") End If Next Next End Sub Private Sub Junk() Dim MyContacts As ContactItem Dim MyEntry As Microsoft.Office.Interop.Outlook.AddressEntries Dim MyMembers As System.Reflection.MemberInfo() = MyContacts.GetType().FindMembers(Reflection.MemberTypes.All, Reflection.BindingFlags.Instance, Nothing, Nothing) For Each MyMem As System.Reflection.MemberInfo In MyMembers Debug.WriteLine(MyMem.Name) Next End Sub End Class |