作者热门文章
- html - 出于某种原因,IE8 对我的 Sass 文件中继承的 html5 CSS 不友好?
- JMeter 在响应断言中使用 span 标签的问题
- html - 在 :hover and :active? 上具有不同效果的 CSS 动画
- html - 相对于居中的 html 内容固定的 CSS 重复背景?
我正在尝试(大部分成功)从事件 ThemeColorScheme
中“读取”颜色.
下面的子程序将从主题中获取 12 种颜色,例如这是 myAccent1
:
我还需要从调色板中获得另外 4 种颜色。我需要的四种颜色将是上面指示的颜色正下方的一种,然后是从左到右接下来的 3 种颜色。
因为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
最佳答案
第一眼Floris' solution似乎可行,但如果您关心准确性,您很快就会意识到先前的解决方案仅与色彩空间的一小部分的办公室颜色计算相匹配。
正确的解决方案 - 使用 HSL 色彩空间
办公室好像用HSL color模式,同时计算着色和阴影,并使用此技术为我们提供了几乎 100% 准确的颜色计算(在 Office 2013 上测试)。
正确计算值的方法似乎是:
| [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_}
)。然后是两个小范围的非常深和非常浅的颜色,分别处理,最后是所有其余颜色的大范围。
TintAndShade
的
Cell.Interior
属性)。
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
关于vba - 如何从 PowerPoint 调色板中获取 RGB/Long 值,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/21142732/
我是一名优秀的程序员,十分优秀!