VBA Script for Visio 2013 to Retrieve User Contact Information from SharePoint 2013 MySites

Created a VBA code script (included below) to run in Visio and look for objects that have a custom property named "UserRef", taking the corresponding value entered into that custom property (assumed to be a Windows AD user account id) to lookup the users contact information (Name, Title, Department, Email, Phone, Office Location) from the users SharePoint "MySite".  Also, adds a hyperlink to the object that points to the users SharePoint MySite.  In my case I was using Visio 2013 and SharePoint 2013.

Sub PopulateUserInfoObjects()

    Dim page As Integer, pages As Integer, shape As Integer, shapes As Integer
    page = 1
    pages = Application.ActiveDocument.pages.Count
    
    While page <= pages
        Application.ActiveWindow.page = Application.ActiveDocument.pages(page)
        page = page + 1
        shape = 1
        shapes = Application.ActiveWindow.page.shapes.Count
        Debug.Print Application.ActiveWindow.page.name & " has " & shapes & " shapes"
        While shape <= shapes
            Dim visioShape As Visio.shape
            Set visioShape = Application.ActiveWindow.page.shapes(shape)
            Dim userRef As String
            userRef = GetCustomPropertyValue(visioShape, "UserRef")
            If userRef <> "" Then
                Dim chars As Visio.Characters
                Set chars = visioShape.Characters
                chars.Text = GetUserInfoFromIntranet(userRef, visioShape)
            End If
            shape = shape + 1
        Wend
    Wend

End Sub

Function GetUserInfoFromIntranet(userId As String, addHyperlink As Visio.shape)
    
    ' Required references:
    '   Microsoft Internet Controls
    '   Microsoft Shell Controls and Automation
    
    ' The InternetExplorerMedium object is required instead of InternetExplorer object 
    ' to avoid the following exception:
    '   Run-time error '-21474178848 (80010108)':
    '   Automation Error
    '   The object invoked has disconnected form its clients.
    
    Dim IE As InternetExplorerMedium
    Dim targetURL As String
    Dim webContent As String
    Dim sh
    Dim eachIE
    
    targetURL = "http://SHAREPOINT_MYSITES_URL_HERE/Person.aspx?accountname=DOMAIN_NAME_HERE%5C" & userId
    Set IE = New InternetExplorerMedium
    IE.Visible = False
    IE.Navigate targetURL
    
    While IE.Busy
      DoEvents
    Wend
    
    Do
      Set sh = New Shell32.Shell
      For Each eachIE In sh.Windows
        If InStr(1, eachIE.LocationURL, targetURL) Then
          Set IE = eachIE
            'In some environments, the new process defaults to Visible.
            IE.Visible = False  
          Exit Do
          End If
        Next eachIE
      Loop
    Set eachIE = Nothing
    Set sh = Nothing
    
    While IE.Busy  ' The new process may still be busy even after you find it
      DoEvents
    Wend
      
    Dim name As String
    name = IE.Document.getElementById("ctl00_PictureUrlImage_NameOverlay").innerHTML
    Dim title As String
    title = IE.Document.getElementById("ProfileViewer_ValueTitle").innerHTML
    Dim dept As String
    dept = IE.Document.getElementById("ProfileViewer_ValueDepartment").innerHTML
    Dim email As String
    email = IE.Document.getElementById("ProfileViewer_ValueWorkEmail").innerHTML
    Dim phone As String
    phone = IE.Document.getElementById("ProfileViewer_ValueWorkPhone").innerHTML
    Dim office As String
    office = IE.Document.getElementById("ProfileViewer_ValueOffice").innerHTML

    On Error Resume Next
    DeleteHyperlinks addHyperlink
    AddHyperlinkToShape addHyperlink, targetURL
 
    name = name & Chr(10) & title & Chr(10) & phone & Chr(10) & email 
    name = name & Chr(10) & dept & Chr(10) & "Location: " & office
    GetUserInfoFromIntranet = name 

End Function

Function GetCustomPropertyValue(TheShape As Visio.shape, ThePropertyName As String) As String
    Dim value As String
    If TheShape.CellExistsU("Prop." & ThePropertyName, 0) Then
        GetCustomPropertyValue = TheShape.CellsU("Prop." & ThePropertyName).ResultStr(visNone)
    Else
        GetCustomPropertyValue = ""
    End If
End Function

Sub AddHyperlinkToShape(shape As Visio.shape, url As String)
    Dim link As Visio.Hyperlink
    Set link = shape.Hyperlinks.Add
    link.IsDefaultLink = False
    link.Description = ""
    link.Address = url
    link.SubAddress = ""
End Sub

Sub DeleteHyperlinks(shape As Visio.shape)
    Dim i As Integer
    i = 1
    While i < shape.Hyperlinks.Count
        shape.Hyperlinks.ItemU(i).Delete
    Wend
End Sub