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.

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

Leave a Reply

Your email address will not be published. Required fields are marked *

To create code blocks or other preformatted text, indent by four spaces:

    This will be displayed in a monospaced font. The first four 
    spaces will be stripped off, but all other whitespace
    will be preserved.
    
    Markdown is turned off in code blocks:
     [This is not a link](http://example.com)

To create not a block, but an inline code span, use backticks:

Here is some inline `code`.

For more help see http://daringfireball.net/projects/markdown/syntax