Option Explicit

'Author: http://geographika.co.uk
'Written: 25/09/2009
'Blog post: http://geographika.co.uk/?p=78

'Requires a reference to "Microsoft Visio Database Modeling Engine Type Library"
'(by default this is in C:\Program Files\Microsoft Office\Office12\MODELENG.DLL)

Public Sub FindShapesForEntities()

    Static vme As New VisioModelingEngine
    
    'get references to the data models
    
    Dim models As IEnumIVMEModels
    Dim model As IVMEModel
    
    Set models = vme.models
    Set model = models.Next
    
    'get references to the visio data modelling elements
    
    Dim elements As IEnumIVMEModelElements
    Dim element As IVMEModelElement
    Dim objEntity As IVMEEntity
    
    Set elements = model.elements
    Set element = elements.Next
    
    'loop through each of the elements in the datamodel
    
    Do While Not element Is Nothing
        If element.Type = eVMEKindEREntity Then 'only look at entities not relationships
            Set objEntity = element
            
            Dim objAttribs As IEnumIVMEAttributes
            Dim objAttr As IVMEAttribute
            Set objAttribs = objEntity.Attributes
            Set objAttr = objAttribs.Next
            
            'loop through each of the attributes in the entity
            
            Do While Not objAttr Is Nothing
                If objAttr.ColumnNumber = 0 Then
                    'get the original field name of the first field
                    Dim sEntityName As String
                    Dim sOrigFieldName As String
                    sEntityName = objEntity.PhysicalName
                    sOrigFieldName = objAttr.PhysicalName
                    'set the first attribute name to be the entity name
                    objAttr.PhysicalName = sEntityName
                    
                    'refresh the database shape (Database Refresh Shape)  or the temporary field name is not visible
                    'however this also changes the active entity..
                    Visio.Application.Addons("dbrs").Run ""

                    Dim intShapeId As Integer
                    'get the id of the associated shape, based on entity name
                    intShapeId = FindShapeIdByEntityName(sEntityName)
                    'set the field back to the original name
                    objAttr.PhysicalName = sOrigFieldName
                    
                    If intShapeId > -1 Then
                        'an associated shape was found - print out the details
                        Debug.Print intShapeId
                        Debug.Print objEntity.PhysicalName
                        'or use them for another function
                        CreateHyperlink intShapeId, objEntity.PhysicalName
                    End If
                End If
                Set objAttr = objAttribs.Next
            Loop
        End If
        Set element = elements.Next
    Loop

End Sub

'Find a shape based on an entity name
Private Function FindShapeIdByEntityName(sEntityName As String) As Integer

    Dim pag As Page
    Dim shp As Shape
    Dim myArray
    Dim mySecondArray
    Dim sShapeEntityName As String
    
    FindShapeIdByEntityName = -1 'not found on page
    Set pag = Application.ActivePage
    
    For Each shp In pag.Shapes
        If shp.Style = "Normal" Then 'ignore connector shaoes
            myArray = Split(shp.Text, vbTab) 'get the text associated with the shape
            sShapeEntityName = myArray(1) 'the second word in the text is the temporary field name
            mySecondArray = Split(sShapeEntityName, Chr(10)) 'split again incase their is a linebreak and FK
            sShapeEntityName = mySecondArray(0)
            sShapeEntityName = Trim(Replace(sShapeEntityName, Chr(10), "")) 'remove line breaks and spaces
            If sShapeEntityName = sEntityName Then
                'the entity name was found in the shape text, so return the shape ID
                FindShapeIdByEntityName = shp.ID
                Exit Function
            End If
        End If
    Next shp

End Function

' a sub to create a hyperlink property with the entity name
Private Sub CreateHyperlink(shpId As Integer, sEntityName As String)

    Dim pag As Page
    Dim shp As Shape
    
    'get the active page
    Set pag = Application.ActivePage
    'get shape based on the shape's id
    Set shp = pag.Shapes.ItemFromID(shpId)
    
    Dim vsoHlink1 As Visio.Hyperlink
    If shp.Hyperlinks.Count > 0 Then 'no way to delete hyperlinks, so reuse first
        Set vsoHlink1 = shp.Hyperlinks.Item(0)
    Else
        'create a new hyperlink
        Set vsoHlink1 = shp.Hyperlinks.Add
    End If
    
    'set the hyperlink properties
    
    vsoHlink1.Name = shp.ID & "_link"
    vsoHlink1.Address = sEntityName

End Sub