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

Question

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

6

我正在尝试（大多数情况下成功地）从活动的ThemeColorScheme中“读取”颜色。

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

我还需要从调色板中获取4种颜色。我需要的四种颜色是上面指示的颜色的下方紧接着的一种颜色，然后是从左到右的下3种颜色。

因为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值？

- David Zemens

1

这篇文章包含了关于在Word中执行此操作的大量信息。由于这个问题很棒，但我没有时间去弄清楚如何将其转换为PPT，所以我仔细研究了一下它 - 可能是一个很好的参考。看起来，其他主题颜色实际上是主题颜色的TintAndShade变化。 - enderland

1

@enderland，它们是使用“TintAndShade”属性的变体，如果需要的话，我会采取这种方法...虽然最初听起来很麻烦，但我认为这可能是最容易的方法，对用户在PPT中的体验干扰最小。 - David Zemens

3个回答

3

如果您使用Excel的VBA，您可以录制按键操作。从主题以下选择另一种颜色将显示：

    .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

enter image description here

- Floris

以上提供了.ThemeColorIndex和TintAndShade因子。我需要获取此颜色的唯一长/RGB值。 - David Zemens

@DavidZemens - 我认为“subcolors”是与主题颜色相同的颜色，但饱和度不同。如果您需要RGB值，我想您可以从中自己计算RGB。我会进行实验并回复您。 - Floris

我相信你是正确的。我找不到任何现成的公式或函数，可以根据饱和度/色调因子进行转换。 - David Zemens

我已经更新了我的答案，并进行了计算（有点猜测，但结果对我来说看起来很令人信服）。函数 toRGB 将 long 转换为三个字节的数组；fadeRGB 接受颜色和“褪色因子”，并相应地修改颜色。 - Floris

2

微软的文档令人困惑。有些东西，它真的很好。另一些则几乎不存在。我认为最终我会重新编写现有代码，使用 .ObjectThemeColor 而不是 .RGB。这对我来说更加劳心（这正是我想通过这个问题避免的！），但对最终用户来说更加直观和更好。 - David Zemens

显示剩余3条评论

0

基于上述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

- user3279536

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- Gedde · Accepted Answer

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

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

办公室似乎在计算调色和阴影时使用HSL颜色模式，使用这种技术可以给我们几乎100%准确的颜色计算（在Office 2013上测试）。

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

将基本RGB颜色转换为HSL
找到要用于五个子颜色的色调和阴影值
应用色调/阴影值
从HSL转换回RGB颜色空间

要查找色调/阴影值（步骤＃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 |

正值会使颜色变浅（增加色调），负值会使颜色变暗（减少色调）。共有五组；一组完全是黑色，一组完全是白色。它们只匹配这些特定的值（而不是例如RGB = {255, 255, _254_}）。然后是两个小范围的非常暗和非常浅的颜色，它们被单独处理，最后是一个大范围的其余所有颜色。

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

PowerPoint VBA代码来实现解决方案

[免责声明]：我在Floris的解决方案基础上构建了这个VBA。很多HSL转换代码也是从评论中提到的Word文章中复制的。

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

Program output, calculated color variations

乍一看，这似乎与Floris的解决方案非常相似，但仔细检查后，您可以清楚地看到在许多情况下存在差异。办公室主题颜色（因此这个解决方案）通常比纯RGB亮度调整技术更饱和。

Comparison of the different solutions. This matches office very well!

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