【问题标题】：How to get the RGB/Long values from PowerPoint color palette如何从 PowerPoint 调色板中获取 RGB/Long 值
【发布时间】：2014-02-04 05:39:01
【问题描述】：

我正在尝试（大部分成功）从活动ThemeColorScheme 中“读取”颜色。

下面的子程序将从主题中获取12种颜色，例如这是myAccent1：

我还需要从调色板中再获得 4 种颜色。我需要的四种颜色将是上面指示的颜色正下方的一种，然后是从左到右的接下来的三种颜色。

因为 ThemeColorScheme 对象仅包含 12 个项目，所以如果我尝试以这种方式为 myAccent9 分配值，我会得到 The specified value is out of range 错误，正如预期的那样。我理解这个错误以及它发生的原因。我不知道如何从调色板访问其他 40 多种颜色，它们不属于 ThemeColorScheme 对象？

Private Sub ColorOverride()

Dim pres As Presentation
Dim thm As OfficeTheme
Dim themeColor As themeColor
Dim schemeColors As ThemeColorScheme

Set pres = ActivePresentation

Set schemeColors = pres.Designs(1).SlideMaster.Theme.ThemeColorScheme

    myDark1 = schemeColors(1).RGB         'msoThemeColorDark1
    myLight1 = schemeColors(2).RGB        'msoThemeColorLight
    myDark2 = schemeColors(3).RGB         'msoThemeColorDark2
    myLight2 = schemeColors(4).RGB        'msoThemeColorLight2
    myAccent1 = schemeColors(5).RGB       'msoThemeColorAccent1
    myAccent2 = schemeColors(6).RGB       'msoThemeColorAccent2
    myAccent3 = schemeColors(7).RGB       'msoThemeColorAccent3
    myAccent4 = schemeColors(8).RGB       'msoThemeColorAccent4
    myAccent5 = schemeColors(9).RGB       'msoThemeColorAccent5
    myAccent6 = schemeColors(10).RGB      'msoThemeColorAccent6
    myAccent7 = schemeColors(11).RGB      'msoThemeColorThemeHyperlink
    myAccent8 = schemeColors(12).RGB      'msoThemeColorFollowedHyperlink

    '## THESE LINES RAISE AN ERROR, AS EXPECTED:

    'myAccent9 = schemeColors(13).RGB     
    'myAccent10 = schemeColors(14).RGB
    'myAccent11 = schemeColors(15).RGB
    'myAccent12 = schemeColors(16).RGB

End Sub

所以我的问题是，如何从调色板/主题中获取这些颜色的 RGB 值？

【问题讨论】：

This article 包含大量有关在 Word 中执行此操作的信息。我查看了它，因为这个问题是一个很好的问题，但我没有时间弄清楚将其转换为 PPT 的所有细节 - 不过可能是一个很好的参考。看起来附加的主题颜色实际上是主主题颜色上 TintAndShade 的变体。
@enderland 它们是使用TintAndShade 属性的变体，如果需要，我会采取这种方式......虽然最初听起来像 PITA，但我认为这可能是最简单的方法尽量不影响用户使用 PPT 的体验。

标签： vba powerpoint

【解决方案1】：

乍一看，Floris' solution 似乎可行，但如果您关心准确性，您很快就会意识到，以前的解决方案只匹配办公室颜色计算的一小部分颜色空间。

正确的解决方案 - 使用 HSL 色彩空间

Office 似乎在计算着色和阴影时使用HSL color 模式，并且使用这种技术可以为我们提供几乎 100% 准确的颜色计算（在 Office 2013 上测试）。

正确计算值的方法似乎是：

将基本 RGB 颜色转换为 HSL
查找用于五种子颜色的色调和明暗度值
应用色调/阴影值
从 HSL 转换回 RGB 颜色空间

要查找色调/阴影值（第 3 步），请查看 HSL 颜色的 Luminosity-value 并使用此表（通过反复试验找到）：

| [0.0] | <0.0 - 0.2> | [0.2 - 0.8] | <0.8 - 1.0> | [1.0] |
|:-----:|:-----------:|:-----------:|:-----------:|:-----:|
| + .50 |    + .90    |    + .80    |    - .10    | - .05 |
| + .35 |    + .75    |    + .60    |    - .25    | - .15 |
| + .25 |    + .50    |    + .40    |    - .50    | - .25 |
| + .10 |    + .25    |    - .25    |    - .75    | - .35 |
| + .05 |    + .10    |    - .50    |    - .90    | - .50 |

正值使颜色着色（使其更亮），负值使颜色变暗（使其更暗）。有五组； 1组全黑，1组全白。这些将只匹配这些特定值（而不是例如RGB = {255, 255, _254_}）。然后是两个小范围的非常深和非常浅的颜色，分别处理，最后是所有其余颜色的大范围。

注意：+0.40 的值意味着该值将变亮 40%，而不是原始颜色的 40% 色调（实际上意味着它变亮了 60%）。这可能会让某些人感到困惑，但这是 Office 在内部使用这些值的方式（即在 Excel 中通过Cell.Interior 的TintAndShade 属性）。

实现解决方案的PowerPoint VBA代码

[免责声明]：我在 Floris 的解决方案的基础上创建了这个 VBA。很多HSL翻译代码也是从Word article mentioned in the comments复制过来的。

以下代码的输出是以下颜色变化：

乍一看，这看起来与 Floris 的解决方案非常相似，但仔细观察后，您可以清楚地看到许多情况下的差异。 Office 主题颜色（以及因此的解决方案）通常比普通的 RGB 变亮/变暗技术更加饱和。

Option Explicit

Public Type HSL
    h As Double ' Range 0 - 1
    S As Double ' Range 0 - 1
    L As Double ' Range 0 - 1
End Type

Public Type RGB
    R As Byte
    G As Byte
    B As Byte
End Type

Sub CalcColor()
    Dim ii As Integer, jj As Integer
    Dim pres As Presentation
    Dim schemeColors As ThemeColorScheme
    Dim ts As Double
    Dim c, c2 As Long
    Dim hc As HSL, hc2 As HSL

    Set pres = ActivePresentation
    Set schemeColors = pres.Designs(1).SlideMaster.Theme.ThemeColorScheme

    ' For all colors
    For ii = 0 To 11
      c = schemeColors(ii + 1).RGB

      ' Generate all the color variations
      For jj = 0 To 5
        hc = RGBtoHSL(c)
        ts = SelectTintOrShade(hc, jj)
        hc2 = ApplyTintAndShade(hc, ts)
        c2 = HSLtoRGB(hc2)
        Call CreateShape(pres.Slides(1), ii, jj, c2)
      Next jj
    Next ii

End Sub

' The tint and shade value is a value between -1.0 and 1.0, where
' -1.0 means fully shading (black), and 1.0 means fully tinting (white)
' A tint/shade value of 0.0 will not change the color
Public Function SelectTintOrShade(hc As HSL, variationIndex As Integer) As Double

    Dim shades(5) As Variant
    shades(0) = Array(0#, 0.5, 0.35, 0.25, 0.15, 0.05)
    shades(1) = Array(0#, 0.9, 0.75, 0.5, 0.25, 0.1)
    shades(2) = Array(0#, 0.8, 0.6, 0.4, -0.25, -0.5)
    shades(3) = Array(0#, -0.1, -0.25, -0.5, -0.75, -0.9)
    shades(4) = Array(0#, -0.05, -0.15, -0.25, -0.35, -0.5)

    Select Case hc.L
        Case Is < 0.001: SelectTintOrShade = shades(0)(variationIndex)
        Case Is < 0.2:   SelectTintOrShade = shades(1)(variationIndex)
        Case Is < 0.8:   SelectTintOrShade = shades(2)(variationIndex)
        Case Is < 0.999: SelectTintOrShade = shades(3)(variationIndex)
        Case Else:       SelectTintOrShade = shades(4)(variationIndex)
    End Select
End Function

Public Function ApplyTintAndShade(hc As HSL, TintAndShade As Double) As HSL

    If TintAndShade > 0 Then
        hc.L = hc.L + (1 - hc.L) * TintAndShade
    Else
        hc.L = hc.L + hc.L * TintAndShade
    End If

    ApplyTintAndShade = hc

End Function

Sub CreateShape(slide As slide, xIndex As Integer, yIndex As Integer, color As Long)

    Dim newShape As Shape
    Dim xStart As Integer, yStart As Integer
    Dim xOffset As Integer, yOffset As Integer
    Dim xSize As Integer, ySize As Integer
    xStart = 100
    yStart = 100
    xOffset = 30
    yOffset = 30
    xSize = 25
    ySize = 25

    Set newShape = slide.Shapes.AddShape(msoShapeRectangle, xStart + xOffset * xIndex, yStart + yOffset * yIndex, xSize, ySize)
    newShape.Fill.BackColor.RGB = color
    newShape.Fill.ForeColor.RGB = color
    newShape.Line.ForeColor.RGB = 0
    newShape.Line.BackColor.RGB = 0

End Sub

' From RGB to HSL

Function RGBtoHSL(ByVal RGB As Long) As HSL

    Dim R As Double ' Range 0 - 1
    Dim G As Double ' Range 0 - 1
    Dim B As Double ' Range 0 - 1

    Dim RGB_Max  As Double
    Dim RGB_Min  As Double
    Dim RGB_Diff As Double

    Dim HexString As String

    HexString = Right$(String$(7, "0") & Hex$(RGB), 8)
    R = CDbl("&H" & Mid$(HexString, 7, 2)) / 255
    G = CDbl("&H" & Mid$(HexString, 5, 2)) / 255
    B = CDbl("&H" & Mid$(HexString, 3, 2)) / 255

    RGB_Max = R
    If G > RGB_Max Then RGB_Max = G
    If B > RGB_Max Then RGB_Max = B

    RGB_Min = R
    If G < RGB_Min Then RGB_Min = G
    If B < RGB_Min Then RGB_Min = B

    RGB_Diff = RGB_Max - RGB_Min

    With RGBtoHSL

        .L = (RGB_Max + RGB_Min) / 2

        If RGB_Diff = 0 Then

            .S = 0
            .h = 0

        Else

            Select Case RGB_Max
                Case R: .h = (1 / 6) * (G - B) / RGB_Diff - (B > G)
                Case G: .h = (1 / 6) * (B - R) / RGB_Diff + (1 / 3)
                Case B: .h = (1 / 6) * (R - G) / RGB_Diff + (2 / 3)
            End Select

            Select Case .L
                Case Is < 0.5: .S = RGB_Diff / (2 * .L)
                Case Else:     .S = RGB_Diff / (2 - (2 * .L))
            End Select

        End If

    End With

End Function

' .. and back again

Function HSLtoRGB(ByRef HSL As HSL) As Long

    Dim R As Double
    Dim G As Double
    Dim B As Double

    Dim X As Double
    Dim Y As Double

    With HSL

        If .S = 0 Then

            R = .L
            G = .L
            B = .L

        Else

            Select Case .L
                Case Is < 0.5: X = .L * (1 + .S)
                Case Else:     X = .L + .S - (.L * .S)
            End Select

            Y = 2 * .L - X

            R = H2C(X, Y, IIf(.h > 2 / 3, .h - 2 / 3, .h + 1 / 3))
            G = H2C(X, Y, .h)
            B = H2C(X, Y, IIf(.h < 1 / 3, .h + 2 / 3, .h - 1 / 3))

        End If

    End With

    HSLtoRGB = CLng("&H00" & _
                    Right$("0" & Hex$(Round(B * 255)), 2) & _
                    Right$("0" & Hex$(Round(G * 255)), 2) & _
                    Right$("0" & Hex$(Round(R * 255)), 2))

End Function

Function H2C(X As Double, Y As Double, hc As Double) As Double

    Select Case hc
        Case Is < 1 / 6: H2C = Y + ((X - Y) * 6 * hc)
        Case Is < 1 / 2: H2C = X
        Case Is < 2 / 3: H2C = Y + ((X - Y) * ((2 / 3) - hc) * 6)
        Case Else:       H2C = Y
    End Select

End Function

【讨论】：

非常好。 Office 2010 有可能与 2013 有不同的调色板......在这里有这个解决方案很好 - 感谢发布它！
是的，他们为 Office 2013 添加了新的颜色主题。可以看到 here。
差异不是由于新的颜色主题。颜色主题仅更改基色。这是关于根据基色计算不同的变化。您可以像 Floris 那样在 RGB 颜色空间中做到这一点，在许多情况下都取得了不错的效果，但肯定不是全部。或者您可以使用此答案中所示的 HSL 颜色空间进行计算，与 Office 的计算相比，这将完美复制变体颜色。这在 Office 2010 和 2013 中都是一样的（我猜在 2007 年也是如此，但我还没有机会尝试）。
没错，我没有在阅读弗洛里斯的评论时考虑到他所问的全部内容。仅供参考，2007 年和 2010 年共享相同的默认主题。

【解决方案2】：

如果您使用 VBA for excel，您可以记录您的击键。选择另一种颜色（从主题下方）显示：

    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorLight2
    .TintAndShade = 0.599993896298105
    .PatternTintAndShade = 0

.TintAndShade 因子修改定义的颜色。主题中的不同颜色对.TintAndShade 使用不同的值 - 有时数字是负数（使浅色更暗）。

.TintAndShade的不完整表格（对于我在Excel中碰巧有的主题，前两种颜色）：

 0.00  0.00
-0.05  0.50
-0.15  0.35
-0.25  0.25
-0.35  0.15
-0.50  0.05

编辑一些“或多或少”进行转换的代码 - 您需要确保 shades 中的值正确，否则颜色转换似乎可以工作

更新为纯 PowerPoint 代码，最后显示输出

Option Explicit

Sub calcColor()
Dim ii As Integer, jj As Integer
Dim pres As Presentation
Dim thm As OfficeTheme
Dim themeColor As themeColor
Dim schemeColors As ThemeColorScheme
Dim shade
Dim shades(12) As Variant
Dim c, c2 As Long
Dim newShape As Shape

Set pres = ActivePresentation
Set schemeColors = pres.Designs(1).SlideMaster.Theme.ThemeColorScheme
shades(0) = Array(0, -0.05, -0.15, -0.25, -0.35, -0.5)
shades(1) = Array(0, 0.05, 0.15, 0.25, 0.35, 0.5)
shades(2) = Array(-0.1, -0.25, -0.5, -0.75, -0.9)
For ii = 3 To 11
  shades(ii) = Array(-0.8, -0.6, -0.4, 0.25, 0.5)
Next

For ii = 0 To 11
  c = schemeColors(ii + 1).RGB
  For jj = 0 To 4
    c2 = fadeRGB(c, shades(ii)(jj))
    Set newShape = pres.Slides(1).Shapes.AddShape(msoShapeRectangle, 200 + 30 * ii, 200 + 30 * jj, 25, 25)
    newShape.Fill.BackColor.RGB = c2
    newShape.Fill.ForeColor.RGB = c2
    newShape.Line.ForeColor.RGB = 0
    newShape.Line.BackColor.RGB = 0
  Next jj
Next ii

End Sub

Function fadeRGB(ByVal c, s) As Long
Dim r, ii
r = toRGB(c)
For ii = 0 To 2
  If s < 0 Then
    r(ii) = Int((r(ii) - 255) * s + r(ii))
  Else
    r(ii) = Int(r(ii) * (1 - s))
  End If
Next ii
fadeRGB = r(0) + 256& * (r(1) + 256& * r(2))

End Function

Function toRGB(c)
Dim retval(3), ii

For ii = 0 To 2
  retval(ii) = c Mod 256
  c = (c - retval(ii)) / 256
Next

toRGB = retval

End Function

【讨论】：

以上提供了.ThemeColorIndex 和TintAndShade 因子。我需要获取此颜色的唯一 long/RGB 值。
@DavidZemens - 我相信“子颜色”与主题颜色相同，但饱和度不同。我想如果 RGB 值是你需要的，你可以自己计算 RGB。我会做一个实验然后回复你。
我相信你是对的。我找不到任何现成的公式或函数可以根据饱和度/色调因子进行转换。
我已经用计算更新了我的答案（涉及到一些猜测，但结果看起来很有说服力）。函数toRGB 将long 转换为三个字节的数组； fadeRGB 采用颜色和“淡化因子”，并相应地修改颜色。
MS 的文档令人困惑。有些东西，它真的很好。其他的，几乎不存在。我想我最终将重新编写现有代码以使用.ObjectThemeColor 而不是.RGB。对我来说有更多的工作（我试图避免这个问题！），但对于最终用户来说会更直观和更好。

【解决方案3】：

基于上述带有 HSL 值的解决方案，在此处添加了一个可在 Excel 中运行的演示。与上面列出的 HSL 解决方案结合使用。

Sub DemoExcelThemecolorsHSL()
   Dim rng As Range
   Dim n As Integer, m As Integer
   Dim arrNames
   Dim arrDescriptions
   Dim arrValues
   Dim schemeColors As ThemeColorScheme
   Dim dblTintShade As Double
   Dim lngColorRGB As Long, lngColorRGBshaded As Long
   Dim ColorHSL As HSL, ColorHSLshaded As HSL

   Set schemeColors = ActiveWorkbook.Theme.ThemeColorScheme

   arrNames = Array("xlThemeColorDark1", "xlThemeColorLight1", "xlThemeColorDark2", "xlThemeColorLight2", "xlThemeColorAccent1", "xlThemeColorAccent2", _
                    "xlThemeColorAccent3", "xlThemeColorAccent4", "xlThemeColorAccent5", "xlThemeColorAccent6", "xlThemeColorHyperlink", "xlThemeColorFollowedHyperlink")
   arrDescriptions = Array("Dark1", "Light1", "Dark2", "Light2", "Accent1", "Accent2", "Accent3", "Accent4", "Accent5", "Accent6", "Hyperlink", "Followed hyperlink")
   arrValues = Array(2, 1, 4, 3, 5, 6, 7, 8, 9, 10, 11, 12)

   ' New sheet, title row
   ActiveWorkbook.Worksheets.Add
   Set rng = Cells(1, 2)
   rng(1, 1).Value2 = "ThemeColor Name"
   rng(1, 2).Value2 = "Value"
   rng(1, 3).Value2 = "Description"
   rng(1, 4).Value2 = "TintAndShade"
   rng.Resize(1, 4).Font.Bold = True

   Set rng = rng(3, 1)
   ' color matrix
   For n = 0 To 11
      rng(n * 2, 1).Value = arrNames(n)
      rng(n * 2, 2).Value = arrValues(n)
      rng(n * 2, 3).Value = arrDescriptions(n)

      lngColorRGB = schemeColors(n + 1).RGB
      For m = 0 To 5
         ColorHSL = RGBtoHSL(lngColorRGB)
         dblTintShade = SelectTintOrShade(ColorHSL, m)
         ColorHSLshaded = ApplyTintAndShade(ColorHSL, dblTintShade)
         lngColorRGBshaded = HSLtoRGB(ColorHSLshaded)

         With rng(n * 2, m + 4)
            .Value = dblTintShade
            If ColorHSLshaded.L < 0.5 Then .Font.ColorIndex = 2

            ' fixed color, not changing when a new Color scheme is being selected
            .Interior.color = lngColorRGBshaded

            ' cell color dependent on selected color palette
            .Offset(1, 0).Interior.ThemeColor = arrValues(n)
            .Offset(1, 0).Interior.TintAndShade = dblTintShade

         End With
      Next m
   Next n
   rng.Resize(1, 3).EntireColumn.AutoFit

End Sub

【讨论】：