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

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

颜色方案中“读取”颜色

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


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

由于
ThemeColorScheme
对象仅包含12项，因此我得到
指定的值超出范围
错误，如果我尝试以这种方式为
myAccent9
赋值，这与预期一样。我理解这个错误以及它发生的原因。我不知道的是如何从调色板中访问其他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值？
如果使用VBA for excel，则可以记录击键。选择另一种颜色（从主题下方）显示：

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

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

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

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

选项显式
子calcColor（）
Dim ii为整数，jj为整数
作为演示文稿的Dim pres
将thm调暗为办公室主题
将颜色暗显为颜色
Dim Scheme颜色作为颜色方案
暗影
暗色调（12）作为变体
尺寸c，c2与长度相同
像形状一样暗淡的新闻形状
Set pres=ActivePresentation
设置schemeColors=pres.Designs（1）.SlideMaster.Theme.ThemeColorScheme
阴影（0）=阵列（0，-0.05，-0.15，-0.25，-0.35，-0.5）
阴影（1）=阵列（0,0.05,0.15,0.25,0.35,0.5）
阴影（2）=阵列（-0.1，-0.25，-0.5，-0.75，-0.9）
对于ii=3到11
阴影（ii）=阵列（-0.8，-0.6，-0.4,0.25,0.5）
下一个
对于ii=0到11
c=模式颜色（ii+1）.RGB
对于jj=0到4
c2=fadeRGB（c，阴影（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
下一个jj
下一个ii
端接头
函数fadeRGB（ByVal c，s）的长度
Dim r，ii
r=toRGB（c）
对于ii=0到2
如果s<0，则
r（ii）=Int（（r（ii）-255）*s+r（ii））
其他的
r（ii）=Int（r（ii）*（1-s））
如果结束
下一个ii
fadeRGB=r（0）+256&*（r（1）+256&*r（2））
端函数
函数toRGB（c）
第二节第三节
对于ii=0到2
返回值（ii）=c模256
c=（c-检索（ii））/256
下一个
toRGB=retval
端函数

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

正确的解决方案-使用HSL颜色空间
Office似乎在计算着色和底纹时使用了模式，使用此技术，我们可以获得几乎100%的准确颜色计算（在Office 2013上测试）

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

将基本RGB颜色转换为HSL
查找要用于五个子颜色的色调和阴影值
应用色调/阴影值
从HSL转换回RGB颜色空间
要查找色调/阴影值（步骤#3），请查看HSL颜色的亮度值并使用此表（通过尝试和错误查找）：

基于上面的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

Sub-DemoExcelThemecolorsHSL（）
变暗rng As范围
尺寸n为整数，m为整数
模糊的名字
模糊的描述
暗ARR值
Dim Scheme颜色作为颜色方案
双色暗色调
昏暗的lngColorRGB为长，lngColorRGBshaded为长
淡色HSL为HSL，淡色HSL为HSL
设置schemeColors=ActiveWorkbook.Theme.ThemeColorScheme
arrNames=数组（“xlThemeColorDark1”、“XLThemeColordLight1”、“xlThemeColorDark2”、“XLThemeColordLight2”、“XLThemeColordAccent1”、“xlThemeColorAccent2”_
“xlThemeColorAccent3”、“xlThemeColorAccent4”、“xlThemeColorAccent5”、“xlThemeColorAccent6”、“xlThemeColorHyperlink”、“XLThemeColorFollowHyperlink”）
arrsdescriptions=数组（“暗1”、“亮1”、“暗2”、“亮2”、“重音1”、“重音2”、“重音3”、“重音4”、“重音5”、“重音6”、“超链接”、“后跟超链接”）
arrValues=数组（2,1,4,3,5,6,7,8,9,10,11,12）
'新工作表，标题行
ActiveWorkbook.Worksheets.Add
设置rng=单元（1，2）
rng（1，1）.Value2=“颜色名称”
rng（1,2）.Value2=“值”
rng（1,3）.Value2=“说明”
rng（1,4）.Value2=“TintAndShade”
rng.Resize（1,4）.Font.Bold=True
设置rng=rng（3，1）
'颜色矩阵
对于n=0到11
rng（n*2，1）.Value=arrNames（n）
rng（n*2，2）.值=ARRG值（n）
rng（n*2，3）.值=n
lngColorRGB=SchemeColor（n+1）.RGB
对于m=0到5
颜色HSL=RGBtoHSL（lngColorRGB）
dblTintShade=选择色调阴影（颜色hsl，m）
ColorHSLshaded=ApplyTintAndShade（ColorHSL，dblTintShade）
lngColorRGBshaded=HSLtoRGB（彩色HSLSHADDED）
带rng（n*2，m+4）
.Value=dblTintShade
如果ColorHSLshaded.L<0.5，则.Font.ColorIndex=2
'固定颜色，在选择新配色方案时不更改
.内饰.颜色=
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

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

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

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