vba 如何从 PowerPoint 调色板中获取 RGB/Long 值

How to get the RGB/Long values from PowerPoint color palette

提问by David Zemens

I am trying (mostly successfully) to "read" the colors from the active ThemeColorScheme.

我正在尝试（大部分成功）从活动的ThemeColorScheme.

The subroutine below will obtain 12 colors from the theme, for example this is myAccent1:

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

I need also to obtain 4 more colors from the palette. The four colors I need will be the one immediately below the color indicated above, and then the next 3 colors from left-to-right.

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

Because the ThemeColorSchemeobject holds 12 items only I get The specified value is out of rangeerror, as expected if I try to assign a value to myAccent9this way. I understand this error and why it occurs. What I do not know is how to access the other 40-odd colors from the palette, which are not part of the ThemeColorSchemeobject?

因为ThemeColorScheme对象只包含 12 个项目The specified value is out of range，所以如果我尝试以myAccent9这种方式分配一个值，我会得到错误，正如预期的那样。我了解此错误及其发生原因。我不知道的是如何从调色板访问其他 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

So my question is, how might I obtain the RGB value of these colors from the palette/theme?

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

采纳答案by Floris

If you use VBA for excel, you can record your keystrokes. Selecting another color (from below the theme) shows:

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

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

The .TintAndShadefactor modifies the defined color. Different colors in the theme use different values for .TintAndShade- sometimes the numbers are negative (to make light colors darker).

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

Incomplete table of .TintAndShade(for the theme I happened to have in Excel, first two colors):

不完整的表格.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

EDITsome code that "more or less" does the conversion - you need to make sure that you have the right values in your shades, but otherwise the conversion of colors seems to work

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

updated to be pure PowerPoint code, with output shown at the end

更新为纯 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

回答by Gedde

At first sight Floris' solutionseems to work, but if you're concerned with accuracy you'll soon realize that the previous solution matches the office color calculations for just a minor part of the color space.

乍一看，Floris 的解决方案似乎有效，但如果您关心准确性，您很快就会意识到先前的解决方案仅与色彩空间的一小部分的办公室颜色计算相匹配。

A Proper solution - Using HSL color space

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

Office seems to use HSL colormode while calculating tinting and shading, and using this technique gives us almost 100% accurate color calculations (tested on Office 2013).

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

The methodology for calculating the values correctly seems to be:

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

1. Convert the base RGB color to HSL
2. Find the tint and shade values to use for the five sub-colors
3. Apply tint/shade values
4. Convert back from HSL to RGB color space

1. 将基本 RGB 颜色转换为 HSL
2. 找到用于五种子颜色的色调和阴影值
3. 应用色调/阴影值
4. 从 HSL 转换回 RGB 色彩空间

To find the tint/shade values (step #3), you look at the Luminosity-value of the HSL color and uses this table (found by trial & error):

要找到色调/阴影值（第 3 步），您可以查看 HSL 颜色的亮度值并使用此表（通过反复试验找到）：

| [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 |

Positive values are tinting the color (making it lighter), and negative values are shading the color (making it darker). There are five groups; 1 group for completely black and 1 group for completely white. These will just match these specific values (and not e.g. RGB = {255, 255, _254_}). Then there are two small ranges of very dark and very light colors that are treated separately, and finally a big range for all of the rest colors.

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

Note: A value of +0.40 means that the value will get 40% lighter, not that it is a 40% tint of the original color (which actually means that it is 60% lighter). This might be confusing to someone, but this is the way Office uses these values internally (i.e. in Excel through the TintAndShadeproperty of the Cell.Interior).

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

PowerPoint VBA code to implement the solution

PowerPoint VBA代码实现解决方案

[Disclaimer]:I've built upon Floris' solution to create this VBA. A lot of the HSL translation code is also copied from a Word article mentioned in the commentsalready.

[免责声明]：我基于 Floris 的解决方案来创建此 VBA。很多 HSL 翻译代码也是从评论中提到的Word 文章中复制而来的。

The output from the code below is the following color variations:

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

At first glance, this looks very similar to Floris' solution, but on closer inspection you can clearly see the difference in many situations. Office theme colors (and thus this solution) is generally more saturated the the plain RGB lighten/darken technique.

乍一看，这与 Floris 的解决方案非常相似，但仔细观察后，您可以清楚地看到许多情况下的差异。办公室主题颜色（以及此解决方案）通常比普通的 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