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 select格式数据点，然后转到填充和拉伸选项（仅在选择了图片填充时才可以），问题是可以解决的。问题是我的数据正在发生变化，我需要一种动态的方法将其实现到上面提到的代码中。有没有办法做到这一点？

我在这里引用此控制台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

VBA复制外观功能

1 个答案: