Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1125
  • Last Modified:

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

Open in new window

OrgBP-Data-Export-Clean2.csv.txt
0
ockins06
Asked:
ockins06
  • 10
  • 5
2 Solutions
 
Chris BottomleyCommented:
Trying to look:

I edited the filename to use hyphems as in teh supplied file, but it errors on rsttemp.open:

    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

Syntax error in from clause:
SELECT * from OrgBP-Data-Export-Clean2.csv

The csv is in the same folder as the ppt.

Chris
0
 
ockins06Author Commented:
Hi Chris,

I don't quite understand what modifying the file's name in the Select statement will change.  I have used several different file names in testing and with and without underscores and hyphens and it seems to have no effect on the file.

I believe the issue is somewhere with the Filter statements, but I have been unable to uncover the error through debugging.
0
 
Chris BottomleyCommented:
I'm happy to work through the VBA with a view to trying to identify the problem, but it will so much easdier to step through as a walk through hasn't suggested a problem ... but I have no experience with ADO in this context so unless we can close out that issue with your file I may be a dead loss!

Chris
0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
Chris BottomleyCommented:
OK, to try and get over the hurdle I removed the hyphens form the filename and file and dropped it into drive c:\ and I can now pass through that error.

Continuing to try and resolve the request I now get a failure on function CreateDiagram :

    Set CreateDiagram = objDocument.Shapes.AddDiagram _
        (Type:=DiagramType, Left:=intPositionLeft, Top:=intPositionTop, _
        Width:=intSizeWidth, Height:=intSizeHeight)

object does not support this action ... should i have something particular in the ppt slide in order for this to initialise?

Chris
0
 
ockins06Author Commented:
Not to my knowledge.  The macro itself creates an organization chart area in the slide and then begins to add elements to it.  I think the issues you're facing are due to having an uncompiled PPT document that contains the macro.  Is there any roundabout way I can forward the exact PPT file I am working with, since PPT files and PPT files within zip files are not allowed to be uploaded on EE?

- Neal
0
 
Chris BottomleyCommented:
On my profile, (click my name) I have an email addy that you can send the file to?

Chris
0
 
Chris BottomleyCommented:
ALternatively I have seen fred.ppt renamed to fred.ppt.txt and then zipped up.

Chris
0
 
Chris BottomleyCommented:
Hmmm.

I am using ppt 2007, where it doesn't work at all.  I have just used a copy of PPT 2003 where it at least displays an orgchart.  I will now try and see what is actually happening in respect of your original inquiry.

Chris
0
 
ockins06Author Commented:
I appreciate your troubleshooting.  I have been developing and using the macro solely in Powerpoint 2003.  I have attached my version as a .txt file.  Please remove the .txt extension to continue troubleshooting.  Included with this version is all of the debug code that I have been using to print to the console.

Regards,
Neal
ORG-chart-v3.3.ppt.txt
0
 
Chris BottomleyCommented:
It may be a limitation of my skills but I can't make your code work.  I will restructure and post if that's acceptable?

Chris
0
 
ockins06Author Commented:
Hi Chris,

Have you tried using PowerPoint 2003?  The code seems to run fine on both my laptop and desktop.  I'm not sure what the issue is.  Are you placing CSV file in the correct directory that the macro points to?
0
 
Chris BottomleyCommented:
It runs fine with 2003, which is where I've been trying to work on it.  I now need to look again at your code to see if I can see where it is going 'wrong'.  I have been trying it for myself and am having problems with thoat method as well but it has given me more of a feeling for your code hence the new plan.

Chris
0
 
ockins06Author Commented:
Chris,

It appears that I have discovered my problem.  It was a logic error in my code, in the AddNewNodes Method.

This line originally read:
            Set rstTemp = GetReports(strManagerField, rstReports.Fields(strNameField).Value)

and it should have read
            Set rstTemp = GetReports(strManagerField, rstReports.Fields(strOrgField).Value)

This is why I was only getting the Main parent node and not any other child nodes in my PowerPoint diagram.  I appreciate your efforts and time consumed while attempting to assist me.
0
 
Chris BottomleyCommented:
AH well, I couldn't get back to it before the morning so i'll be interested to look at it anyway in the morning ... just for the challenge!

Chris
0
 
Chris BottomleyCommented:
I have had repeated issies with recursion.  Basically I have been unable to fix at the PPT level an issue with the data.

As I see it two changes are required:

1. Code to call up the empOrg column D which I presume is what you referred to and secondly to modify the CSV column 3 data to ensure the reports to consulting, (Peter, Patrick and Greg) DO NOT have consulting as their column C entries else it all recurs indefinitely.

Chris
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()
    ActivePresentation.Slides.Add ActivePresentation.Slides.Count + 1, ppLayoutBlank
    Do While ActivePresentation.Slides.Count > 1
        ActivePresentation.Slides.Item(ActivePresentation.Slides.Count).Delete
    Loop
    Do While ActivePresentation.Slides(1).Shapes.Count > 0
        ActivePresentation.Slides(1).Shapes.Item(ActivePresentation.Slides(1).Shapes.Count).Delete
    Loop
    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)
            Set rstTemp = GetReports(strManagerField, rstReports.Fields(strPropsField).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

Open in new window

OrgBP-Data-Export-Clean2.csv.txt
0

Featured Post

Prepare for your VMware VCP6-DCV exam.

Josh Coen and Jason Langer have prepared the latest edition of VCP study guide. Both authors have been working in the IT field for more than a decade, and both hold VMware certifications. This 163-page guide covers all 10 of the exam blueprint sections.

  • 10
  • 5
Tackle projects and never again get stuck behind a technical roadblock.
Join Now