程序员经验分享-hwhale

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

2023-11-26

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

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

http://i.imgur.com/ZwBRgQO.png

我还需要从调色板中获取另外 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

所以我的问题是，如何从调色板/主题中获取这些颜色的 RGB 值？


第一眼弗洛里斯的解决方案似乎可行，但如果您关心准确性，您很快就会意识到以前的解决方案仅与颜色空间的一小部分的办公室颜色计算相匹配。

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

办公室好像用HSL颜色模式，同时计算着色和阴影，并使用此技术为我们提供了几乎 100% 准确的颜色计算（在 Office 2013 上测试）。

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

  1. 将 RGB 基础颜色转换为 HSL
  2. 查找用于五种子颜色的色调和阴影值
  3. 应用色调/阴影值
  4. 从 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 |

正值使颜色着色（使其变浅），负值使颜色变暗（使其变暗）。有五个组； 1 组为全黑，1 组为全白。这些将仅匹配这些特定值（而不是例如RGB = {255, 255, _254_}）。然后有两个小范围的非常暗和非常亮的颜色分别处理，最后是所有其余颜色的大范围。

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

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

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

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

Program output, calculated color variations

乍一看，这看起来与 Floris 的解决方案非常相似，但仔细观察，您可以清楚地看到许多情况下的差异。 Office 主题颜色（因此此解决方案）通常比普通 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
本文内容由网友自发贡献，版权归原作者所有，本站不承担相应法律责任。如您发现有涉嫌抄袭侵权的内容，请联系:hwhale#tublm.com(使用前将#替换为@)

vba

powerpoint

如何从 PowerPoint 调色板获取 RGB/Long 值 的相关文章

  • 升级到 Office 365 专业增强版后 Excel VBA 运行速度极慢

    我粘贴部分代码如下 这段代码是解析从HTTP请求得到的JSON字符串 根本没有工作表 工作簿操作 在office升级到office365专业增强版之前 效率还是蛮高的 但升级后 解析一个不到2秒的json 却要花费几分钟 我个人不明白根本原

  • 在 Excel 中将 x 轴的最大值和最小值设置为日期

    我有一个 X 轴上有日期的图表 我正在尝试使用 Excel VBA 设置该轴的最大值和最小值 下面是我的代码 似乎不起作用 有人可以帮忙吗 With ActiveSheet ChartObjects 1 Chart Axes xlValue

  • 在vba中打乱数组[重复]

    这个问题在这里已经有答案了 我需要对数组中的值进行无重复的洗牌 我需要在代码中添加什么以避免重复 Function Resample data vector n UBound data vector ReDim shuffled vecto

  • 变量的变化触发事件

    是否可以通过变量的更改来触发事件 例如 这将触发事件 Dim t As Integer Dim Fire As Boolean Private Sub Test t 0 Fire True IIf Fire t 1 t 2 End sub

  • Outlook 宏中的 SenderName 为空

    我想要得到SenderName和和To属性来自于MailItem对象 但它们是空白的 我可以看到有SentOn Subject以及其他不为空的属性 有谁知道为什么这两个是空白的 这是我的代码 Sub TestMacro Dim myOlAp

  • VBA 中 Thisworkbook.name 和 Activeworkbook.name 之间的区别

    Thisworkbook 和 ActiveWorkbook 有什么区别吗 示例代码 Sub workbook name MsgBox Thisworkbook name End Sub Sub active name MsgBox Acti

  • 使用用户定义函数的 VBA 数据验证

    我有一个用户定义的函数 我想在自定义数据验证中使用它 我的函数工作正常 但是当我在数据验证中使用它时 每次都会出错 有代码 Public Function AlphaNumeric pValue As Boolean Dim LPos As

  • 使用@@Identity

    我想知道如何从另一个数据库的表中获取最近生成的自动编号值 目前我正在这样做 Do Until rsA EOF Inserts new row here works Set rs New ADODB Recordset rs Open SEL

  • =MATCH() 等价于多维范围

    我有一个 Excel 工作表 其中单元格 A1 C20 INT RAND 10 这是我的数据范围 单元格 E1 1 E2 2 E3 3 等 这些是我试图找到的值 我设置单元格 F1 MATCH E1 A C 0 F2 MATCH E1 A

  • Excel VBA 中.Delete 和.Clear 的区别？

    有什么区别Worksheets 1 Cells Delete and Worksheets 1 Cells Clear 我问这个是因为我一直用 Clear清除我的工作表内容 但在我之前的帖子中我发现Worksheets 1 Cells De

  • 将按颜色过滤的行复制到新工作表

    我有一个 Excel 电子表格 如下所示 Job1 Job2 Job3 Job4 Job5 Job1 Job2 Job3 Job4 Job5 每行和列之间的单元格颜色不同 我需要按橙色对每列进行排序 然后将行名称复制到新工作表中 所以最后我

  • 从网站上的表格中抓取数据，而无需搜索标签

    这是这个问题的延续使用 InStr 搜索引号 空格 冒号等 https stackoverflow com questions 52673819 using instr to search for quotes spaces colons

  • 将最后几个功能添加到我的调度模板生成器中

    感谢 StackOverflow 上的一些出色的人 我几乎完成了调度模板生成器的代码 我还想补充三件事 但我遇到了一些麻烦 当前细分 我有两张表 2 员工列表 和 X 模板 员工列表中的值是从单元格 D9 开始的一列员工姓名 然后将员工值转

  • 运行代码（而不是查询）时如何在状态栏上显示进度

    我已经发布了有关在 MS Access 2010 中运行查询时更新状态栏的问题 请参阅在 MS Access 中运行一系列查询时如何在状态栏上显示进度 https stackoverflow com questions 27765376 h

  • 从 C# 检测 powerpoint 形状上的事件

    是否有可能检测在 Powerpoint 形状 例如箭头 上发生的事件 到目前为止 我发现唯一的可能性是 selectitemchanged beforerightclick 和 beforedoubleclick 但无法找到检测其他内容的方

  • VBA ByRef 参数类型不匹配

    最初在我的主代码部分中 我有一个丑陋的 if 语句 尽管它会运行丑陋 我决定将其设为我要调用的函数 这导致我收到错误 编译错误 ByRef 参数类型不匹配 我的假设是该函数需要正确引用 尽管我一直在阅读文档并且不明白为什么 gt 声明 Sh

  • 标志状态的 VBA 替换

    根据文档 Outlook 中的 MailItem FlagStatus 属性是已弃用 https msdn microsoft com en us library microsoft office interop outlook maili

  • 在VBA中初始化全局变量

    在 Excel 2003 中 如何声明全局变量并仅在打开工作簿时初始化它们一次 我有一些由几个宏使用的参数 基本上是输入文件的路径 目前 我的代码如下所示 global path1 path2 as string sub initPaths

  • 在 Excel 中使用 VBA 设置图像透明度

    有没有办法使用 VBA 脚本对图像应用一些透明度 我录制了一个 宏 但似乎没有录制艺术效果 我已经找到了如何制作形状 但没有找到图像 这需要几个步骤 将自选图形 如矩形 放置在工作表上 使用以下方法将您的实际图片嵌入矩形中 ShapeRan

  • 如何使用vba复制Excel工作表中的动态范围

    我试图使宏中的范围是动态的 而不指定最后一行x Sheets SheetName Range A2 K1000 Copy在 1000 行中 我想将其更改为动态 因为有时我的数量会更少或更多 尝试这个 Sub Test Dim lRow as

随机推荐

  • 按第一项对嵌套列表进行排序 - itemgetter 不起作用

    我有一本字典 已转换为列表 以便我可以按第一项进行排序 字典中的键是一个字符串 数字 值是一个在列表中维护的整数 字典转换的列表如下所示 228055 1 228054 1 228057 2 228056 1 228051 1 228050

  • 异步 Google 地图 API v3 未定义不是函数 [关闭]

    很难说出这里问的是什么 这个问题模棱两可 含糊不清 不完整 过于宽泛或言辞激烈 无法以目前的形式合理回答 如需帮助澄清此问题以便重新打开 访问帮助中心 我正在编写一个应用程序 它使用手工构建的框架异步加载 Google 地图 当我加载地图时

  • Node JS 中 Socket 和 EventEmitter 的异同

    我对 Node js 中的 Socket io 和 EventEmitter API 有点困惑 是的 我对事件驱动的 NodeJS 编程很陌生 这两者之间有什么显着差异吗 或者一个已经超越了另一个 它们的设计目的是相同还是不同 任何示例 资

  • 如何在 UITableViewCell 中获取透明附件视图？ （带屏幕截图）

    我使用笔尖中的自定义 UITableViewCell 附件视图是详细信息披露指示器 问题是附件视图后面的 UITableViewCell 的背景颜色没有被渲染 参见下面的图像 源 有什么线索吗 另外 这里有一些我尝试过但没有成功的事情 不起

  • 设置在 matplotlib 中使用 plt.subplots 创建的图形的高度和宽度？

    在 matplotlib 中 我知道如何设置图形的高度 宽度和 DPI fig plt figure figsize 4 5 dpi 100 然而 似乎如果我想创建小的多个图 我无法创建这样的图形 我必须使用这个 fig subplots

  • ASP.NET MVC - 使用 ViewData 将 Json 字符串传递给视图

    我正在尝试使用 ViewData 将 Json 传递到我的视图 控制器 ViewData JsonRegionList Json RegionService GetActiveRegions view input UserRegion au

  • 非中心卡方概率和非中心参数

    如何获得非中心参数的值 对于不同的临界值和自由度 该参数的概率恰好为 0 9 例如 显着性水平 0 05 且自由度为 1 临界值 3 84 时 ncp 必须等于 10 50742 才能获得 0 9 的概率 1 pchisq 3 841459

  • Android 深度链接与自定义 URI

    我在清单中定义了以下内容

  • “PHP 通知：未定义的属性”[关闭]

    这个问题不太可能对任何未来的访客有帮助 它只与一个较小的地理区域 一个特定的时间点或一个非常狭窄的情况相关 通常不适用于全世界的互联网受众 为了帮助使这个问题更广泛地适用 访问帮助中心 我收到这个奇怪的错误 你会说 为什么奇怪 你只是没有这

  • 运行一个进程并退出而不等待它

    在 Windows 下的 Python 中 我想在单独的进程中运行一些代码 我不希望家长等待它结束 尝试过这个 from multiprocessing import Process from time import sleep def c

  • C# 中委托不可变的目的是什么？

    我正在看一本图解C 2012的Combining Delegates一节 没有注意到这一点吗 代表们的目的是一成不变的 合并代表 到目前为止 您见过的所有代表都只有 其调用列表中的单个方法 代表可以 合并 通过使用加法运算符 运算的结果是

  • Redis集群与Spring boot集成

    我有一个具有主服务器 从服务器和 3 个哨兵服务器的 Redis 集群 主服务器和从服务器映射到 dns 名称为 node1 redis dev com node2 redis dev com redis服务器版本是2 8 我将以下内容包含

  • 找出Windows服务正在运行的进程名称.NET 1.1

    我们正在使用一个写得不好的 Windows 服务 当我们试图从代码中停止它时 它会挂起 因此 我们需要找到与该服务相关的进程并将其杀死 有什么建议么 您可以使用System Management MangementObjectSearche

  • “每个表只能有一个 IDENTITY 列” - 为什么？

    每个表只能有一个 IDENTITY 列 为什么会这样呢 以车辆为例 存在唯一的底盘号以及唯一的车牌号 为了描述这个场景sql服务器我们需要对其中一个列进行自定义实现 相反 在Oracle一张桌子上可以有任意数量的序列 为什么对 IDENTI

  • 如何在html动作链接中插入图像？ ASP.NET MVC

    我的 web 项目上有来自 html 操作链接的导航和许多链接 它们很丑 有下划线 我想插入一些带有名称的图像或使用操作链接的样式 是否可以 怎么做 谢谢并保重 拉吉姆斯 您可以使用 css 删除下划线或放置背景图片 否则你也可以像这样创建

  • 来自元组的构造函数参数

    如果我有一个像这样的结构 struct Thing int x int y bool a bool b 然后我可以创建一个Thing对象通过这样做 Thing t 1 2 true false 但是 如果我有一个元组 那么我会做类似的事情

  • 如何在 Angular 2 中使用 SheetJS (js-xlsx)

    我正在学习 angular2 我想使用js xlsx我的项目中的库 我安装了xlsxnpm install xlsx和jszipnpm install jszip并将它们添加到我的index html中 并添加了打字稿定义tsd insta

  • 用于重载传递的函数指针类型的表达式 SFINAE

    在此示例中 函数被传递给隐式实例化的函数模板 Function that will be passed as argument int foo return 0 Function template to call passed functi

  • Karma jasmine 测试：在终端中突出显示差异

    我使用 Karma 和 Jasmine 进行测试 在某些测试中 我有测试所依赖的大型对象 当我做类似的事情时 expect obj toEqual expectedObj and obj expectedObj 我在终端中收到一条错误消息

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

    我正在尝试 大部分成功 从活动中 读取 颜色ThemeColorScheme 下面的子例程将从主题中获取 12 种颜色 例如这是myAccent1 我还需要从调色板中获取另外 4 种颜色 我需要的四种颜色是上面指示的颜色正下方的一种 然后是

热门标签