Public Sub CreateOrgChart()
On Error GoTo CreateOrgChart_Err
Const ORGANIZATION_CHART_WIZARD As String = "OrgCWiz"
Dim vsoApp As Visio.Application
Dim vsoAddOn As Visio.Addon
Dim strCommand As String
Dim strCommandPart As String
Dim strQuery As String
strQuery = "qryOrgChart"
' Create an instance of Visio.
Set vsoApp = New Visio.Application
' Get a reference to the Organization Chart Wizard add-on.
Set vsoAddOn = vsoApp.Addons.Item(ORGANIZATION_CHART_WIZARD)
' Initialize the wizard and prepare it to accept a
' series of arguments.
strCommand = "/S-INIT"
vsoAddOn.Run strCommand
strCommand = "/S-ARGSTR "
' Specify that the org chart information will be from Microsoft Access.
strCommandPart = "/DATASOURCE=VisioConnectFile.dsn,TABLE=" & strQuery & "," & ShowCurrentFolder & ""
vsoAddOn.Run strCommand & strCommandPart
strCommandPart = "/UNIQUEID-FIELD=" _
& StringToFormulaForString("Name")
vsoAddOn.Run strCommand & strCommandPart
strCommandPart = "/NAME-FIELD=" _
& StringToFormulaForString("Name")
vsoAddOn.Run strCommand & strCommandPart
strCommandPart = "/MANAGER-FIELD=" _
& StringToFormulaForString("Table")
vsoAddOn.Run strCommand & strCommandPart
strCommandPart = "/DISPLAY-FIELDS=Name, Table"
vsoAddOn.Run strCommand & strCommandPart
strCommandPart = "/CUSTOM-PROPERTY-FIELDS=Name, Table"
vsoAddOn.Run strCommand & strCommandPart
'This tells visio to put the chart on one page
strCommandPart = "/PAGES=Table"
strCommand = strCommand & strCommandPart
strCommand = strCommand & "/PAGENAME=TablePlan"
vsoAddOn.Run strCommand
' Begin creating the org chart.
strCommand = "/S-RUN "
vsoAddOn.Run strCommand
Exit Sub
CreateOrgChart_Err:
MsgBox err.Description
End Sub
----------------------------------------------------------------------
Public Function StringToFormulaForString(strIn As String) As String
' StringToFormulaForString
'
' Abstract - Convert the input string to a Visio string by
' replacing each 'double quote'(") with a 'double double
' quote'("") and adding a ("") around the entire string.
'
' Parameters strIn
' Input string that will to be converted to Visio String
'
' Return Value Returns the converted Visio string
Dim strResult As String
Dim intCtr As Integer
On Error GoTo StringToFormulaForString_Err
strResult = strIn
'The original code that comes from Microsoft is based on VB
'and uses the replace function. in Access 97 you don't have that luxury
'and have to use the mid statement. When looping through a string to
'to find a character and then replace it with itself twice it gets messy
'thats why I convert it to (^) first and then (")
'Changes all " to ^^
For intCtr = 1 To Len(strResult)
If Mid(strResult, intCtr, 1) = Chr(34) Then
Mid(strResult, intCtr, 2) = Chr(94) & Chr(94)
End If
Next
'Changes all ^ to "
For intCtr = 1 To Len(strResult)
If Mid(strResult, intCtr, 1) = Chr(94) Then
Mid(strResult, intCtr, 2) = Chr(34)
End If
Next
' Add ("") around the whole string.
strResult = Chr(34) & strResult & Chr(34)
StringToFormulaForString = strResult
Exit Function
StringToFormulaForString_Err:
MsgBox err.Description
End Function
----------------------------------------------------------------------
Public Function ShowCurrentFolder()
'Returns the true path and name of current database
ShowCurrentFolder = left(CurrentDb.name, InStr(CurrentDb.name, Dir(CurrentDb.name)) - 1) _
& Mid(CurrentDb.name, InStr(CurrentDb.name, Dir(CurrentDb.name)), _
& (Len(CurrentDb.name) - InStr(CurrentDb.name, Dir(CurrentDb.name)) + 1))
End Function