Attribute VB_Name = "ex_Color"
'================ Модуль для работы с цветами в разных приложениях =============
' Shared module version: 20210430
' Tested in: TestCommons
' Depends on:
' Required reference:
Option Private Module
Option Explicit

Public Enum ColorType
  CT_RGB = &H0
  CT_AUTO = &HFF
  CT_SYSTEM = &H80
  CT_THEME_LOW = &HD0
  CT_THEME_HIGH = &HDF
End Enum

Public Type ColorDetails
  type_  As Byte
  clrIndex_ As WdThemeColorIndex
  tintShade_  As Double
  rgb_ As Long
End Type

Public Enum HardColor
  HC_INVALID = -1
  HC_WHITE = &HFFFFFF
  HC_BLACK = &H0
  HC_RED = &HFF
  HC_GREEN = &HFF00
  HC_BLUE = &HFF0000
End Enum

Public Declare PtrSafe Function _
  ColorAdjustLuma Lib "shlwapi.dll" ( _
    ByVal nRGB As Long, _
    ByVal nLumaAdjust As Long, _
    ByVal bScale As Long) As Long

Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Enum AppType
  T_APP_UNDEF = 0
  [_First] = 1
  
  T_APP_WORD = 1
  T_APP_EXCEL = 2
  T_APP_VISIO = 3
  T_APP_POWER_POINT = 4

  [_Last] = 4
End Enum

Public Function ColorGetLuma(nRGB&) As Long
  Dim clrRed%, clrGreen%, clrBlue%
  Call LongColor3Components(nRGB, clrRed, clrGreen, clrBlue)
  ColorGetLuma = Math_Sym(0.2126 * clrRed + 0.7152 * clrGreen + 0.0722 * clrBlue)
End Function

Public Function ColorGetRGB(nColorID&, aDocument As Object) As Long
  ColorGetRGB = QueryColor(nColorID, aDocument).rgb_
End Function

Public Function ConvertRGBtoString(nRGB&) As String
  Dim nRed%, nGreen%, nBlue%
  Call LongColor3Components(nRGB, nRed, nGreen, nBlue)
  ConvertRGBtoString = "RGB(" & nRed & "," & nGreen & "," & nBlue & ")"
End Function

Public Function ConvertStringToRGB(sColor$) As Long
  ConvertStringToRGB = HC_INVALID
  
  Dim nLen&: nLen = VBA.Len(sColor)
  Dim nPos&: nPos = 1
  Dim nRed%: nRed = ExtractFirstInteger(sColor, nPos)
  If nPos > nLen Or nRed = HC_INVALID Or nRed > 255 Then _
    Exit Function
    
  nPos = nPos + 1
  Dim nGreen%: nGreen = ExtractFirstInteger(sColor, nPos)
  If nPos > nLen Or nGreen = HC_INVALID Or nGreen > 255 Then _
    Exit Function
    
  nPos = nPos + 1
  Dim nBlue%: nBlue = ExtractFirstInteger(sColor, nPos)
  If nPos > nLen Or nBlue = HC_INVALID Or nBlue > 255 Then _
    Exit Function
  
  ConvertStringToRGB = RGB(nRed, nGreen, nBlue)
End Function

Public Function QueryColor(nColorID&, aDocument As Object) As ColorDetails
  Dim sHexColor$: sHexColor = VBA.Right$(VBA.String$(7, "0") & VBA.Hex$(nColorID), 8)
  QueryColor.type_ = CByte("&H" & VBA.Left$(sHexColor, 2))
  Select Case QueryColor.type_
    Case CT_RGB: QueryColor.rgb_ = nColorID
    Case CT_SYSTEM: QueryColor.rgb_ = SysColorToRGB(nColorID)
    Case CT_THEME_LOW To CT_THEME_HIGH: QueryColor = QueryThemeColor(QueryColor.type_, sHexColor, aDocument)
  End Select
End Function

' =========
Private Function LongColor3Components(nColor&, ByRef c1%, ByRef c2%, ByRef c3%)
  c1 = Math_Sym(nColor And &HFF&)
  c2 = Math_Sym((nColor And &HFF00&) / &H100&)
  c3 = Math_Sym((nColor And &HFF0000) / &H10000)
End Function

Private Function Math_Sym(ByVal nValue As Double, Optional ByVal dFactor As Double = 1) As Double
   Math_Sym = Fix(nValue * dFactor + 0.5 * Sgn(nValue)) / dFactor
End Function

Private Function ExtractApplicationType(target As Object) As AppType
  If target Is Nothing Then
    ExtractApplicationType = T_APP_UNDEF
    Exit Function
  End If
  Select Case target.Application.Name
    Case "Microsoft Word":      ExtractApplicationType = T_APP_WORD
    Case "Microsoft Excel":     ExtractApplicationType = T_APP_EXCEL
    Case "Microsoft PowerPoint":  ExtractApplicationType = T_APP_POWER_POINT
    Case "Microsoft Visio": ExtractApplicationType = T_APP_VISIO
    Case Else: ExtractApplicationType = T_APP_UNDEF
  End Select
End Function

Private Function ExtractFirstInteger(sText$, ByRef nPos&) As Integer
  On Error GoTo ERR_OVERFLOW

  Dim bStarted As Boolean: bStarted = False
  Dim nLen&: nLen = VBA.Len(sText)
  Dim sDigit$
  Do
    If nPos > nLen Then _
      Exit Function
    sDigit = VBA.Mid(sText, nPos, 1)
    If VBA.IsNumeric(sDigit) Then
      bStarted = True
      ExtractFirstInteger = ExtractFirstInteger * 10 + VBA.CLng(sDigit)
    ElseIf bStarted Then _
      Exit Function
    End If
    nPos = nPos + 1
  Loop
  
ERR_OVERFLOW:
  On Error GoTo 0
  ExtractFirstInteger = HC_INVALID
End Function

Private Function SysColorToRGB(nColor&) As Long
  SysColorToRGB = GetSysColor(nColor And &HFFFFFF)
End Function

Private Function QueryThemeColor(clrType As Byte, hexColor$, aDocument As Object) As ColorDetails
  QueryThemeColor.type_ = clrType And &HF0
  QueryThemeColor.clrIndex_ = clrType And &HF
  
  Dim bDarkness As Byte: bDarkness = CByte("&H" & Mid$(hexColor, 5, 2))
  If bDarkness <> &HFF Then
    QueryThemeColor.tintShade_ = VBA.Round(-1 + bDarkness / &HFF, 2)
  End If
  
  Dim bLightness As Byte: bLightness = CByte("&H" & Mid$(hexColor, 7, 2))
  If bLightness <> &HFF Then
    QueryThemeColor.tintShade_ = VBA.Round(1 - bLightness / &HFF, 2)
  End If

  QueryThemeColor.rgb_ = GetThemeRGB(QueryThemeColor.clrIndex_, QueryThemeColor.tintShade_, aDocument)
End Function

Private Function GetThemeRGB(clrIndex As WdThemeColorIndex, tintShade As Double, aDocument As Object) As Long
  Dim schemeID  As MsoThemeColorSchemeIndex
  Dim schemeRGB&
  Select Case ExtractApplicationType(aDocument)
    Case T_APP_UNDEF
      schemeID = WordColor(clrIndex)
      schemeRGB = ActiveDocument.DocumentTheme.ThemeColorScheme(schemeID).RGB
    Case T_APP_WORD
      schemeID = WordColor(clrIndex)
      schemeRGB = aDocument.DocumentTheme.ThemeColorScheme(schemeID).RGB
    Case T_APP_VISIO
      schemeRGB = aDocument.DocumentTheme.ThemeColorScheme(clrIndex).RGB
    Case T_APP_EXCEL
      schemeID = ExcelColor(clrIndex)
      schemeRGB = aDocument.DocumentTheme.ThemeColorScheme(schemeID).RGB
    Case T_APP_POWER_POINT
      schemeRGB = aDocument.DocumentTheme.ThemeColorScheme(clrIndex).RGB
  End Select
  GetThemeRGB = ColorAdjustLuma(schemeRGB, Math_Sym(tintShade, 1000) * 1000, True)
End Function
 
Private Function WordColor(clrID As WdThemeColorIndex) As MsoThemeColorSchemeIndex
  Select Case clrID
    Case wdThemeColorMainDark1:         WordColor = msoThemeDark1
    Case wdThemeColorMainLight1:        WordColor = msoThemeLight1
    Case wdThemeColorMainDark2:         WordColor = msoThemeDark2
    Case wdThemeColorMainLight2:        WordColor = msoThemeLight2
    Case wdThemeColorAccent1:           WordColor = msoThemeAccent1
    Case wdThemeColorAccent2:           WordColor = msoThemeAccent2
    Case wdThemeColorAccent3:           WordColor = msoThemeAccent3
    Case wdThemeColorAccent4:           WordColor = msoThemeAccent4
    Case wdThemeColorAccent5:           WordColor = msoThemeAccent5
    Case wdThemeColorAccent6:           WordColor = msoThemeAccent6
    Case wdThemeColorHyperlink:         WordColor = msoThemeHyperlink
    Case wdThemeColorHyperlinkFollowed: WordColor = msoThemeFollowedHyperlink
    Case wdThemeColorBackground1:       WordColor = msoThemeLight1
    Case wdThemeColorText1:             WordColor = msoThemeDark1
    Case wdThemeColorBackground2:       WordColor = msoThemeLight2
    Case wdThemeColorText2:             WordColor = msoThemeDark2
    Case Else:
  End Select
End Function

Private Function ExcelColor(clrID As XlThemeColor) As MsoThemeColorSchemeIndex
  Select Case clrID
    Case xlThemeColorDark1:               ExcelColor = msoThemeDark1
    Case xlThemeColorLight1:              ExcelColor = msoThemeLight1
    Case xlThemeColorDark2:               ExcelColor = msoThemeDark2
    Case xlThemeColorLight2:              ExcelColor = msoThemeLight2
    Case xlThemeColorAccent1:             ExcelColor = msoThemeAccent1
    Case xlThemeColorAccent2:             ExcelColor = msoThemeAccent2
    Case xlThemeColorAccent3:             ExcelColor = msoThemeAccent3
    Case xlThemeColorAccent4:             ExcelColor = msoThemeAccent4
    Case xlThemeColorAccent5:             ExcelColor = msoThemeAccent5
    Case xlThemeColorAccent6:             ExcelColor = msoThemeAccent6
    Case xlThemeColorHyperlink:           ExcelColor = msoThemeHyperlink
    Case xlThemeColorFollowedHyperlink:   ExcelColor = msoThemeFollowedHyperlink
    Case Else:
  End Select
End Function

'
'
''----------------------Конвертирование ------------------------------------------------
'Function Convert_RGB2CMYK(colr&) As Long
''RGB -> CMYK
'  Dim red As Integer, blue As Integer, green As Integer
'  Dim c As Double, m As Double, y As Double, k As Double, minCMY As Double
'  Dim cyan As Integer, magenta As Integer, yellow As Integer, key As Integer
'
'  Call LongColor3Components(colr, red, green, blue)
'  If red = 0 And green = 0 And blue = 0 Then
'    key = 100
'    GoTo RESULTING
'  End If
'
'  c = 1 - (red / 255)
'  m = 1 - (green / 255)
'  y = 1 - (blue / 255)
'  k = Math_Min(c, Math_Min(m, y))
'
'  cyan = Math_Sym(100 * (c - k) / (1 - k))
'  magenta = Math_Sym(100 * (m - k) / (1 - k))
'  yellow = Math_Sym(100 * (y - k) / (1 - k))
'  key = Math_Sym(100 * k)
'
'RESULTING:
'  Convert_RGB2CMYK = cyan * 101 ^ 3 + 101 ^ 2 * magenta + 101 * yellow + key
'End Function
'
'
''--------------------------Обработка цветовых ссылок ------------------------
'
'Private Function SysColorToRGB(ByVal SysColor&) As Long
''Возвращает RGB системного цвета
'  SysColor = SysColor And &HFFFFFF
'  SysColorToRGB = GetSysColor(SysColor)
'End Function
'
'Private Function QueryThemeColor(ColourTypeByte As Byte, _
'                 ColourToTestHex As String, app As Object) _
'         As ColorDetails
'
'  Const Unchanged    As Byte = &HFF
'
'  Dim LightnessByte  As Byte
'  Dim DarknessByte   As Byte
'
'  LightnessByte = CByte("&H" & Mid$(ColourToTestHex, 7, 2))
'  DarknessByte = CByte("&H" & Mid$(ColourToTestHex, 5, 2))
'
'  QueryThemeColor.ColourType = ColourTypeByte And &HF0
'  QueryThemeColor.ThemeColorIndex = ColourTypeByte And &HF
'
'  If DarknessByte <> Unchanged Then
'    QueryThemeColor.TintAndShade = Round(-1 + DarknessByte / &HFF, 2)
'  End If
'
'  If LightnessByte <> Unchanged Then
'    QueryThemeColor.TintAndShade = Round(1 - LightnessByte / &HFF, 2)
'  End If
'
'  QueryThemeColor.RGB = GetThemeRGB(QueryThemeColor.ThemeColorIndex, _
'                 QueryThemeColor.TintAndShade, app)
'
'End Function