Access VBA向Word粘贴含6个及以上数据点Chart时报错4065问题咨询

我有一个搭载VBA的Access数据库，用途是为简单Chart对象填充系列数据，再将其粘贴到Word文档的表格中。当Chart对象的系列包含5个以上数据点时，粘贴操作会失败并抛出4065错误，错误提示为：This method or property is not available because the Clipboard is empty or not valid.

数据点数量≤5的Chart可以正常粘贴到Word表格中，业务要求Word中必须保留可编辑的Chart对象，不能使用图片格式，方便客户直接在Word中查看、编辑图表数据。

错误固定在执行Paste命令时触发，我初步判断可能的原因包括：

• Chart对象损坏
• Word表格目标单元格异常
• Paste或PasteSpecial命令使用不当
• 以上多个问题叠加
• 需使用Paste、PasteSpecial之外的方法向Word表格单元格添加图表

我在Paste调用前添加了On Error Resume Next语句可以跳过报错完成Word文档生成，但6个及以上数据点的Chart仍然无法正常粘贴。

已尝试的排查操作 #

• 检查了6个及以上数据点的Chart的Chart.ChartData.Workbook.ActiveSheet中的系列数据，数据完整无异常
• 在Copy操作后分别添加3秒、5秒延迟再执行DoEvents，无效果，仍只有≤5个数据点的Chart可以正常粘贴
• 核对了写入Chart的源数据，无格式、内容异常

正在进行的排查 #

• 尝试通过VBA调用API在粘贴后读取剪贴板内容，判断剪贴板中的Chart对象是否完整，确认问题是否出在Word表格单元格侧

现寻求该问题的解决方案或排查建议，以下是我的源代码和示例数据：

源代码 #

生成目标Word文档时使用另一个Word文档作为模板，模板文档的表格中包含10个簇状条形图（xlBarClustered），第1个模板图表含1个数据点的系列，第2个含2个数据点的系列，以此类推，第10个模板图表含10个数据点的系列。
模板图表将被加载到数组chtArray中：

' 该子过程用于初始化ChtArray，数组索引对应图表的数据行数量
'------------------------------------------------------------------------------------------
Sub InitCharts()

    Dim ProgCnt As Integer, ChrtCnt As Integer
    
    ProgCnt = 0
    ChrtCnt = 0

    ' 初始化一个引用数组，指向ChartTemplate.docx中的每个图表
    '----------------------------------------------------------------------------
    Do While ProgCnt < SrcDoc.InlineShapes.Count And ChrtCnt < MAXCHARTS
    
        ProgCnt = ProgCnt + 1
        
        If SrcDoc.InlineShapes(ProgCnt).Type = wdInlineShapeChart Then
        
            ChrtCnt = ChrtCnt + 1
            Set ChtArray(ChrtCnt) = SrcDoc.InlineShapes(ProgCnt).Chart
            
        End If
        
    Loop

End Sub

生成目标Word文档时，将从ChtArray中选取匹配数据点数量的模板图表副本，添加到目标文档中：

' 该子过程用于将图表和工作组百分比添加到表格中
'-------------------------------------------------------------
Sub AddChartsToTable(TblRowCnt)

    Dim TblRow As Integer, DesTblRowCnt As Integer, clipFormats As Integer
    Dim currentWorkGroup As Double
    
    currentWorkGroup = rstFiltered.Fields("Work Group").Value

    With tbl
    
        For TblRow = 3 To TblRowCnt ' 第1、2行是表头和列标题
            
                ' 工作组列的格式设置与赋值
                '--------------------------------------
            With .Cell(TblRow, 1).Range
            
                '========================================================
                ' 待办：移除Q和WG标识
                '========================================================
                .Text = Format(rstFiltered![WrkGrpPct].Value, "##0%") & _
                        " Q" & CStr(rstFiltered![QNum].Value) & _
                        " WG:" & CStr(rstFiltered.Fields("Work Group").Value)
                
                Select Case rstFiltered![WrkGrpPct].Value
                    Case Is >= 0.75
                    .Font.TextColor = ColorGreen
                    
                Case Is >= 0.6
                    .Font.TextColor = ColorGold
                    
                Case Else
                    .Font.TextColor = ColorRed
                    
                End Select
                
            End With
            
            currentWorkGroup = rstFiltered.Fields("Work Group").Value
            DesTblRowCnt = GetNumChtPoints(rstFiltered![Work Group])
          
            ' 引用需要更新的图表：SrcDoc中匹配数据行数量的图表
            '--------------------------------------------------
            If ChtArray(DesTblRowCnt) Is Nothing Then
                ' 待办：记录该异常实例
            Else
            
                Set Cht = ChtArray(DesTblRowCnt)
                ' Set Cht = NewChart()
                Set Pts = Cht.SeriesCollection(1).Points
                Set sht = Cht.ChartData.Workbook.ActiveSheet
               
                ' 赋值前检查图表系列
                InspectChartSeries
                                
                UpdateChartForWrkGrp DesTblRowCnt, TblRow
                
                ' 赋值后检查图表系列
                InspectChartSeries

                ' 复制图表对象到剪贴板，准备粘贴到Word表格
                Cht.Copy
                Pause 2
                                                              
                ' 检查剪贴板内容：确认复制操作是否将图表成功写入剪贴板
                
                
                On Error Resume Next
                .Cell(TblRow, 2).Range.PasteSpecial Link:=False, _
                                                    DataType:=wdPasteEnhancedMetafile, _
                                                    Placement:=wdInLine, _
                                                    DisplayAsIcon:=False
                
            End If
          
            If TblRow < TblRowCnt Then tbl.Rows.Add
          
        Next TblRow
    
  End With
  
End Sub 

UpdateChartForGrp方法用于为新增的Chart设置数据和每个条形的颜色：

' 该子过程用途为用对应数据点名称和颜色更新图表
' 由AddChartsToTable调用
'------------------------------------------------------------------------------------------
Sub UpdateChartForWrkGrp(TotChtPts As Integer, TblRow As Integer)

    Dim i As Integer
    Dim ptCount As Integer
       
    ' 更新图表本身的数据
    '-----------------------------
    For i = 2 To TotChtPts + 1
    
        sht.Range("A" & i) = rstFiltered!Department.Value
        sht.Range("B" & i) = rstFiltered![DeptPct].Value ' 图表模板单元格已经设置为百分比格式
        
        ' 更新图表的同时，将变更数据写入Word表格
        '---------------------------------------------------------------
        tbl.Cell(TblRow, 3).Range.InsertBefore rstFiltered!Change.Value & IIf(i = 2, "", vbCr)
        rstFiltered.MoveNext
        
    Next i
    
    Cht.Refresh
    
    ptCount = 0
      
    For Each Pt In Pts
    
        Select Case Val(Pt.DataLabel.Caption) / 100
            Case Is >= 0.75
                Pt.Interior.Color = ColorGreen
            Case Is >= 0.6
                Pt.Interior.Color = ColorGold
            Case Else
                Pt.Interior.Color = ColorRed
        End Select
        
        ptCount = ptCount + 1
        
    Next Pt
    
    Debug.Print "UpdateChartForWrkGrp:ptCount = " & ptCount
    
    Cht.Refresh ' 额外刷新一次确保变更生效
      
End Sub

示例数据 #

涉及的rstFiltered记录集数据如下：

内容的提问来源于stack exchange，提问作者Doug Kimzey