Organizational Diagram Macro in PowerPoint not Looping Properly

Hello Everyone,

I have been working on a Macro for PowerPoint that would enable me to print an Organizational Chart from a CSV file that is exported from an Excel Business Planning sheet.  For testing purposes, I have attached a sample of the CSV file below.  This macro was designed based upon information in the MSDN forum, available here: http://msdn.microsoft.com/en-us/library/aa140203(office.10).aspx

Basically, the macro is able to retrieve all of the data from the CSV file, place it into a recordset and begin filtering and writing Organizational Chart pieces to the slide, but it is not reiterating through the entire global record set.  Using my debug code, I am seeing that it is checking for existing nodes, but not identifying and properly filtering beyond the second level.  Any help or insight that you can provide would be appreciated.

Also, I have attached a sample of the PPT document that I have been working with.  Feel free to remove the .txt extensions from the CSV file and copy it to the root of your C: drive to replicate my current problem.

Regards,
Neal

Option Explicit
 
'Need to set a reference to the Microsoft ActiveX Data Objects 2.5 Library
Dim grstMain As ADODB.Recordset
 
'New Values needed for DB connection
Public cn As ADODB.Connection
 
'Global enumeration for the node type used in AddNewNode function
Public Enum NodeTypeEnum
    Parent = 1
    Assistant = 2
    Child = 3
 
End Enum
 
 
'To run the following code use one of the test procedures below:
 
Sub CreateOrgChartInPowerPoint()
    Call CreateOrgChart(objDocument:=ActivePresentation.Slides(1), _
        strPath:=ActivePresentation.Path)
End Sub
 
'Sub CreateOrgChartInWord()
'    Call CreateOrgChart(objDocument:=ActiveDocument, _
'       strPath:=ActiveDocument.Path & "\employees.mdb", strTable:="EmpNames")
'End Sub
 
 
Sub CreateOrgChart(ByRef objDocument As Object, ByRef strPath As String)
    
    Dim blnHaveRST As Boolean
    Dim rstReports As ADODB.Recordset
    Dim shpOrgChart As Shape
    Dim dgnFirstNode As DiagramNode
    Dim strActiveConnection As String
    
    Const NAME_FIELD = "Name"
    Const BOSS_FIELD = "SuperiorOrg"
    Const TITLE_FIELD = "Title"
    Const PROPS_FIELD = "EmpOrg"
    Const TITLE_FIRST_NODE = "Corporate Entity"
    
    'Debug using original Data
    'Const NAME_FIELD = "Name"
    'Const BOSS_FIELD = "ReportsTo"
    'Const TITLE_FIELD = "Title"
    'Const PROPS_FIELD = "Properties"
    'Const TITLE_FIRST_NODE = "President"
    
    Const DIAGRAM_POSITION_LEFT = 0
    Const DIAGRAM_POSITION_TOP = 0
    Const DIAGRAM_SIZE_WIDTH = 720
    Const DIAGRAM_SIZE_HEIGHT = 540
    
 
    'Modified Version for Testing
    strActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\;" _
    & "Extended Properties=""text;HDR=Yes;FMT=Delimited"";"
 
    'WORKING VERSION
    'strActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\;" _
    '& "Extended Properties=""text;HDR=Yes;FMT=Delimited"";"
 
    '"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\;"_
      '  &"Extended Properties=""text;HDR=Yes;FMT=Delimited""";"
 
    'Get main recordset
    blnHaveRST = GetData(strActiveConnection:=strActiveConnection, _
        strCursorType:=adOpenStatic)
    
    If blnHaveRST = True Then
        'Create base organizational chart diagram
        Set shpOrgChart = CreateDiagram(objDocument:=objDocument, DiagramType:=msoDiagramOrgChart, _
            intPositionLeft:=DIAGRAM_POSITION_LEFT, intPositionTop:=DIAGRAM_POSITION_TOP, _
            intSizeWidth:=DIAGRAM_SIZE_WIDTH, intSizeHeight:=DIAGRAM_SIZE_HEIGHT)
    
        'Create main parent node
        Set rstReports = GetReports(strField:=BOSS_FIELD, strFilter:=TITLE_FIRST_NODE)
        Set dgnFirstNode = AddNewNode(rstTemp:=rstReports, shpDiagram:=shpOrgChart, _
            strNameField:=NAME_FIELD, strTitleField:=TITLE_FIELD, strPropsField:=PROPS_FIELD, eNodeType:=Parent)
        
        
        'Add nodes for employees
        Set rstReports = GetReports(strField:=BOSS_FIELD, strFilter:=rstReports.Fields(PROPS_FIELD).Value)
 
 
        If rstReports.RecordCount > 0 Then
            AddNodes rstReports:=rstReports, dgnParentNode:=dgnFirstNode, _
                strNameField:=NAME_FIELD, strManagerField:=BOSS_FIELD, _
                strTitleField:=TITLE_FIELD, strPropsField:=PROPS_FIELD
                                
        End If
        
        rstReports.Close
        Set rstReports = Nothing
        
        grstMain.Close
        Set grstMain = Nothing
    
    End If
    
End Sub
 
Function GetData(ByVal strActiveConnection As String, _
            ByVal strCursorType As CursorTypeEnum) As Boolean
    
    Dim rstTemp As New ADODB.Recordset
    Dim strsql As String
    
    'Define SQL query to select data from CSV
    strsql = "SELECT * from OrgBP_Data_Export_Clean2.csv"
    'strsql = "SELECT * from EmpNames.csv"
    
    'Create DB Connection - Revised Method
    Set cn = CreateObject("ADODB.Connection")
    cn.Open strActiveConnection
    
    cn.CursorLocation = adUseServer
    Set rstTemp.ActiveConnection = cn
    rstTemp.CursorType = adOpenStatic
    
    'Open recordset, adding data to SQL query
    rstTemp.Open strsql
    
    'ClonerstTemp to grstMain
    Set grstMain = rstTemp
    
    
    On Error GoTo Error_Handler
    
    
    
    
    'DEBUG: print the record set
'    Debug.Print rstTemp.Fields(rstTemp.Fields.Count - 1).Type
 
        'DEBUG: Print Fields in recordset
                
'        Debug.Print ("Print the Record Set from imported CSV")
'
'        With rstTemp
'          .MoveFirst
'          Do While Not .EOF
'                Debug.Print ("Name: ") + !Name
'                Debug.Print ("Title: ") + !Title
'                Debug.Print ("Employee's Org: ") + !EmpOrg
'                Debug.Print ("Reports To: ") + !SuperiorOrg
'                Debug.Print
'                .MoveNext
'          Loop
'        End With
        
    GetData = True
 
Exit_Sub:
   Exit Function
    
Error_Handler:
    Select Case Err.Number
        Case -2147467259
            MsgBox "You must first save your document."
        Case Else
            MsgBox "An unknown error occurred."
    End Select
 
    GetData = False
    
End Function
 
 
Function GetReports(ByVal strField As String, ByVal strFilter As String) _
        As ADODB.Recordset
 
    Dim rstTemp As New ADODB.Recordset
 
    'Create a clone of the main global recordset
    Set rstTemp = grstMain.Clone
    
'DEBUG: Print Filtered result Dataset
'       Debug.Print ("DEBUG: Data from GetReports Filtering Method")
'DEBUG: Print recordset after clone
'        Debug.Print ("DEBUG: Print recordset after clone")
'        With grstMain
'          .MoveFirst
'          Do While Not .EOF
'                Debug.Print ("Name: ") + !Name
'                Debug.Print ("Title: ") + !Title
'                Debug.Print ("Employee's Org: ") + !EmpOrg
'                Debug.Print ("Reports To: ") + !SuperiorOrg
'                Debug.Print
'                .MoveNext
'          Loop
'        End With
'        Debug.Print ("DEBUG: Print Successful:  Continuing...")
 
   'Set a filter on the recordset and return a new recordset
   rstTemp.Filter = strField & " = '" & strFilter & "'"
 
    Set GetReports = rstTemp
 
'DEBUG: Review GetReports Filtering ability
 
'Debug.Print ("DEBUG: Print global grstMain recordset after filtering")
'With grstMain
'  .MoveFirst
'  Do While Not .EOF
'                Debug.Print ("Name: ") + !Name
'                Debug.Print ("Title: ") + !Title
'                Debug.Print ("Employee's Org: ") + !EmpOrg
'                Debug.Print ("Reports To: ") + !SuperiorOrg
'                Debug.Print
'        .MoveNext
'  Loop
'End With
'Debug.Print ("DEBUG: Print Successful:  Continuing...")
 
 
'Debug.Print ("DEBUG: Print Filtered result Dataset")
'
'With rstTemp
'  .MoveFirst
'  Do While Not .EOF
'                Debug.Print ("Name: ") + !Name
'                Debug.Print ("Title: ") + !Title
'                Debug.Print ("Employee's Org: ") + !EmpOrg
'                Debug.Print ("Reports To: ") + !SuperiorOrg
'                Debug.Print
'        .MoveNext
'  Loop
'End With
'rstTemp.MoveFirst
 
'Debug.Print ("DEBUG: Print Successful:  Continuing...")
 
End Function
 
Function CreateDiagram(ByVal objDocument As Object, _
    ByVal DiagramType As MsoDiagramType, ByVal intPositionLeft As Integer, _
    ByVal intPositionTop As Integer, ByVal intSizeWidth As Integer, _
    intSizeHeight As Integer) As Shape
 
    'You can use this function for Word, PowerPoint, and Excel. Just pass in a
    'Document (Word), Slide (PowerPoint), or Worksheet (Excel) object as objDocument.
 
    Set CreateDiagram = objDocument.Shapes.AddDiagram _
        (Type:=DiagramType, Left:=intPositionLeft, Top:=intPositionTop, _
        Width:=intSizeWidth, Height:=intSizeHeight)
 
End Function
 
Function AddNewNode(ByVal rstTemp As ADODB.Recordset, ByVal strNameField As String, _
        ByVal strTitleField As String, ByVal strPropsField As String, ByVal eNodeType As NodeTypeEnum, _
        Optional ByVal NodeLayout As MsoOrgChartLayoutType, Optional ByVal shpDiagram As Shape, _
        Optional ByVal dgnParentNode As DiagramNode) As DiagramNode
 
    Dim dgnNewNode As DiagramNode
    
    On Error Resume Next
    
    'Create new node
    Select Case eNodeType
        
        Case Parent
            Set dgnNewNode = shpDiagram.DiagramNode.Children.AddNode
 
        Case Assistant
            Set dgnNewNode = dgnParentNode.Children.AddNode(NodeType:=msoDiagramAssistant)
 
        Case Child
            Set dgnNewNode = dgnParentNode.Children.AddNode
            dgnNewNode.Layout = NodeLayout
        
    End Select
 
    'Add name and title to node
    With dgnNewNode.TextShape.TextFrame
 
        .WordWrap = False
        Call AddFormatText(objText:=.TextRange, _
            strName:=rstTemp.Fields(strNameField).Value, _
            strTitle:=rstTemp.Fields(strTitleField).Value, strProps:=rstTemp.Fields(strPropsField))
          
    End With
 
    Set AddNewNode = dgnNewNode
 
End Function
 
Sub AddNodes(ByVal rstReports As ADODB.Recordset, ByRef dgnParentNode As DiagramNode, _
        strNameField As String, strManagerField As String, strTitleField As String, strPropsField As String)
 
    Dim dgnNode As DiagramNode
    Dim rstTemp As ADODB.Recordset
 
    Do While Not rstReports.EOF
        
        'Create assistant node
        If InStr(1, rstReports.Fields(strTitleField).Value, "Assistant") Then
            Set dgnNode = AddNewNode(rstTemp:=rstReports, _
                strNameField:=strNameField, strTitleField:=strTitleField, strPropsField:=strPropsField, _
                eNodeType:=Assistant, dgnParentNode:=dgnParentNode)
 
        'Create all other nodes
        Else
            Set dgnNode = AddNewNode(rstTemp:=rstReports, _
                strNameField:=strNameField, strTitleField:=strTitleField, strPropsField:=strPropsField, _
                dgnParentNode:=dgnParentNode, eNodeType:=Child, _
                NodeLayout:=msoOrgChartLayoutRightHanging)
 
            'Get any direct reports for node added above
            Set rstTemp = GetReports(strManagerField, rstReports.Fields(strNameField).Value)
            If rstTemp.RecordCount > 0 Then
 
                Do While Not rstTemp.EOF
                    
                    'Recurse through the AddNodes routine for direct reports
                    Call AddNodes(rstReports:=rstTemp, dgnParentNode:=dgnNode, _
                        strNameField:=strNameField, strManagerField:=strManagerField, _
                        strTitleField:=strTitleField, strPropsField:=strPropsField)
                Loop
 
                rstTemp.Close
                Set rstTemp = Nothing
 
            End If
    
        End If
 
        rstReports.MoveNext
 
    Loop
 
End Sub
 
Sub AddFormatText(ByRef objText As Object, ByVal strName As String, _
    ByVal strTitle As String, ByVal strProps As String)
 
    With objText
        .Text = strName & vbCrLf & strTitle & vbCrLf & strProps
        .Font.Size = 8
    End With
    
 
End Sub

Select allOpen in new window

OrgBP-Data-Export-Clean2.csv.txt