The meat of the code module below came from Microsoft download web page. It worked for word and powerpoint modules. I attempted to alter the VB so that it create org chart into an excel worksheet. It builds the org chart diagram but it does not add text to the org chart boxes. How add text to org chart boxes?
You can see my fumbling in Function AddNewNode. I commented the call to AddFormatText, but I will put back once I see the syntax for adding any text to an org chart box.
You can see my fumbling in Function AddNewNode. I commented the call to AddFormatText, but I will put back once I see the syntax for adding any text to an org chart box.
Code:
Option Explicit
'To run the following code use one of the test procedures below:
'
'Sub CreateOrgChartInPowerPoint()
' Call CreateOrgChart(objDocument:=ActivePresentation.Slides(1), _
' strPath:=ActivePresentation.Path & "\employees.mdb", strTable:="EmpNames")
'End Sub
'
'Sub CreateOrgChartInWord()
' Call CreateOrgChart(objDocument:=ActiveDocument, _
' strPath:=ActiveDocument.Path & "\employees.mdb", strTable:="EmpNames")
'End Sub
'
'
'Need to set a reference to the Microsoft ActiveX Data Objects 2.5 Library
Dim grstMain As ADODB.Recordset
'Global enumeration for the node type used in AddNewNode function
Public Enum NodeTypeEnum
Parent = 1
Assistant = 2
Child = 3
End Enum
'
'You can use this function for Word, PowerPoint, and Excel. Just pass in a
'Document (Word), Slide (PowerPoint), or Worksheet (Excel) object as objDocument.
' strPath:="C:\temp\powerpoint\employees.mdb", strTable:="EmpNames")
Sub CreateOrgChartInExcel()
Call CreateOrgChart(objDocument:=ActiveSheet, _
strPath:=ActiveWorkbook.Path & "\employees.mdb", strTable:="EmpNames")
End Sub
Sub CreateOrgChart(ByRef objDocument As Object, ByRef strPath As String, _
ByRef strTable 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 = "ReportsTo"
Const TITLE_FIELD = "Title"
Const TITLE_FIRST_NODE = "President"
Const DIAGRAM_POSITION_LEFT = 0
Const DIAGRAM_POSITION_TOP = 0
Const DIAGRAM_SIZE_WIDTH = 1720
Const DIAGRAM_SIZE_HEIGHT = 1540
strActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Password="""";User ID=Admin;Data Source=" & strPath & ";"
'Get main recordset
blnHaveRST = GetData(strTable:=strTable, 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:=TITLE_FIELD, strFilter:=TITLE_FIRST_NODE)
Set dgnFirstNode = AddNewNode(rstTemp:=rstReports, shpDiagram:=shpOrgChart, _
strNameField:=NAME_FIELD, strTitleField:=TITLE_FIELD, eNodeType:=Parent)
'Add nodes for employees
Set rstReports = GetReports(strField:=BOSS_FIELD, strFilter:=rstReports.Fields(NAME_FIELD).Value)
If rstReports.RecordCount > 0 Then
AddNodes rstReports:=rstReports, dgnParentNode:=dgnFirstNode, _
strNameField:=NAME_FIELD, strManagerField:=BOSS_FIELD, _
strTitleField:=TITLE_FIELD
End If
rstReports.Close
Set rstReports = Nothing
grstMain.Close
Set grstMain = Nothing
End If
End Sub
Function GetData(ByVal strTable As String, ByVal strActiveConnection As String, _
ByVal strCursorType As CursorTypeEnum) As Boolean
Dim rstTemp As New ADODB.Recordset
On Error GoTo Error_Handler
rstTemp.Open Source:=strTable, _
ActiveConnection:=strActiveConnection, _
CursorType:=strCursorType
Set grstMain = rstTemp
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
'Set a filter on the recordset and return a new recordset
rstTemp.Filter = strField & " = '" & strFilter & "'"
Set GetReports = rstTemp
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 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
' Case Other
' Set dgnNewNode = shpDiagram.DiagramNode.Children.AddNode
End Select
'Add name and title to node
With dgnNewNode.TextShape.TextFrame
.WordWrap = False
[COLOR=red] MsgBox ("Phil was here")
' Call AddFormatText(objText:=.TextRange, _
' strName:=rstTemp.Fields(strNameField).Value, _
' strTitle:=rstTemp.Fields(strTitleField).Value)
' AddFormatText objText:=.Characters, _
' strName:=rstTemp.Fields(strNameField).Value, _
' strTitle:=rstTemp.Fields(strTitleField).Value
'dgnNewNode.TextShape.TextFrame.Characters.Text = rstTemp.Fields(strNameField).Value & vbCrLf & rstTemp.Fields(strTitleField).Value
dgnNewNode.TextShape.TextFrame.Characters.Text = "Phil was here"
dgnNewNode.TextShape.TextFrame.Characters.Caption = "Phil was here"
[/color]
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)
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, _
eNodeType:=Assistant, dgnParentNode:=dgnParentNode)
'Create all other nodes
Else
Set dgnNode = AddNewNode(rstTemp:=rstReports, _
strNameField:=strNameField, strTitleField:=strTitleField, _
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)
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)
MsgBox ("AddFormatText")
With objText
.Text = strName & vbCrLf & strTitle
.Value = strName & vbCrLf & strTitle
.Font.Size = 8
End With
End Sub