PowerPoint 색상 표에서 RGB/Long 값을 얻는 방법

Question

활성화된 색을 "읽으려고"시도하고 있습니다 (ThemeColorScheme).

서브 루틴 아래 테마에서 12 색을 구하는 것, 예를 들어이 myAccent1이다

난 팔레트에서 4 개 개의 색상을 얻는 것이 또한 필요하다. 필요한 네 가지 색상은 위에 표시된 색상 바로 아래에있는 색상이고, 그 다음에 왼쪽에서 오른쪽으로 다음 3 색상입니다.

myAccent9 값을이 방법으로 지정하려고하면 예상대로 ThemeColorScheme 개체에 12 개 항목 만 있기 때문에 나는 The specified value is out of range 오류가 발생합니다. 이 오류와 그 오류가 발생한 이유를 이해합니다. 내가 모르는 것은 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 값을 팔레트/테마에서 얻을 수 있습니까?

Answer 1

Excel에서 VBA를 사용하는 경우 키 입력을 기록 할 수 있습니다. (주제 아래에서) 다른 색상을 선택하면 보여줍니다

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

.TintAndShade 요소가 정의 된 색상을 수정합니다. 테마의 다른 색상은 .TintAndShade에 대해 다른 값을 사용합니다. - 밝은 색상을 더 어둡게 만들기 위해 숫자가 음수 인 경우가 있습니다.

.TintAndShade의

불완전한 테이블 (I 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에 올바른 값을 가지고 있지만, 다른 색상의 변환이 작동하는 것 같다 있는지

말

0,123,516에 표시 출력, 순수 파워 코드로 업데이트 첫눈 Floris' solution에서

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 

Answer 2

가 작동하는 것 같다,하지만 당신은 정확성에 관심 있다면 당신은 곧 이전의 솔루션은 색 공간의 단지 작은 부분에 대한 사무실 용 색상 계산과 일치하는지 깨닫게됩니다 .

적절한 솔루션 -

사무실 HSL 컬러 공간

사용은 색조 및 음영을 계산하고,이 기술을 사용하면 (오피스 2013에서 테스트) 우리에게 거의 100 % 정확한 색상 계산을 제공하는 동안 HSL color 모드를 사용하는 것 같다.

1. 는
2. 하는 색조를 적용 다섯 가지 하위 색상에 사용할 색조와 음영 값을 찾기 HSL
3. 에 기본 RGB 색상 변환 :
   는 제대로 값을 계산하는 방법이 될 것으로 보인다

   /그늘

4. 는

가 색조/그늘 값을 찾으려면 RGB 색 공간에 HSL에서 다시 변환 값 (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 | 

양수 색을 염색하는 (가벼운 그것을 만들기), 음의 값은 색상 음영있다 (더 어둡게 만든다). 5 개의 그룹이 있습니다. 완전히 검은 색 인 경우 1 그룹, 완전 흰색 인 경우 1 그룹. 이 값은 특정 값과 일치합니다 (예 : RGB = {255, 255, _254_} 제외). 그런 다음 매우 어두운 색과 매우 밝은 색의 두 가지 작은 범위가 개별적으로 처리되며 마지막으로 나머지 색의 큰 범위가 있습니다.

참고 : 값이 +0.40이면 값이 40 % 가벼워지며 원래 색의 40 % 색조 (실제로는 60 % 가벼운 것을 의미)가 아닙니다. 이는 누군가에게 혼란을 줄 수 있지만 Office에서 내부적으로이 값을 사용하는 방식입니다 (예 : Excel의 경우 TintAndShade 속성이 Cell.Interior). 나는이 VBA를 만들 수 플로리스 '솔루션을 기반으로 구축 한 :

파워 포인트 VBA 코드 솔루션을

[면책 조항]을 구현합니다. 많은 HSL 번역 코드도 이미 Word article mentioned in the comments에서 복사됩니다.

아래 코드의 출력은 다음과 같은 색상 변화입니다 : 언뜻

, 이것은 플로리스 '솔루션과 매우 비슷하지만, 더 정밀한 점검에 당신이 많은 차이를 분명히 볼 수 있습니다 상황. Office 테마 색상 (따라서이 솔루션)은 일반적으로 일반 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