vba - 为什么我的自定义形状无法在 PowerPoint 中正确填充？

Question

我正在尝试在代码中创建许多自选图形(不要问为什么......呵呵)。我正在使用 Open XML 提供的参数来重新创建它们，其中一些工作正常，比如创建一颗心。在某些情况下，我可以创建形状，但无法正确填充。

这是来自 DrawingML 的 FoldedCorner 形状的 XML:

  <foldedCorner>
    <avLst xmlns="http://schemas.openxmlformats.org/drawingml/2006/main">
      <gd name="adj" fmla="val 16667" />
    </avLst>
    <gdLst xmlns="http://schemas.openxmlformats.org/drawingml/2006/main">
      <gd name="a" fmla="pin 0 adj 50000" />
      <gd name="dy2" fmla="*/ ss a 100000" />
      <gd name="dy1" fmla="*/ dy2 1 5" />
      <gd name="x1" fmla="+- r 0 dy2" />
      <gd name="x2" fmla="+- x1 dy1 0" />
      <gd name="y2" fmla="+- b 0 dy2" />
      <gd name="y1" fmla="+- y2 dy1 0" />
    </gdLst>
    <ahLst xmlns="http://schemas.openxmlformats.org/drawingml/2006/main">
      <ahXY gdRefX="adj" minX="0" maxX="50000">
        <pos x="x1" y="b" />
      </ahXY>
    </ahLst>
    <cxnLst xmlns="http://schemas.openxmlformats.org/drawingml/2006/main">
      <cxn ang="3cd4">
        <pos x="hc" y="t" />
      </cxn>
      <cxn ang="cd2">
        <pos x="l" y="vc" />
      </cxn>
      <cxn ang="cd4">
        <pos x="hc" y="b" />
      </cxn>
      <cxn ang="0">
        <pos x="r" y="vc" />
      </cxn>
    </cxnLst>
    <rect l="l" t="t" r="r" b="y2" xmlns="http://schemas.openxmlformats.org/drawingml/2006/main" />
    <pathLst xmlns="http://schemas.openxmlformats.org/drawingml/2006/main">
      <path stroke="false" extrusionOk="false">
        <moveTo>
          <pt x="l" y="t" />
        </moveTo>
        <lnTo>
          <pt x="r" y="t" />
        </lnTo>
        <lnTo>
          <pt x="r" y="y2" />
        </lnTo>
        <lnTo>
          <pt x="x1" y="b" />
        </lnTo>
        <lnTo>
          <pt x="l" y="b" />
        </lnTo>
        <close />
      </path>
      <path stroke="false" fill="darkenLess" extrusionOk="false">
        <moveTo>
          <pt x="x1" y="b" />
        </moveTo>
        <lnTo>
          <pt x="x2" y="y1" />
        </lnTo>
        <lnTo>
          <pt x="r" y="y2" />
        </lnTo>
        <close />
      </path>
      <path fill="none" extrusionOk="false">
        <moveTo>
          <pt x="x1" y="b" />
        </moveTo>
        <lnTo>
          <pt x="x2" y="y1" />
        </lnTo>
        <lnTo>
          <pt x="r" y="y2" />
        </lnTo>
        <lnTo>
          <pt x="x1" y="b" />
        </lnTo>
        <lnTo>
          <pt x="l" y="b" />
        </lnTo>
        <lnTo>
          <pt x="l" y="t" />
        </lnTo>
        <lnTo>
          <pt x="r" y="t" />
        </lnTo>
        <lnTo>
          <pt x="r" y="y2" />
        </lnTo>
      </path>
    </pathLst>
  </foldedCorner>

这是我在 VBA 中重新创建它的方法:

Sub DrawFoldedCornerfromPresetShape()
    Dim w As Single
    Dim h As Single
    Dim adj As Single
    adj = 16667
    w = 200
    h = 200
    Dim L, T, r, B As Single
    L = 0: T = 0: r = w: B = h
    Dim a, DY2, DY1, x1, x2, y2, y1 As Single
    a = Pin(0, adj, 50000)
    DY2 = MultiplyDivide(Min(w, h), a, 100000)
    DY1 = MultiplyDivide(DY2, 1, 5)
    x1 = AddSubtract(r, 0, DY2)
    x2 = AddSubtract(x1, DY1, 0)
    y2 = AddSubtract(B, 0, DY2)
    y1 = AddSubtract(y2, DY1, 0)
    Dim sh2 As Shape

    With ActivePresentation.Slides(1).Shapes.BuildFreeform(msoEditingAuto, L, T)
        ''# this is the first in the path list
        .AddNodes msoSegmentLine, msoEditingAuto, r, T
        .AddNodes msoSegmentLine, msoEditingAuto, r, y2
        .AddNodes msoSegmentLine, msoEditingAuto, x1, B
        .AddNodes msoSegmentLine, msoEditingAuto, L, B
        ''# this is the second in the path list
        .AddNodes msoSegmentLine, msoEditingAuto, x1, B ''# moveto
        .AddNodes msoSegmentLine, msoEditingAuto, x2, y1
        .AddNodes msoSegmentLine, msoEditingAuto, r, y2
        ''# this is the Third in the path list
        .AddNodes msoSegmentLine, msoEditingAuto, x1, B ''# moveto
        .AddNodes msoSegmentLine, msoEditingAuto, x2, y1
        .AddNodes msoSegmentLine, msoEditingAuto, r, y2
        .AddNodes msoSegmentLine, msoEditingAuto, x1, B
        .AddNodes msoSegmentLine, msoEditingAuto, L, B
        .AddNodes msoSegmentLine, msoEditingAuto, L, T
        .AddNodes msoSegmentLine, msoEditingAuto, r, T
        .AddNodes msoSegmentLine, msoEditingAuto, r, y2
         Set sh2 = .ConvertToShape
    End With
End Sub
'used for fmla in Preset Autoshapes
Function Min(ByVal w As Single, ByVal h As Single) As Single
    If w < h Then Min = w Else Min = h
End Function
Function Pin(ByVal x As Single, ByVal y As Single, ByVal z As Single) As Single
    If (y < x) Then
        Pin = x
    ElseIf (y > z) Then
            Pin = z
    Else: Pin = y
    End If
End Function
Function MultiplyDivide(ByVal x As Single, ByVal y As Single, ByVal z As Single) As Single
    MultiplyDivide = ((x * y) / z)
End Function
Function AddSubtract(ByVal x As Single, ByVal y As Single, ByVal z As Single) As Single
    AddSubtract = ((x + y) - z)
End Function

它可以很好地创建轮廓(您可以复制/粘贴到 PowerPoint VBA 模块中来运行它)，但是当我尝试以编程方式或手动方式用颜色填充它时，它只填充了一半的形状。关于如何用颜色填充整个形状的任何想法？

Answer 1

删除最后一个 AddNode ,(这个:.AddNodes msoSegmentLine, msoEditingAuto, r, y2)。这对我行得通。