用Excel的图表及形状控件来制作简易仪表
1.在sheet1工作表输入过程.
Sub gdt()
ActiveSheet.Shapes("我的指针").Select
Selection.ShapeRange.Rotation = Range("A1")
Range("A1").Select
End Sub
2.新建模块,在模块内输入过程和函数.
Sub Sctubiao()
If Not MyChart("我的仪表", xlDoughnut, , , False, , , 20, 200, 150) Then MsgBox "NO TuBiao"
End Sub
'以下为自定义函数代码:
Function MyChart(Optional ByVal MyChart_Name As String = "我的图表", Optional ByVal MyChart_Type As XlChartType = xlColumnClustered, _
Optional ByVal MyChart_Source As Range = Nothing, Optional ByVal MyChart_Plotby As XlRowCol = xlRows, _
Optional ByVal MyChart_Title As Boolean = True, Optional ByVal MyChart_TitleText As String = "标题", _
Optional ByVal MyChart_HasLegend As Boolean = False, Optional ByVal MyChart_kd, _
Optional ByVal MyChart_Left As Integer = 420, Optional ByVal MyChart_Top As Integer = 250, _
Optional ByVal MyChart_Width As Integer = 300, Optional ByVal MyChart_Height As Integer = 200) As Boolean
'参数 (可选):
' MyChart_Name As String = "我的图表" 字符型,设置图表的名称,默认值="我的图表"
' MyChart_Type As XlChartType = xlColumnClustered XlChartType枚举,设置图表类型,默认值=xlColumnClustered簇状柱形图
' MyChart_Source As Range = Nothing 单元格对象,设置图表数据源,默认为空
' MyChart_Plotby As XlRowCol = xlRows XlRowCol枚举,设置图表数据系列的数值是处于行中还是列中,默认值=xlRows行中
' MyChart_Title As Boolean = True 布尔型,设置图表有可见标题,默认值=True有可见标题
' MyChart_TitleText As String = "标题" 字符型,设置图表的标题文本,默认值="标题"
' MyChart_HasLegend As Boolean = False 布尔型,设置图表有图例,默认值=False没有图例
' MyChart_Left As Integer = 420 整型,设置图表的左边距,默认值=420
' MyChart_Top As Integer = 250 整型,设置图表的上边距,默认值=250
' MyChart_Width As Integer = 300 整型,设置图表的宽度,默认值=300
' MyChart_Height As Integer = 200 整型,设置图表的高度,默认值=200
Dim Mych As ChartObject '声明变量为嵌入式图表对象
Dim MyJh As Collection '声明变量集合
Dim MyShe As Worksheet '声明变量为工作表对象
Dim Mysz() As Integer '声明变量为数组
On Error Resume Next '如出错,则从出错行下一行开始执行
Set MyShe = Application.ActiveSheet '设置对象变量为激活工作表
Set MyJh = New Collection '设置新集合变量
Set Mych = ActiveSheet.ChartObjects(MyChart_Name) '设置对象
ReDim Mysz(1 To MyChart_kd) '重新定义数组并赋初值
For k = 1 To MyChart_kd
Mysz(k) = 1
Next
MyChart_Width = 220
MyChart_Height = 220
'绘制园环图-------------------------------------------------------------------------------------------
'MsgBox Err.Number
If Err.Number <> 0 Then '设置对象出错,没有对象
Set Mych = ActiveSheet.ChartObjects.Add(MyChart_Left, MyChart_Top, MyChart_Width, MyChart_Height) '添加嵌入图表,设置对象
Mych.Name = MyChart_Name '设置对象名称
Mych.Chart.SeriesCollection.NewSeries '创建新系列1
Mych.Chart.SeriesCollection.NewSeries '创建新系列2
End If
Err.Clear '清除Err对象
On Error GoTo Myerr '如出错,则执行Myerr语句
With Mych.Chart
.ChartType = MyChart_Type '图表类型为xlLineMarkers_数据点折线图
.HasTitle = MyChart_Title '图表标题，可见则为 True
If MyChart_Title Then .ChartTitle.Characters.Text = MyChart_TitleText '图表标题文本
'.ChartTitle.Characters.Font.Size = 12 '设置标题的字号
'.SetSourceData Source:=MyChart_Source, PlotBy:=MyChart_Plotby '为指定图表设置源数据区域
.HasLegend = MyChart_HasLegend '为False ,图表没有图例
.SeriesCollection(1).Values = Mysz '设置系列1源数据
.SeriesCollection(2).Values = Mysz '设置系列2源数据
.ChartGroups(1).FirstSliceAngle = 180 '设置第一扇区的角度
.ChartGroups(1).DoughnutHoleSize = 60 '设置内径大小
.ChartArea.Fill.OneColorGradient Style:=msoGradientFromCenter, Variant:=1, Degree:=0 '设置图表填充设为单色渐变
.ChartArea.Fill.ForeColor.SchemeColor = 2 '设置图表前景色:白
'.PlotArea.Top = 5 '绘图区上边距
'.PlotArea.Left = (MyChart_Width - .PlotArea.Width) / 2-2 '绘图区下边距
.PlotArea.Border.LineStyle = xlNone '绘图区边框线型:无
.PlotArea.Interior.ColorIndex = xlNone '绘图区填充:无
With .SeriesCollection(1) '设置系列1格式
For xl = 1 To .Points.Count
.Points(xl).Border.LineStyle = xlNone '无边框
Select Case xl
Case 1
.Points(xl).Interior.ColorIndex = xlNone '无填充
Case 2 To .Points.Count * 10 / 20
.Points(xl).Interior.ColorIndex = 35 '填充淡绿色
Case .Points.Count * 10 / 20 To .Points.Count * 14 / 20
.Points(xl).Interior.ColorIndex = 20 '填充淡兰色
Case .Points.Count * 14 / 20 To .Points.Count * 17 / 20
.Points(xl).Interior.ColorIndex = 38 '填充淡红色
Case .Points.Count * 17 / 20 To .Points.Count - 1
.Points(xl).Interior.ColorIndex = 3 '填充红色
Case .Points.Count
.Points(xl).Interior.ColorIndex = xlNone '无填充
End Select
Next xl
End With
With .SeriesCollection(2) '设置系列2格式
.ApplyDataLabels AutoText:=True '根据内容自动生成数据标签
For xl = 1 To .Points.Count
.Points(xl).Border.Weight = xlMedium '设置系列2格式,边框加粗
Select Case xl
Case 1
.Points(xl).Interior.ColorIndex = xlNone '无填充
Case 2 To .Points.Count * 10 / 20
.Points(xl).Interior.ColorIndex = 35 '填充淡绿色
Case .Points.Count * 10 / 20 To .Points.Count * 14 / 20
.Points(xl).Interior.ColorIndex = 20 '填充淡兰色
Case .Points.Count * 14 / 20 To .Points.Count * 17 / 20
.Points(xl).Interior.ColorIndex = 38 '填充淡红色
Case .Points.Count * 17 / 20 To .Points.Count - 1
.Points(xl).Interior.ColorIndex = 3 '填充红色
Case .Points.Count
.Points(xl).Interior.ColorIndex = xlNone '无填充
End Select
If xl = 1 Or xl = .Points.Count Then '更改数据标签
.Points(xl).DataLabel.Characters.Text = ""
Else
.Points(xl).DataLabel.Characters.Text = (xl - 1) * 10
End If
Next xl
End With
End With
'Mych.Activate '对象激活
'Mych.Placement = xlFreeFloating '设置图表为可自由浮动（既不随下方单元格移动，也不随其改变大小）。
MyJh.Add Mych.Name '把该图表形状添加到集合中
'绘制园形1-------------------------------------------------------------------------------------------
Y_width = 185
Y_height = 185
Y_left = MyChart_Left + MyChart_Width / 2 - Y_width / 2
Y_Top = MyChart_Top + MyChart_Height / 2 - Y_height / 2
With MyShe.Shapes.AddShape(msoShapeOval, Y_left, Y_Top, Y_width, Y_height) '添加园 msoShapeOval椭圆形
.Fill.Transparency = 1 '设置形状为透明
.Line.Weight = 4 '设置线条宽度
'.Line.ForeColor.RGB = myRGB '设置前景色
MyJh.Add .Name '把该形状添加到集合中
End With
'绘制园形2-------------------------------------------------------------------------------------------
Y_width = 35
Y_height = 35
Y_left = MyChart_Left + MyChart_Width / 2 - Y_width / 2
Y_Top = MyChart_Top + MyChart_Height / 2 - Y_height / 2
With MyShe.Shapes.AddShape(msoShapeOval, Y_left, Y_Top, Y_width, Y_height) '添加园 msoShapeOval椭圆形
.Line.Weight = 2 '设置线条宽度
.Fill.ForeColor.SchemeColor = 12 '设置前景色填充
MyJh.Add .Name '把该形状添加到集合中
End With
'对形状进行组合-------------------------------------------------------------------------------------------
ReDim myJhsz(MyJh.Count - 1) '为动态数组变量分配存储空间
For k = 0 To MyJh.Count - 1
myJhsz(k) = MyJh.Item(k + 1) '为动态数组变量赋值
Next
With MyShe.Shapes.Range(myJhsz).Group '把集合中的形状进行组合
.LockAspectRatio = True '组合形状纵横比例锁定
.Placement = xlFreeFloating '组合形状大小/位置不随单元格变化
.Name = MyChart_Name
End With
'删除集合中的内容-------------------------------------------------------------------------------------------
For k = 1 To MyJh.Count
MyJh.Remove 1 ' 将第一个对象删除
' 直到删除所有对象为止。
Next k
'绘制指针-------------------------------------------------------------------------------------------
Y_width = 15
Y_height = 80
Y_left = MyChart_Left + MyChart_Width / 2 - Y_width / 2
Y_Top = MyChart_Top + MyChart_Height / 2
With MyShe.Shapes.AddShape(msoShapeIsoscelesTriangle, Y_left, Y_Top, Y_width, Y_height) '添加三角形
.Line.Weight = 1 '设置线条宽度
.Rotation = 180 '顺时针旋转180度
.Fill.ForeColor.SchemeColor = 2 '设置前景色填充
MyJh.Add .Name '把该形状添加到集合中
End With
BeginX = MyChart_Left + MyChart_Width / 2
Beginy = MyChart_Top + MyChart_Height / 2 - Y_height
EndX = MyChart_Left + MyChart_Width / 2
EndY = MyChart_Top + MyChart_Height / 2
With MyShe.Shapes.AddLine(BeginX, Beginy, EndX, EndY) '添加
.Line.Weight = 2 '设置线条宽度
.Fill.ForeColor.SchemeColor = 2 '设置前景色填充
.Line.Visible = msoFalse '设置线条不可见
MyJh.Add .Name '把该形状添加到集合中
End With
'对形状进行组合-------------------------------------------------------------------------------------------
ReDim myJhsz(MyJh.Count - 1) '为动态数组变量分配存储空间
For k = 0 To MyJh.Count - 1
myJhsz(k) = MyJh.Item(k + 1) '为动态数组变量赋值
Next
With MyShe.Shapes.Range(myJhsz).Group '把集合中的形状进行组合
.LockAspectRatio = True '组合形状纵横比例锁定
.Placement = xlFreeFloating '组合形状大小/位置不随单元格变化
.Rotation = 360 / MyChart_kd '顺时针旋转xxx度
.Name = "我的指针"
End With
'绘制滚动条-------------------------------------------------------------------------------------------
Y_width = 150
Y_height = 12
Y_left = MyChart_Left + MyChart_Width / 2 - Y_width / 2
Y_Top = MyChart_Top + MyChart_Height - Y_height - 2
With MyShe.ScrollBars.Add(Y_left, Y_Top, Y_width, Y_height) '添加滚动条
.LinkedCell = "$A$1" '设置滚动条与单元格A1链接
.Value = 360 / MyChart_kd '设置滚动条当前值
.Min = 360 / MyChart_kd '设置滚动条最小值
.Max = 360 - 360 / MyChart_kd '设置滚动条最大值
.OnAction = MyShe.CodeName & ".gdt" '设置滚动条的宏
End With
MyChart = True '本函数返回True
Exit Function '退出函数
Myerr:
MyChart = False '本函数返回False
End Function
