VBA复制外观功能

Question

以下代码用于创建气泡饼图（饼图为气泡的气泡图）。它递归地将饼图复制到气泡图中。我的问题是，使用这种方法，最终的饼图看起来有点椭圆——不是真的圆。我怀疑的一个问题与某种格式有关。

Sub PieMarkers()

Dim chtMarker As Chart
Dim chtMain As Chart
Dim intPoint As Integer
Dim rngRow As Range
Dim lngPointIndex As Long
Dim thmColor As Long
Dim myTheme As String


Application.ScreenUpdating = False
Set chtMarker = ActiveSheet.ChartObjects("chtMarker").Chart
Set chtMain = ActiveSheet.ChartObjects("chtMain").Chart

Set chtMain = ActiveSheet.ChartObjects("chtMain").Chart
Set rngRow = Range(ThisWorkbook.Names("PieChartValues").RefersTo)

For Each rngRow In Range("PieChartValues").Rows
    chtMarker.SeriesCollection(1).Values = rngRow
    ThisWorkbook.Theme.ThemeColorScheme.Load GetColorScheme(thmColor)
    chtMarker.Parent.CopyPicture xlScreen, xlPicture
    lngPointIndex = lngPointIndex + 1
    chtMain.SeriesCollection(1).Points(lngPointIndex).Paste
    thmColor = thmColor + 1
Next

lngPointIndex = 0

Application.ScreenUpdating = True
End Sub

Function GetColorScheme(i As Long) As String
Const thmColor1 As String = "C:\Program Files\Microsoft Office\Document Themes 15\Theme Colors\Blue Green.xml"
Const thmColor2 As String = "C:\Program Files\Microsoft Office\Document Themes 15\Theme Colors\Orange Red.xml"
    Select Case i Mod 2
        Case 0
            GetColorScheme = thmColor1
        Case 1
            GetColorScheme = thmColor2
    End Select
End Function

我发现如果双击特定的ubble选择格式数据点然后进入填充和拉伸选项（仅在选择图片填充时才可能），问题是可以解决的。问题是我的数据正在发生变化，我需要一种动态的方式将其实现到上述代码中。有没有办法做到这一点？

我这里指的是这个控制台http://s1.directupload.net/file/d/3300/7dlimc3g_png.htm

Answer 1

我认为如果您的饼图不是一个完美的方形，这可能是问题所在。我可以复制您的问题，即使我检查填充选项，偏移量都是0%。我可以调整它们，但这不是一种可靠的方法。所以，我认为最好的选择是确保您的饼图.Parent 是方形的。为此，在您 CopyPicture 之前，将其 Height 设置为等于其 Width，如下所示：

chtMarker.Parent.Height = chtMarker.Parent.Width  '## Ensure the chartObject is a square, so it will not be distorted when pasted.
chtMarker.Parent.CopyPicture xlScreen, xlPicture