解析HTML、CSS的颜色文本为 Color 对象

https://blog.clso.fun/posts/vb-net-parser-html-css-text-to-color.html

用法

Dim c As Color = ToColorEx("#FF00CC")
c = ToColorEx("#ccc")
c = ToColorEx("rgba(204, 232, 207, 0.5)")
c = ToColorEx("hsla(84, 91, 205, 50%)")
c = ToColorEx("red")

支持的格式

#fff
#FFFFFF
rgb(0,123,50)
rgba(0,123,50,0.5)
hsl(84,91,205)
hsla(84,91,205,50%)
red\blue\green\yellow 等常规描述性文本

代码

Imports System.Text
Imports System.Text.RegularExpressions
Imports System.Runtime.InteropServices
Imports System.Drawing


''' <summary>从字符串分析出颜色</summary>
Shared Function ToColorEx(colorText As String, Optional throwError As Boolean = False) As Color
    colorText = colorText.Trim()
 
    Dim p As String
    Dim m As Match
 
    p = "^(#(?:[0-9a-fA-F]{3}|[0-9a-fA-F]{6}))$"
    m = Regex.Match(colorText, p)
    If m.Success Then
        Return ColorTranslator.FromHtml(m.Groups(1).Value)
    End If
 
 
    p = "^(rgba?)\s*\((.+?)\)$"
    m = Regex.Match(colorText, p, RegexOptions.IgnoreCase)
    If m.Success Then
        Dim csn As String() = m.Groups(2).Value.Split(New String() {",", " "}, StringSplitOptions.RemoveEmptyEntries)
        If csn.Length < 3 OrElse csn.Length > 4 Then
            If throwError Then
                Throw New Exception("数值参数设定错误（过多或过少）")
            Else
                Return Nothing
            End If
        End If
 
        Dim ca, cr, cg, cb As Integer
        ca = 255
        cr = StrToByte(csn(0))
        cg = StrToByte(csn(1))
        cb = StrToByte(csn(2))
 
        If m.Groups(1).Value = "rgba" AndAlso csn.Length = 4 Then
            ca = StrToByte(csn(3), True)
        End If
 
        Return Color.FromArgb(ca, cr, cg, cb)
    End If
 
    p = "^(hsla?)\s*\((.+?)\)$"
    m = Regex.Match(colorText, p, RegexOptions.IgnoreCase)
    If m.Success Then
        Dim csn As String() = m.Groups(2).Value.Split(New String() {",", " "}, StringSplitOptions.RemoveEmptyEntries)
        If csn.Length < 3 OrElse csn.Length > 4 Then
            If throwError Then
                Throw New Exception("数值参数设定错误（过多或过少）")
            Else
                Return Nothing
            End If
        End If
 
        ' css = hsl, win = hls
        Dim ca, ch, cs, cl As Integer
        ca = 255
        ch = StrToByte(csn(0))
        cs = StrToByte(csn(1))
        cl = StrToByte(csn(2))
 
 
        ' 利用系统转换
        Dim cwin As Integer = ColorHLSToRGB(ch, cl, cs)
        ' 从win32数值转换为color
        Dim cr As Color = ColorTranslator.FromWin32(cwin)
 
        If m.Groups(1).Value = "hsla" AndAlso csn.Length = 4 Then
            ca = StrToByte(csn(3), True)
        End If
 
        Return Color.FromArgb(ca, cr) '叠加透明度
    End If
 
 
    ' 尝试自动解析
    If throwError Then
        Return ColorTranslator.FromHtml(colorText)
    Else
        Try
            Return ColorTranslator.FromHtml(colorText)
        Catch ex As Exception
            Return Nothing
        End Try
    End If
End Function
 
<DllImport("shlwapi.dll")>
Private Shared Function ColorHLSToRGB(H As Integer, L As Integer, S As Integer) As Integer
End Function
 
Private Shared Function StrToByte(s As String, Optional isDbl As Boolean = False) As Integer
    's = s.Trim
 
    Dim p As String
    Dim m As Match
    Dim v As Double = -1
 
    ' 如果是浮点数
    p = "^\d+\.\d+$"
    m = Regex.Match(s, p)
    If m.Success Then
        v = CDbl(s)
    End If
 
    ' 如果是百分比
    p = "^(\d+)%$"
    m = Regex.Match(s, p)
    If m.Success Then
        v = CDbl(m.Groups(1).Value) * 0.01
    End If
 
    ' 强制转换为浮点数，面对设置为0或者1的情况
    If isDbl Then
        p = "^(\d+)$"
        m = Regex.Match(s, p)
        If m.Success Then
            v = CDbl(s)
        End If
    End If
 
 
    ' 处理浮点数
    If v >= 0 Then
        If v > 1 Then v = 1
        Return CInt(255 * v)
    End If
 
 
    Dim i As Integer
    Try
        i = CInt(s)
    Catch ex As Exception
        i = 0
    End Try
    If i < 0 Then i = 0
    If i > 255 Then i = 255
 
    Return i
End Function