|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
本帖最后由 hxhgxy 于 2012-2-7 15:54 编辑
老版本的Office里面有组织架构图插件，做出来的组织架构图极其丑陋。Office 2007和2010中，SmartArt里面有几种组织架构图设计图案（Layout），我最喜欢带照片的那种。
但是通过手动插入SmartArt中的组织架构图来制作的话，还是很费事的，除非你使用内置的样式！我们也可以通过手动，将某个图形（VBA中SmartArt的对象模型为SmartArtNode）进行自定义样式，比如拖动位置，更改大小，更改字体和图形的格式等等。但是，我们这样做的话，会累得半死！
本文介绍本人开发的组织架构图工具，来创建自定义样式的组织架构图。图1为组织架构图效果。图2为人员信息存储模板。
图1. 利用VBA代码创建的组织架构图
在下面的模板中输入人员信息和汇报关系，本组织中最高领导的Report To为自己（当然他自己的真正老板不会是自己）。Is Admin是指该员工是否是老板秘书，只有最高老板下才能设置秘书，也就是说秘书的老板必须是最高老板，否则程序出错。Draw列留空，这是为代码做记号用的。
常规设置：
Level 1是中最高老板，其填充颜色，边框颜色，字号可以和其它级别不同。Title Font Size Ratio是指头衔字号与姓名字号的大小比例。员工照片必须和本工具存贮于同一文件夹中。
遗留问题：
1. 在VBA中，还是不能对组织架构图中子图形进行大小和位置的设置，因此下表中的Left，Top，Width和Height都没有用到；
2. VBA中也不能将默认的矩形转换成圆角矩形，因此Round Rectangle参数也没有用
所以，我在该工具中加了两个按钮，Select Shape 1——选择所有输入文字的矩形；Select Shape 2——选择所有照片矩形。这样，我们可以一次性更改这些图形的格式。当然，我们按照该思路，也可以增加功能，让用户可以选择指定的图形，或者指定某个人以及他的所有下属（本版本工具中不具备该功能）。
图2. 将人员信息输入在Excel表格，再通过代码创建组织架构图
详细代码：
Option Explicit
'Settings
Dim lFillColor1 As Long
Dim lFillColor2 As Long
Dim lBorderColor1 As Long
Dim lBorderColor2 As Long
Dim strRoundRec As String
Dim sinFontSize1 As String
Dim sinFontSize2 As String
Dim strHasPic As String
Dim sinTitleFontRatio As String
Dim strHasShadow As String
Dim lFontColor As Long
Dim sinWidthOC As Single
Dim sinHeightOC As Single
'Organization data
Dim strName As String
Dim strTitle As String
Dim strReportTo As String
Dim strIsAdmin As String
Dim strPicture As String
Dim sinLeft As Single
Dim sinTop As Single
Dim sinWidth As Single
Dim sinHeight As Single
'Top manager
Dim ndTopMgr As SmartArtNode
Dim strTopMgr As String
Sub CreateOrgChart()
Dim shtTemp As Worksheet 'active worksheet
Dim shpOC As Shape 'Organization chart smart art
Dim lstObjTemp As ListObject 'Table of organization data
Dim i As Integer
Dim iRowCount As Integer
Dim ndTemp As SmartArtNode 'Organization chart node
Set shtTemp = ActiveSheet
With shtTemp
On Error Resume Next
.Shapes("TigerOCAddin").Delete
On Error GoTo 0
'Get general settings
lFillColor1 = .Range("rngFillColor1").Interior.Color
lFillColor2 = .Range("rngFillColor2").Interior.Color
lBorderColor1 = .Range("rngBorderColor1").Interior.Color
lBorderColor2 = .Range("rngBorderColor2").Interior.Color
strRoundRec = .Range("rngRoundRec").Value
sinFontSize1 = .Range("rngFontSize1").Value
sinFontSize2 = .Range("rngFontSize2").Value
strHasPic = .Range("rngHasPic").Value
sinTitleFontRatio = .Range("rngTitleFontSize").Value
strHasShadow = .Range("rngHasShadow").Value
lFontColor = .Range("rngFontColor").Interior.Color
sinWidthOC = .Range("rngWidth").Value
sinHeightOC = .Range("rngHeight").Value
Set lstObjTemp = .ListObjects(1)
'Organization Chart SmartArt with Picture
Set shpOC = .Shapes.AddSmartArt(Application.SmartArtLayouts(98))
With shpOC
.Left = 0
.Top = 0
.Width = sinWidthOC
.Height = sinHeightOC
.Name = "TigerOCAddin"
'Delete all default nodes, so that draw customized nodes later
For i = .SmartArt.AllNodes.Count To 1 Step -1
.SmartArt.AllNodes(i).Delete
Next i
End With
With lstObjTemp
iRowCount = .Range.Rows.Count
.ListColumns("Draw").DataBodyRange.ClearContents
For i = 2 To iRowCount
strName = .ListColumns("Name").Range.Cells(i).Value
strReportTo = .ListColumns("Report To").Range.Cells(i).Value
'The top level report to itself
If strName = strReportTo Then
Set ndTemp = shpOC.SmartArt.AllNodes.Add
Set ndTopMgr = ndTemp
strTopMgr = strName
strTitle = .ListColumns("Title").Range.Cells(i).Value
strIsAdmin = .ListColumns("Is Admin").Range.Cells(i).Value
strPicture = .ListColumns("Picture").Range.Cells(i).Value
sinLeft = .ListColumns("Left").Range.Cells(i).Value
sinTop = .ListColumns("Top").Range.Cells(i).Value
sinWidth = .ListColumns("Width").Range.Cells(i).Value
sinHeight = .ListColumns("Height").Range.Cells(i).Value
With ndTemp
With .Shapes(1)
' .Width = sinWidth
' .Height = sinHeight
' .Left = sinLeft
' .Top = sinTop
With .Fill
.Visible = msoTrue
.ForeColor.RGB = lFillColor1
End With
With .Line
.Visible = msoTrue
.ForeColor.RGB = lBorderColor1
End With
.Shadow.Visible = (strHasShadow = "Yes")
' If strRoundRec = "Yes" Then
' .AutoShapeType = msoShapeRoundedRectangle
' End If
End With
If strPicture <> "" Then
With .Shapes(2)
.Fill.UserPicture ThisWorkbook.Path & "\" & strPicture
End With
End If
With .TextFrame2.TextRange
.Text = strName & VBA.Chr(10) & strTitle
With .Font
.Fill.ForeColor.RGB = lFontColor
.Name = "Arial"
.Size = sinFontSize1 * sinTitleFontRatio
End With
.Characters(1, VBA.Len(strName)).Font.Size = sinFontSize1
End With
' .Smaller
End With
.ListColumns("Draw").Range.Cells(i) = "Yes"
'Draw subordinates
Call AddSubNodes(lstObjTemp, ndTemp, strName)
Exit For
End If
Next i
End With
End With
End Sub
Private Sub AddSubNodes(loTemp As ListObject, _
ndTemp As SmartArtNode, _
strManager As String)
Dim i As Integer
Dim iRowCount As Integer
Dim bFound As Boolean
Dim ndParent As SmartArtNode
Dim strSubName As String
' bFound = False
i = 2
With loTemp
iRowCount = .Range.Rows.Count
Do While i <= iRowCount
If .ListColumns("Draw").Range.Cells(i).Value = "Yes" Then
i = i + 1
ElseIf .ListColumns("Report To").Range.Cells(i).Value = strManager Then
Set ndParent = ndTemp
strName = .ListColumns("Name").Range.Cells(i).Value
strReportTo = .ListColumns("Report To").Range.Cells(i).Value
strTitle = .ListColumns("Title").Range.Cells(i).Value
strIsAdmin = .ListColumns("Is Admin").Range.Cells(i).Value
strPicture = .ListColumns("Picture").Range.Cells(i).Value
sinLeft = .ListColumns("Left").Range.Cells(i).Value
sinTop = .ListColumns("Top").Range.Cells(i).Value
sinWidth = .ListColumns("Width").Range.Cells(i).Value
sinHeight = .ListColumns("Height").Range.Cells(i).Value
If strIsAdmin = "Yes" Then
Set ndTemp = ndParent.AddNode(msoSmartArtNodeDefault, msoSmartArtNodeTypeAssistant)
Else
Set ndTemp = ndParent.AddNode(msoSmartArtNodeBelow)
End If
strSubName = .ListColumns("Name").Range.Cells(i).Value
With ndTemp
With .Shapes(1)
' .Width = sinWidth
' .Height = sinHeight
' .Left = sinLeft
' .Top = sinTop
With .Fill
.Visible = msoTrue
.ForeColor.RGB = lFillColor2
End With
With .Line
.Visible = msoTrue
.ForeColor.RGB = lBorderColor2
End With
.Shadow.Visible = (strHasShadow = "Yes")
' If strRoundRec = "Yes" Then
' .AutoShapeType = msoShapeRoundedRectangle
' End If
End With
With .Shapes(2)
If strPicture <> "" Then _
.Fill.UserPicture ThisWorkbook.Path & "\" & strPicture
End With
With .TextFrame2.TextRange
.Text = strName & VBA.Chr(10) & strTitle
With .Font
.Fill.ForeColor.RGB = lFontColor
.Name = "Arial"
.Size = sinFontSize2 * sinTitleFontRatio
End With
.Characters(1, VBA.Len(strName)).Font.Size = sinFontSize2
End With
End With
.ListColumns("Draw").Range.Cells(i) = "Yes"
Call AddSubNodes(loTemp, ndTemp, strSubName)
If Not ndTemp Is ndTopMgr Then
Set ndTemp = ndTemp.Parent
strManager = VBA.Left(ndTemp.TextFrame2.TextRange.Text, _
VBA.InStr(1, ndTemp.TextFrame2.TextRange.Text, Chr(10), vbBinaryCompare) - 1)
End If
Else
i = i + 1
End If
Loop
End With
End Sub
Sub selectShape1()
Dim shtTemp As Worksheet
Dim shpOC As Shape
Set shtTemp = ActiveSheet
With shtTemp
Set shpOC = .Shapes("TigerOCAddin")
Call SelectShapes(shpOC, 1)
End With
End Sub
Sub selectShape2()
Dim shtTemp As Worksheet
Dim shpOC As Shape
Set shtTemp = ActiveSheet
With shtTemp
Set shpOC = .Shapes("TigerOCAddin")
Call SelectShapes(shpOC, 2)
End With
End Sub
Private Sub SelectShapes(shpTemp As Shape, intShp As Integer)
Dim i As Integer
With shpTemp.SmartArt
For i = 1 To .AllNodes.Count
.AllNodes(i).Shapes(intShp).Select False
Next i
End With
With shpTemp
End With
End Sub
Organization Chart Tool.zip
(30.49 KB, 下载次数: 2705)
|
|
[复制链接]
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2012-2-7 15:50
楼主
发表于 2012-2-8 17:17
