526互联

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

发布时间 2023-08-30 10:25:30作者: 多见多闻

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

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

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

因为该ThemeColorScheme对象仅包含12个项目The specified value is out of range，所以如果我尝试myAccent9以此方式分配值，则会出现错误，这与预期的一样。我了解此错误以及为什么会发生。我不知道该如何访问调色板中不属于ThemeColorScheme对象的其他40多种颜色？

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

Office 主题颜色（因此此解决方案）通常比普通 RGB 变亮/变暗技术更饱和。

用于实施该解决方案的 PowerPoint VBA 代码

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

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

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 不同。

”这些差异并不是由于新的颜色主题造成的。颜色主题仅更改基色。这是关于根据基色计算不同的变化。您可以像 Floris 那样在 RGB 色彩空间中做到这一点，在许多情况下都能获得相当好的结果，但绝对不是全部。或者，您可以使用 HSL 颜色空间进行计算，如本答案所示，与 Office 的计算相比，这将完美复制变化颜色。这在 Office 2010 和 2013 中都是一样的（我猜 2007 年也是如此，但我还没有机会尝试）。“

如果您使用 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

C#代码

using PowerPoint = Microsoft.Office.Interop.PowerPoint;
using Office = Microsoft.Office.Core;

public class ColorCalculator
{
    public void CalcColor()
    {
        PowerPoint.Presentation pres = Globals.ThisAddIn.Application.ActivePresentation;
        Office.ThemeColorScheme schemeColors = pres.Designs[1].SlideMaster.Theme.ThemeColorScheme;

        double[][] shades = new double[12][]
        {
            new double[] { 0, -0.05, -0.15, -0.25, -0.35, -0.5 },
            new double[] { 0, 0.05, 0.15, 0.25, 0.35, 0.5 },
            new double[] { -0.1, -0.25, -0.5, -0.75, -0.9 }
        };

        for (int ii = 3; ii < 12; ii++)
        {
            shades[ii] = new double[] { -0.8, -0.6, -0.4, 0.25, 0.5 };
        }

        for (int ii = 0; ii < 12; ii++)
        {
            int c = schemeColors.Colors[ii + 1].RGB;
            for (int jj = 0; jj < 5; jj++)
            {
                int c2 = FadeRGB(c, shades[ii][jj]);
                PowerPoint.Shape newShape = pres.Slides[1].Shapes.AddShape(Office.MsoAutoShapeType.msoShapeRectangle, 200 + 30 * ii, 200 + 30 * jj, 25, 25);
                PowerPoint.FillFormat fill = newShape.Fill;
                PowerPoint.LineFormat line = newShape.Line;
                fill.BackColor.RGB = c2;
                fill.ForeColor.RGB = c2;
                line.ForeColor.RGB = 0;
                line.BackColor.RGB = 0;
            }
        }
    }

    private int FadeRGB(int c, double s)
    {
        int[] r = ToRGB(c);
        for (int ii = 0; ii < 3; ii++)
        {
            if (s < 0)
            {
                r[ii] = (int)((r[ii] - 255) * s + r[ii]);
            }
            else
            {
                r[ii] = (int)(r[ii] * (1 - s));
            }
        }
        return r[0] + 256 * (r[1] + 256 * r[2]);
    }

    private int[] ToRGB(int c)
    {
        int[] retval = new int[3];
        for (int ii = 0; ii < 3; ii++)
        {
            retval[ii] = c % 256;
            c = (c - retval[ii]) / 256;
        }
        return retval;
    }
}

注释：

  1. 引入 Microsoft.Office.Interop.PowerPoint 和 Microsoft.Office.Core 命名空间。
  2. 创建一个名为 ColorCalculator 的类，用于计算颜色。
  3. 在 CalcColor 方法中，获取当前活动演示文稿和颜色方案。
  4. 创建一个二维数组 shades 存储颜色的渐变值。
  5. 使用嵌套的 for 循环遍历颜色和渐变值，并在幻灯片上添加矩形形状。
  6. 获取新形状的填充和线条，并设置背景色、前景色、线条颜色和背景线条颜色。
  7. 在 FadeRGB 方法中，将颜色值进行渐变计算。
  8. 在 ToRGB 方法中，将颜色值转换为 RGB 数组。

我已经用计算更新了我的答案（涉及一些猜测，但结果对我来说看起来很有说服力）。函数toRGB将 转换long为三个字节的数组；fadeRGB获取颜色和“褪色系数”，并相应地修改颜色。

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