玩转VBA窗体图表——MSChart控件详细教程

yunfei2018

窗体上，日期输入窗体，我咋没有找到是哪个窗体？也没有找到对应的代码了？想借鉴一下，望指点，谢谢！

ivccav

2. 图表实践

2.1 堆叠图表

        图表的堆叠通过Stacking属性设置。堆叠图表可用于比较同一个点不同系列的比较。当然也可以使用饼图实现。本节不仅讲了堆叠柱状图的使用，还使用了百分比坐标轴类型。使用如下数据实现4个人相同月份的数据比较：



全部代码如下（附件中窗体4）注意看用百分比和不用百分比的区别：

Private Sub CheckBox1_Click()
With MSChart1
    If CheckBox1 Then
        .Plot.Axis(VtChAxisIdY).AxisScale.Type = VtChScaleTypePercent
        .Plot.Axis(VtChAxisIdY).AxisScale.PercentBasis = VtChPercentAxisBasisSumRow
        For i = 1 To .Plot.SeriesCollection.Count
            .Plot.SeriesCollection(i).DataPoints(-1).DataPointLabel.LocationType = VtChLabelLocationTypeCenter
            .Plot.SeriesCollection(i).DataPoints(-1).DataPointLabel.Component = VtChLabelComponentPercent
            .Plot.SeriesCollection(i).DataPoints(-1).DataPointLabel.PercentFormat = "0.0%"
        Next
    Else
        .Plot.Axis(VtChAxisIdY).AxisScale.Type = VtChScaleTypeLinear
        For i = 1 To .Plot.SeriesCollection.Count
            .Plot.SeriesCollection(i).DataPoints(-1).DataPointLabel.LocationType = VtChLabelLocationTypeCenter
            .Plot.SeriesCollection(i).DataPoints(-1).DataPointLabel.Component = VtChLabelComponentValue
        Next
    End If
End With
End Sub

Private Sub CheckBox2_Click()
    MSChart1.Stacking = CheckBox2
End Sub

Private Sub UserForm_Initialize()
Dim arr(), i%
arr = Range("a1:e13")
With MSChart1
    .ChartData = arr
    .ChartType = VtChChartType3dArea
    .Stacking = True
    .Legend.Location.Visible = True
    .Legend.Location.LocationType = VtChLocationTypeBottom
    For i = 1 To .Plot.SeriesCollection.Count
        .Plot.SeriesCollection(i).DataPoints(-1).DataPointLabel.LocationType = VtChLabelLocationTypeCenter
    Next
End With
With ComboBox1
    .AddItem "VtChChartType3dBar" '0 3D 条形图
    .AddItem "VtChChartType2dBar" '1 2D 条形图
    .AddItem "VtChChartType3dLine" '2 3D 折线图
    .AddItem "VtChChartType2dLine" '3 2D 折线图
    .AddItem "VtChChartType3dArea" '4 3D 面积图
    .AddItem "VtChChartType2dArea" '5 2D 面积图
    .AddItem "VtChChartType3dStep" '6 3D 阶梯图
    .AddItem "VtChChartType2dStep" '7 2D 阶梯图
    .AddItem "VtChChartType3dCombination" '8 3D 组合图
    .AddItem "VtChChartType2dCombination" '9 2D 组合图
    .AddItem "VtChChartType2dPie" '14 2D 饼图
    .AddItem "VtChChartType2dXY" '16 2D XY 散点图
    .ListIndex = 1
    .style = fmStyleDropDownList
End With
    CheckBox2 = True
    Me.Caption = "认识堆叠图"
End Sub

Private Sub ComboBox1_Change()
    Dim idx%
    idx = ComboBox1.ListIndex
    If idx > 9 Then idx = 14 + IIf(idx = 10, 0, 2)
    MSChart1.ChartType = idx
End Sub

运行结果为：

ivccav

2.2切片图表

        其实是没有切片图表类型的，这个说法是EXCEL里面的，本质就是按不同的条件进行查询，把数据归类，然后用图表展示。本节举2个例子，第一个例子使用饼图的图表类型，第二个例子使用了统计线（使用的统计线类型是趋势线）。例1把如下数据按年份切片，统计每个人不同项目的绩效：



代码如下（附件中窗体11）：
Dim cnn As Object
Private Sub CheckBox1_Click()
With MSChart1
    If CheckBox1 Then
        .Plot.Axis(VtChAxisIdY).AxisScale.PercentBasis = VtChPercentAxisBasisSumRow
        .Plot.Axis(VtChAxisIdY).AxisScale.Type = VtChScaleTypePercent
        .Plot.Weighting.Basis = VtChPieWeightBasisNone '所有饼图一样大小
        For i = 1 To .Plot.SeriesCollection.Count '无法设置单个数据点属性，索引必须等于-1，代表所有数据点
            .Plot.SeriesCollection(i).DataPoints(-1).DataPointLabel.LocationType = VtChLabelLocationTypeCenter
            .Plot.SeriesCollection(i).DataPoints(-1).DataPointLabel.Component = VtChLabelComponentPercent
            .Plot.SeriesCollection(i).DataPoints(-1).DataPointLabel.PercentFormat = "0.0%"
        Next
    Else
        .Plot.Axis(VtChAxisIdY).AxisScale.Type = VtChScaleTypeLinear
        .Plot.Weighting.Basis = VtChPieWeightBasisTotal
        For i = 1 To .Plot.SeriesCollection.Count
            .Plot.SeriesCollection(i).DataPoints(-1).DataPointLabel.LocationType = VtChLabelLocationTypeCenter
            .Plot.SeriesCollection(i).DataPoints(-1).DataPointLabel.Component = VtChLabelComponentValue
        Next
    End If
End With
End Sub

Private Sub ComboBox1_Change()
    Set rst = CreateObject("adodb.recordset")
    Sql = "select 姓名,sum(项目A) as 项目A,sum(项目B) as 项目B,sum(项目C) as 项目C,sum(项目D) as 项目D " & _
            "from [切片图表$] where 年数='" & ComboBox1 & "' group by 姓名"
    rst.Open Sql, cnn, 1, 3
    If rst.RecordCount = 0 Then Exit Sub
    With MSChart1
        .ChartData = Application.Transpose(rst.getrows)
        .ChartType = VtChChartType2dPie
        For i = 1 To .columnCount '修改系列名称，不能用ChartData修改
            .Column = i
            .ColumnLabel = rst.fields(i).Name
        Next
        .AllowSelections = False '禁止选择图表元素
        .ShowLegend = True
        .Legend.Location.LocationType = VtChLocationTypeBottom
    End With
    rst.Close
    Set rst = Nothing
End Sub

Private Sub UserForm_Initialize()
    Set cnn = CreateObject("adodb.connection")
    Set rst = CreateObject("adodb.recordset") '连接数据库
    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES';Data Source=" & ThisWorkbook.FullName
    Sql = "select distinct 年数 from [切片图表$] order by 年数 desc"
    rst.Open Sql, cnn, 1, 3
    If rst.RecordCount = 0 Then Exit Sub
    With ComboBox1
       .Column = rst.getrows
       .ListIndex = 0
       .style = fmStyleDropDownList
    End With
    CheckBox1 = True
    Me.Caption = "切片图"
    rst.Close
    Set rst = Nothing
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    cnn.Close
    Set cnn = Nothing
End Sub

例2的数据来源于网友的提问，需要切片的数据很多，还好可用ADO，不然代码都得写晕。工作表函数Application.Index用于获取数组中的一整列，而工作表函数Application.Max和Application.Min可获取一维数组中的最大值和最小值，善用工作表函数可省略不少代码。最重要的当然是ValueScale对象的使用，要理解了，才能作好图表。示例为附件窗体17.

Dim cnn As Object

Private Sub ComboBox1_Change() '班组名称
    Call Query
End Sub

Private Sub ComboBox2_Change() '产品名称
    Call Query
End Sub

Private Sub ComboBox3_Change() '测试项目
    Call Query
End Sub

Private Sub DTPicker1_Change() '日期范围
    Call Query
End Sub

Private Sub DTPicker2_Change() '日期范围
    Call Query
End Sub

Private Sub UserForm_Initialize()
    Dim sql$, a()
    Set cnn = CreateObject("adodb.connection")
    Set rst = CreateObject("adodb.recordset") '连接数据库
    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES';Data Source=" & ThisWorkbook.FullName

    DTPicker1 = DateAdd("yyyy", -1, Date)
    DTPicker2 = Date

    sql = "select distinct 产品名称 from [切片图表2$] order by 产品名称"
    rst.Open sql, cnn, 1, 3
    If rst.RecordCount = 0 Then Exit Sub
    With ComboBox2
       .Column = rst.getrows
       .ListIndex = 0
       .style = fmStyleDropDownList
    End With
    rst.Close

    With ComboBox3
       .List = Array("5片厚度mm", "5片干重g", "抗压强度N", "卷重kg")
       .ListIndex = 0
       .style = fmStyleDropDownList
    End With

    sql = "select distinct 班组 from [切片图表2$] order by 班组"
    rst.Open sql, cnn, 1, 3
    If rst.RecordCount = 0 Then Exit Sub
    With ComboBox1
       .Column = rst.getrows
       .AddItem "全部", 0
       .ListIndex = 0
       .style = fmStyleDropDownList
    End With
    rst.Close: Set rst = Nothing
    Call Query
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    cnn.Close: Set cnn = Nothing
End Sub

Private Function GetSQL() As String
    If ComboBox1 = "全部" Then
        GetSQL = "select format(卷号,'J0000'),[" & ComboBox3 & "] from [切片图表2$] where 产品名称='" & ComboBox2 & "' and 日期 between #" & DTPicker1 & "# and #" & DTPicker2 & "# order by format(卷号,'0000')"
    Else
        GetSQL = "select format(卷号,'J0000'),[" & ComboBox3 & "] from [切片图表2$] where 产品名称='" & ComboBox2 & "' and 日期 between #" & DTPicker1 & "# and #" & DTPicker2 & "# and 班组='" & ComboBox1 & "' order by format(卷号,'0000')"
    End If
End Function

Private Sub Query()
    Dim sql$, arr(), YARR(), YMAX!, YMIN!
    If Len(ComboBox1) * Len(ComboBox2) * Len(ComboBox3) = 0 Then Exit Sub
    Set rst = CreateObject("adodb.recordset")
    sql = GetSQL: If Len(sql) = 0 Then Exit Sub
    rst.Open sql, cnn, 1, 3
    If rst.RecordCount = 0 Then Exit Sub
    arr = Application.Transpose(rst.getrows)
    rst.Close: Set rst = Nothing
    YARR = Application.Index(arr, 0, 2)
    YMAX = Application.Max(YARR)
    YMIN = Application.Min(YARR)
    With MSChart1
        .ChartData = arr
        .ChartType = VtChChartType2dLine
        .Title = ComboBox3 & " 趋势图"
        .Plot.UniformAxis = False
        .Plot.Axis(VtChAxisIdX).AxisGrid.MajorPen.style = VtPenStyleNull
        With .Plot.Axis(VtChAxisIdY).ValueScale
            .Auto = False
            .Maximum = YMAX
            .Minimum = YMIN
            .MajorDivision = 10
            .MinorDivision = 0
        End With
        With .Plot.SeriesCollection(1).Pen
            .Width = 4
            .VtColor.Set 0, 0, 255
        End With
        With .Plot.SeriesCollection(1).StatLine
            .VtColor.Set 255, 0, 0
            .Flag = VtChStatsRegression
            .style(VtChStatsRegression) = VtPenStyleDashDit
            .Width = 40
        End With
    End With
End Sub

ivccav

2.3 组合图表

        组合图表类型为VtChChartType2dCombination，所谓组合图表，就是不同的系列可以使用不同的图表类型（XY散点图不能组合，挺遗憾的），然后组合成复杂的分析图表。本例使用柱状图和折线图来显示完成数量和完成率，并使用了堆叠属性来显示未完成的数量，要主要的是堆叠顺序的设置，避免想要显示的系列（本例是折线图）被其他系列覆盖。完成率使用次坐标轴，要自行设计其刻度与数值刻度的对应关系，否则图表和数据就不一致了。本例在附件窗体5，使用的数据如下表：



完整代码如下：

Private Sub UserForm_Initialize()
Dim arr()
arr = Range("a1:d9")
With MSChart1
    .ChartData = arr
    .ChartType = VtChChartType2dCombination
    .Legend.Location.Visible = True
    .Stacking = True
    .Plot.SeriesCollection(1).DataPoints(-1).DataPointLabel.LocationType = VtChLabelLocationTypeCenter
    .Plot.SeriesCollection(2).DataPoints(-1).DataPointLabel.LocationType = VtChLabelLocationTypeCenter
    With .Plot.SeriesCollection(3)
        .SeriesType = VtChSeriesType2dLine '修改系列3的图表类型
        .SecondaryAxis = True '应用Y轴次坐标轴，要设计百分比和数据一致
    End With
    .Plot.SeriesCollection(3).Position.Order = 1
    .Plot.SeriesCollection(2).Position.Order = 2
    .Plot.SeriesCollection(1).Position.Order = 2 '1和2Order需要一致，否则就不再堆叠了。
End With
Me.Caption = "组合图"
End Sub

最后的效果如下图：


2.4 动态散点图

        XY散点图与其他图表类型最大的区别就是需要2列数据才能显示一个系列，第一列表示X值，第二列表示Y值，其他图表类型是不需要X值的。如果要显示N个系列的XY散点图，需要N*2列的数据数组。散点图的关键在于设置好ValueScale。下面这个例子的数据来源于网友的求助，数据很多，截图只是局部：

完整代码如下（附件窗体18）：
Private Sub UserForm_Initialize()
Dim arr()
arr = Range("a1:b200")
With MSChart1
    .TitleText = "变化趋势图"
    .Title.VtFont.VtColor.Blue = 255
    .Plot.Axis(VtChAxisIdX).AxisTitle.Text = "时间（单位：秒）"
    .Plot.SeriesCollection(1).Pen.Width = 20
    .Plot.SeriesCollection(1).Pen.style = VtPenStyleSolid
    With .Plot.Axis(VtChAxisIdX).ValueScale
        .Auto = False
        .Maximum = 10
        .Minimum = 0
        .MajorDivision = 6
        .MinorDivision = 0
    End With
    .Plot.Axis(VtChAxisIdX).AxisGrid.MajorPen.style = VtPenStyleDotted
    With .Plot.Axis(VtChAxisIdY).ValueScale
        .Auto = False
        .Maximum = 400
        .Minimum = -800
        .MajorDivision = 12
        .MinorDivision = 0
    End With
    .Plot.Axis(VtChAxisIdY).AxisGrid.MajorPen.style = VtPenStyleDotted
    .Plot.UniformAxis = False
    .ChartType = VtChChartType2dXY
    .ChartData = arr
End With
End Sub

下面再举一个XY散点图的例子。

图表显示2个系列的XY散点曲线，数据为随机数，每秒钟填充一次数据，动态显示。VBA中没有计时器，使用Application.OnTime又闪烁得厉害，没法看，因此使用了API函数SetTimer。关闭窗体时记得KillTimer。控件属性DrawMode设置为VtChDrawModeBlit，应该会减少闪烁。DrawMode 属性决定什么时候以及如何重绘图表，有2个可选值，VtChDrawModeDraw 是直接绘制到显示设备上，而VtChDrawModeBlit使用 Blit 方式把内存中的图形绘制到显示设备上。

窗体中的代码（附件窗体19）为：

Private Sub UserForm_Initialize()
Dim i&, j&
For i = 1 To 20
    arr(i, 1) = DateAdd("s", -(20 - i), Time)
    arr(i, 2) = Rnd() * 100
    arr(i, 3) = arr(i, 1)
    arr(i, 4) = Rnd() * 80
Next
With Me.MSChart1
    With .Plot.Axis(VtChAxisIdX).ValueScale
        .Auto = False
        .MajorDivision = 10
        .MinorDivision = 0
        .Maximum = Time + TimeValue("0:0:00")
        .Minimum = Time - TimeValue("0:0:19")
    End With
    .Plot.Axis(VtChAxisIdX).Labels(1).Format = "hh:mm:ss"
    .Plot.UniformAxis = False
    .ChartType = VtChChartType2dXY
    .DrawMode = VtChDrawModeBlit
    .ChartData = arr
End With
Start_Timer
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Stop_Timer
End Sub

因为需要回调函数，而AddressOf函数必须放在模块中，模块中的代码如下：

Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Const WM_TIMER = &H113 '计时器消息，API常数
Private Const lDuration = 1000& '时间间隔，单位毫秒，可自行设置
Private lTimerID As Long '保存计时器ID号
Public arr#(1 To 20, 1 To 4)

Public Sub Start_Timer()
    If lTimerID <> 0 Then Call Stop_Timer
    lTimerID = SetTimer(0&, 0&, lDuration, AddressOf TimerProc)
End Sub

Public Sub Stop_Timer()
    KillTimer 0&, lTimerID
    lTimerID = 0
End Sub

Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    Dim i&, j&
    If uMsg = WM_TIMER And idEvent = lTimerID Then
        For i = 1 To 19
            arr(i, 1) = arr(i + 1, 1)
            arr(i, 2) = arr(i + 1, 2)
            arr(i, 3) = arr(i + 1, 3)
            arr(i, 4) = arr(i + 1, 4)
        Next
        Randomize
        With UserForm19
            arr(20, 1) = Time
            arr(20, 3) = arr(20, 1)
            arr(20, 2) = Rnd() * 100
            arr(20, 4) = Rnd() * 80
            With .MSChart1
                With .Plot.Axis(VtChAxisIdX).ValueScale
                    .Auto = False
                    .MajorDivision = 10
                    .MinorDivision = 0
                    .Maximum = Time + TimeValue("0:0:00")
                    .Minimum = Time - TimeValue("0:0:19")
                End With
                .Plot.Axis(VtChAxisIdX).Labels(1).Format = "hh:mm:ss"
                .Plot.UniformAxis = False
                .ChartType = VtChChartType2dXY
                .DrawMode = VtChDrawModeBlit
                .ChartData = arr
            End With
        End With
    End If
End Sub

ivccav

2.5 图表缩放

        图表缩放使用了2种技术，第一个示例使用了控件的MSChart1.Plot.LocationRect属性直接修改绘图区的矩形大小，缩放之后，按住鼠标可拖动图表查看。设置了3个功能：放大、缩小和还原，因此设置了几个变量保存原始设置。注意点是要保持绘图区的高宽比，避免在缩放过程中图形变形，还有就是LocationRect的坐标系是以图表控件的左上角为原点的。第二个示例是根据用户选中的数据点，获取其相邻的其他数据点数据，用另一个窗体显示出来，实现细节的展示。
        第一个缩放示例（附件窗体3）的完整代码如下，数据是散点图中的数据：

Private XVSMinDiv%, XVSMajDiv%
Private YVSMinDiv%, YVSMajDiv%
Private XCSDivPerTk%, XCSDivPerLb%

Private Sub CommandButton1_Click()
Dim AspectRatio!, PlotH!, PlotW!
Dim XIncrement!, YIncrement!, R!
With MSChart1
    .Plot.AutoLayout = False
    R = 0.2'一次缩放原大小的20%
    With .Plot.LocationRect
        PlotH = .Max.Y - .Min.Y
        PlotW = .Max.X - .Min.X
        AspectRatio = PlotH / PlotW '绘图区高宽比
        XIncrement = PlotW * R 'X轴增量
        YIncrement = (PlotW + XIncrement) * AspectRatio - PlotH 'Y轴增量
        .Min.Set .Min.X - XIncrement / 2, .Min.Y - YIncrement / 2
        .Max.Set .Max.X + XIncrement / 2, .Max.Y + YIncrement / 2
    End With
    If .ChartType = VtChChartType2dXY Then
        With .Plot.Axis(VtChAxisIdX).ValueScale
            .Auto = False
            .MajorDivision = Application.RoundUp(.MajorDivision * (1 + R), 0)
            .MinorDivision = 0
        End With
        .Plot.Axis(VtChAxisIdX).Labels(1).Format = "0.0"
    Else
        With .Plot.Axis(VtChAxisIdX).CategoryScale
            .Auto = False
            .DivisionsPerTick = Application.Max(Int(.DivisionsPerTick / (1 + R)), 1)
            .DivisionsPerLabel = .DivisionsPerTick
        End With
    End If
    With .Plot.Axis(VtChAxisIdY).ValueScale
        .Auto = False
        .MajorDivision = Application.RoundUp(.MajorDivision * (1 + R), 0)
        .MinorDivision = 0
    End With
    .Plot.Axis(VtChAxisIdY).Labels(1).Format = "0.0"
End With
End Sub

Private Sub CommandButton2_Click()
    With MSChart1
        .Plot.AutoLayout = True
        With .Plot.Axis(VtChAxisIdX).ValueScale
            .Auto = False
            .MajorDivision = XVSMajDiv
            .MinorDivision = XVSMinDiv
        End With
        With .Plot.Axis(VtChAxisIdX).CategoryScale
            .Auto = False
            .DivisionsPerLabel = XCSDivPerLb
            .DivisionsPerTick = XCSDivPerTk
        End With
        With .Plot.Axis(VtChAxisIdY).ValueScale
            .Auto = False
            .MajorDivision = YVSMajDiv
            .MinorDivision = YVSMinDiv
        End With
    End With
End Sub

Private Sub CommandButton3_Click()
Dim AspectRatio!, PlotH!, PlotW!
Dim XIncrement!, YIncrement!, R!
With MSChart1
    .Plot.AutoLayout = False
    R = 0.2
    With .Plot.LocationRect
        PlotH = .Max.Y - .Min.Y
        PlotW = .Max.X - .Min.X
        AspectRatio = PlotH / PlotW
        XIncrement = PlotW * R
        YIncrement = PlotH - (PlotW - XIncrement) * AspectRatio
        .Min.Set .Min.X + XIncrement / 2, .Min.Y + YIncrement / 2
        .Max.Set .Max.X - XIncrement / 2, .Max.Y - YIncrement / 2
    End With
    If .ChartType = VtChChartType2dXY Then
        With .Plot.Axis(VtChAxisIdX).ValueScale
            .Auto = False
            .MajorDivision = Application.Max(Int(.MajorDivision / (1 + R)), 1)
            .MinorDivision = 0
        End With
        .Plot.Axis(VtChAxisIdX).Labels(1).Format = "0.0"
    Else
        With .Plot.Axis(VtChAxisIdX).CategoryScale
            .Auto = False
            .DivisionsPerTick = Application.RoundUp(.DivisionsPerTick * (1 + R), 0)
            .DivisionsPerLabel = .DivisionsPerTick
        End With
    End If
    With .Plot.Axis(VtChAxisIdY).ValueScale
        .Auto = False
        .MajorDivision = Application.Max(Int(.MajorDivision / (1 + R)), 1)
        .MinorDivision = 0
    End With
    .Plot.Axis(VtChAxisIdY).Labels(1).Format = "0.0"
End With
End Sub

Private Sub UserForm_Initialize()
Dim arr()
arr = Range("a1:b200")
With MSChart1
    .TitleText = "变化趋势图"
    .Title.VtFont.VtColor.Blue = 255
    .Plot.Axis(VtChAxisIdX).AxisTitle.Text = "时间（单位：秒）"
    .Plot.SeriesCollection(1).Pen.Width = 20
    .Plot.SeriesCollection(1).Pen.style = VtPenStyleSolid
    With .Plot.Axis(VtChAxisIdX).ValueScale
        .Auto = False
        .Maximum = 10
        .Minimum = 0
        .MajorDivision = 6
        .MinorDivision = 0
        XVSMinDiv = .MinorDivision
        XVSMajDiv = .MajorDivision
    End With
    With .Plot.Axis(VtChAxisIdX).CategoryScale
        XCSDivPerTk = .DivisionsPerTick
        XCSDivPerLb = .DivisionsPerLabel
    End With
    With .Plot.Axis(VtChAxisIdY).ValueScale
        .Auto = False
        .Maximum = 400
        .Minimum = -800
        .MajorDivision = 12
        .MinorDivision = 0
        YVSMinDiv = .MinorDivision
        YVSMajDiv = .MajorDivision
    End With
    .Plot.Axis(VtChAxisIdX).AxisGrid.MajorPen.style = VtPenStyleDotted
    .Plot.Axis(VtChAxisIdY).AxisGrid.MajorPen.style = VtPenStyleDotted
    .Plot.UniformAxis = False
    .ChartType = VtChChartType2dXY
    .ChartData = arr
End With
End Sub

效果图：



第二个缩放示例（附件窗体2）完整代码如下，核心就是取得选中的数据点周围的数据：

Private Sub MSChart1_PointSelected(Series As Integer, DataPoint As Integer, MouseFlags As Integer, Cancel As Integer)
    Dim PartData(), XARR(), YARR()
    Dim XMAX!, XMIN!, YMAX!, YMIN!
    Dim pt%, i%, j%, k%

    With MSChart1
        If .rowCount < 7 Then Exit Sub
        ReDim PartData(5, .columnCount)
        Select Case DataPoint
            Case 1, 2
                pt = 1
            Case .rowCount - 1, .rowCount
                pt = .rowCount - 4
            Case Else
                pt = DataPoint - 2
        End Select
        For i = 0 To .columnCount
            PartData(0, i) = .ChartData(0, i) '列标签
        Next
        For i = pt To pt + 4
            k = k + 1
            PartData(k, 0) = .ChartData(i, 0) '行标签
            For j = 1 To .columnCount
                PartData(k, j) = .ChartData(i, j)
            Next
        Next
    End With

    XARR = Application.Index(PartData, 0, 2)
    XMAX = Application.Max(XARR)
    XMIN = Application.Min(XARR)
    YARR = Application.Index(PartData, 0, 3)
    YMAX = Application.Max(YARR)
    YMIN = Application.Min(YARR)
    With UserForm6.MSChart1
        .ChartType = MSChart1.ChartType
        .Plot.UniformAxis = False
        .ChartData = PartData
        With .Plot.Axis(VtChAxisIdX).ValueScale
            .Auto = False
            .Maximum = XMAX
            .Minimum = XMIN
            .MajorDivision = 10
            .MinorDivision = 2
        End With
        .Plot.Axis(VtChAxisIdX).Pen.VtColor.Red = 255
        With .Plot.Axis(VtChAxisIdY).ValueScale
            .Auto = False
            .Maximum = YMAX
            .Minimum = YMIN
            .MajorDivision = 10
            .MinorDivision = 2
        End With
    End With
    UserForm6.Show
End Sub

Private Sub UserForm_Initialize()
Dim arr()
arr = Range("a1:b200")
With MSChart1
    .TitleText = "变化趋势图"
    .Title.VtFont.VtColor.Blue = 255
    .Plot.Axis(VtChAxisIdX).AxisTitle.Text = "时间（单位：秒）"
    With .Plot.SeriesCollection(1)
        .Pen.Width = 20
        .SeriesMarker.Auto = False
        .SeriesMarker.Show = True
        .DataPoints(-1).Marker.style = VtMarkerStyle3dBall
        .DataPoints(-1).Marker.Size = 120
        .DataPoints(-1).Marker.FillColor.Set 0, 0, 100
    End With
    With .Plot.Axis(VtChAxisIdX).ValueScale
        .Auto = False
        .Maximum = 10
        .Minimum = 0
        .MajorDivision = 6
        .MinorDivision = 0
    End With
    With .Plot.Axis(VtChAxisIdY).ValueScale
        .Auto = False
        .Maximum = 400
        .Minimum = -800
        .MajorDivision = 12
        .MinorDivision = 0
    End With
    .AllowSeriesSelection = False
    .Plot.UniformAxis = False
    .ChartType = VtChChartType2dXY
    .ChartData = arr
End With
End Sub




如果觉得MSChart控件拖动鼠标体验不好，又苦于没有滚动条，可以把控件放到框架控件中，利用框架的滚动条。这里就不写代码了。

ivccav

2.6 图表保存和打印

        MSChart控件在保存图表和打印这方面基本是空白，唯一提供的方法是EditCopy 方法，该方法以 Windows 图元文件格式将当前图表的图片复制到剪贴板中，同时将创建图表使用的数据复制到剪贴板中。

（保存图表和打印在附件窗体20）

2.6.1 保存图表

        在VB6中要保存图表文件是非常容易的，用剪贴板对象Get数据：Clipboard.GetData，然后使用SavePicture函数就可以把图表保存到磁盘中。但在VBA中却很麻烦，因为VBA的剪贴板只支持文本，无法获取剪贴板上的图片数据。好在可用OLE技术（Object Linking and Embedding，对象连接与嵌入）。
保存为BMP格式，直接使用OleCreatePictureIndirect实现访问标准图片对象（stdPicture），使用的接口为IPicture，接口的GUID为："{7BF80980-BF32-101A-8BBB-00AA00300CAB}"。使用OleCreatePictureIndirectIPic得到的stdPicture对象可用SavePicture函数保存到磁盘，也可以直接赋值给PictureBox、Image等带有Picture属性的控件使用，而无需使用磁盘中转，然后用Loadpicture导入。

保存为BMP格式完全代码如下：

Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Long, pclsid As GUID) As Long
Private Const sIID_IPicture As String = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Private Const CF_BITMAP As Long = 2

Private Type PicBmp
    Size As Long
    type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Sub SaveClipToBMP(ByVal FileName As String)
    Dim Pic As PicBmp, IPic As IPicture
    Dim hBmp As Long, IID_IDispatch As GUID
    CLSIDFromString StrPtr(sIID_IPicture), IID_IDispatch
    If OpenClipboard(ByVal 0&) Then
        hBmp = GetClipboardData(CF_BITMAP)
        CloseClipboard
        If hBmp Then
            With Pic
                .Size = Len(Pic)
                .type = 1
                .hBmp = hBmp
            End With
            OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic
            SavePicture IPic, FileName
        End If
    End If
End Sub

保存为BMP格式时，文件非常大，可以考虑保存为JPG格式，虽然是损压缩，但文件大小可减小10倍以上。从BMP格式到JPG格式需要编解码，完整代码如下：

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal Format As Long) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Long, pclsid As GUID) As Long
Private Const CLSID_JPG As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private Const CF_BITMAP As Long = 2

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type

Private Type GdiplusStartupInput
   GdiplusVersion As Long
   DebugEventCallback As Long
   SuppressBackgroundThread As Long
   SuppressExternalCodecs As Long
End Type

Private Type EncoderParameter
   GUID As GUID
   NumberOfValues As Long
   type As Long
   value As Long
End Type

Private Type EncoderParameters
   count As Long
   Parameter As EncoderParameter
End Type

Sub SaveClipToJPG(ByVal FileName As String)
    Dim hMem As Long, BITMAP As Long
    Dim Quality As Long, lRet As Long
    Dim GDI_Token As Long
    Dim GpInput As GdiplusStartupInput
    Dim Params As EncoderParameters
    Dim JPGID As GUID, ECQID As GUID
    If OpenClipboard(ByVal 0&) = 0 Then Exit Sub
    hMem = GetClipboardData(CF_BITMAP)
    CloseClipboard
    If hMem = 0 Then Exit Sub
    GpInput.GdiplusVersion = 1
    lRet = GdiplusStartup(GDI_Token, GpInput)
    If lRet <> 0 Then Exit Sub
    GdipCreateBitmapFromHBITMAP hMem, 0, BITMAP
    CLSIDFromString StrPtr(EncoderQuality), ECQID
    Quality = 100
    With Params
        .count = 1
        With .Parameter
            .GUID = ECQID
            .NumberOfValues = 1
            .type = 4
            .value = VarPtr(Quality)
        End With
    End With
    CLSIDFromString StrPtr(CLSID_JPG), JPGID
    GdipSaveImageToFile BITMAP, StrPtr(FileName), JPGID, Params
    GdipDisposeImage BITMAP
    GdiplusShutdown GDI_Token
End Sub

这里只写了2种格式的保存代码，应该已经足够使用了。在窗体中用GetSaveAsFilename方法获得文件名和保存路径，根据文件名后缀判断保存为BMP还是JPG格式，代码如下：

Private Sub CommandButton1_Click()
    Dim InitName, FileFilter, FileName
    MSChart1.EditCopy
    InitName = Format(Now, "yyyy-mm-dd hhmmss") '预设文件名
    FileFilter = "JPG图片(*.jpg), *.jpg,BMP图片(*.bmp),*.bmp"
    FileName = Application.GetSaveAsFilename(InitName, FileFilter)
    If FileName <> False Then
        If UCase(Right(FileName, 3)) = "JPG" Then
            SaveClipToJPG FileName  '保存为JPG格式图片
        Else
            SaveClipToBMP FileName '保存为BMP格式图片
        End If
    End If
End Sub

除了把图表保存到磁盘上，还可以粘贴到EXCEL工作表指定位置。代码简单得多了：

Sub PasteToExcelPicture(ByVal pictruename As String)
    Dim Pic As Shape
    For Each Pic In ActiveSheet.Shapes
        If Pic.Name = pictruename Then Pic.Delete
    Next
    With ActiveSheet.Pictures.Paste
        .Name = pictruename
        .Placement = xlFreeFloating
        .ShapeRange.LockAspectRatio = msoTrue
        .Top = Range("a1").Top
        .Left = Range("a1").Left
        .Height = 400
    End With
End Sub

除了保存图表的图片，其实还可以保存图表的数据：ActiveSheet.Paste。

把图表保存到EXCEL工作表，在窗体中的代码如下：

Private Sub CommandButton3_Click()
    MSChart1.EditCopy
    PasteToExcelPicture "test" '图表粘贴到EXCEL
'    ActiveSheet.Paste '粘贴为数据
End Sub

2.6.2 打印图表

        在窗体上直接打印，用：Me.PrintForm，该方法还会打印窗体上的控件，因此打印前用代码隐藏一下不需要打印的控件。我一般是复制到EXCEL工作表中打印，可预览，可调节边界：

Private Sub CommandButton2_Click() '打印
'    Me.PrintForm
    Dim AspectRatio!, PlotH!, PlotW!
    MSChart1.EditCopy
    With MSChart1.Plot.LocationRect
        PlotH = .Max.Y - .Min.Y
        PlotW = .Max.X - .Min.X
        AspectRatio = PlotH / PlotW
    End With
    PasteToExcelPicture "test" '图表粘贴到EXCEL
    PrintPageSetup IIf(AspectRatio > 1, 1, 2)
    Me.Hide
    ActiveSheet.PrintOut Preview:=True
    Me.Show
End Sub

我先计算图表控件绘图区的高宽比，来自动决定横向还是纵向纸张，然后使用PrintPageSetup打印设置。PrintPageSetup过程的代码如下：

Sub PrintPageSetup(ByVal Orient As Long)
    With ActiveSheet.PageSetup
        .HeaderMargin = Application.InchesToPoints(0.1)
        .TopMargin = Application.InchesToPoints(0.12)
        .LeftMargin = Application.InchesToPoints(0.1)
        .RightMargin = Application.InchesToPoints(0.1)
        .BottomMargin = Application.InchesToPoints(0.12)
        .FooterMargin = Application.InchesToPoints(0.1)
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .CenterVertically = 1
        .CenterHorizontally = 1
        .Orientation = Orient '横向2;纵向1
    End With
End Sub

——END——

ivccav

yunfei2018 发表于 2019-1-22 16:18
窗体上，日期输入窗体，我咋没有找到是哪个窗体？也没有找到对应的代码了？想借鉴一下，望指点，谢谢！

MSChart是VB6自带的免费图表控件。VBA中使用，可用附件中的控件注册到系统。

ivccav

不知道为什么 发表于 2019-1-22 15:36
先抢个沙发，呵呵

你这个沙发抢得我措手不及，防不胜防

yunfei2018

ivccav 发表于 2019-1-22 16:46
MSChart是VB6自带的免费图表控件。VBA中使用，可用附件中的控件注册到系统。

我说的是这个：弹出的日期输入窗体

   

ivccav

yunfei2018 发表于 2019-1-22 17:22
我说的是这个：弹出的日期输入窗体

这个控件VBA中肯定有的啊。
可在窗体上使用，也可在EXCEL中。
没有的话，我复制一个我电脑上的给你：



DTP.zip (313.78 KB, 下载次数: 435)

2019-1-22 17:28 上传

点击文件名下载附件