299 lines
10 KiB
QBasic
299 lines
10 KiB
QBasic
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
|
|
|