Excel Dark Mode Macro (Forget Waiting for Microsoft)


dacrone

dacrone

Well-known member
Guru
VIP
Local time
7:16 PM
Posts
4,592
OS
Windows 11 Pro
here is the macro that i have been working on. perhaps someone a bit better than i can fix the few small issues i have remaining:

1) if a cell has a custom border (actually, only some border styles,.. not all) that is set to black or white manually, it does not invert (thus if you set a white border in light mode, it will remain white in dark mode (again some styles, not all)

2) if a cell contains (example) red and black text, the black text is not inverted when dark mode is applied.
*it will, however, invert all cells that are solid black/white (with the except of cells that have filled colors - ie: if you have black text and a yellow fill, it leaves that text alone)

If you can fix these before i do, please update us. thanks.

Code: 
Function StyleExists(styleName As String) As Boolean
    On Error Resume Next
    StyleExists = Not ActiveWorkbook.Styles(styleName) Is Nothing
End Function

Function HexToRGB(hex As String) As Long
    Dim nohash As String
    Dim red As Long, green As Long, blue As Long

    nohash = Replace(hex, "#", "")
    red = CLng("&H" & Mid(nohash, 1, 2))
    green = CLng("&H" & Mid(nohash, 3, 2))
    blue = CLng("&H" & Mid(nohash, 5, 2))

    HexToRGB = RGB(red, green, blue)
End Function

Function CustomPropertyExists(propName As String) As Boolean
    Dim docProp As DocumentProperty

    For Each docProp In ActiveWorkbook.CustomDocumentProperties
        If docProp.Name = propName Then
            CustomPropertyExists = True
            Exit Function
        End If
    Next

    CustomPropertyExists = False
End Function

Function BackupStyleName(styleName As String) As String
    BackupStyleName = styleName & "_DARKMODE_BACKUP"
End Function

Function ApplyStyleToSelection(styleName As String)
    Dim cell As Range

    For Each cell In Selection
        If cell.MergeArea.Cells.Count = 1 Then
            cell.Style = styleName
        End If
    Next cell
End Function

Sub SetAllTableStyle(styleName As String)
    Dim tbl As ListObject
    Dim sht As Worksheet

    For Each sht In ActiveWorkbook.Worksheets
        For Each tbl In sht.ListObjects
            tbl.TableStyle = styleName
        Next tbl
    Next sht
End Sub

Function UpdateStyleColors(styleName As String, _
    Optional fillColorHex As String, _
    Optional fontColorHex As String, _
    Optional borderColorHex As String, _
    Optional borderLineStyle As XlLineStyle, _
    Optional interiorPattern As XlPattern)

    On Error Resume Next

    With ActiveWorkbook.Styles(styleName)
        .IncludeFont = True
        .IncludeBorder = True
        .IncludePatterns = True
    End With

    With ActiveWorkbook.Styles(styleName)
        If Not IsMissing(fillColorHex) Then .Interior.Color = HexToRGB(fillColorHex)
        If Not IsMissing(fontColorHex) Then .Font.Color = HexToRGB(fontColorHex)

        If Not IsMissing(borderColorHex) Then
            .Borders(xlLeft).Color = HexToRGB(borderColorHex)
            .Borders(xlRight).Color = HexToRGB(borderColorHex)
            .Borders(xlTop).Color = HexToRGB(borderColorHex)
            .Borders(xlBottom).Color = HexToRGB(borderColorHex)
        End If

        If borderLineStyle <> 0 Then
            .Borders(xlLeft).LineStyle = borderLineStyle
            .Borders(xlRight).LineStyle = borderLineStyle
            .Borders(xlTop).LineStyle = borderLineStyle
            .Borders(xlBottom).LineStyle = borderLineStyle
        End If

        If interiorPattern <> 0 Then .Interior.Pattern = interiorPattern
    End With
End Function

Function ApplyDarkStyle(styleName As String, _
    Optional fillColorHex As String, _
    Optional fontColorHex As String, _
    Optional borderColorHex As String)

    On Error Resume Next

    With ActiveWorkbook.Styles(styleName)
        .IncludeFont = True
        .IncludeBorder = True
        .IncludePatterns = True
    End With

    If Not StyleExists(BackupStyleName(styleName)) Then
        ActiveWorkbook.Styles.Add (BackupStyleName(styleName))
    End If

    With ActiveWorkbook.Styles(BackupStyleName(styleName))
        If Not IsMissing(fillColorHex) Then .Interior.Color = ActiveWorkbook.Styles(styleName).Interior.Color
        If Not IsMissing(fontColorHex) Then
            .Font.Color = ActiveWorkbook.Styles(styleName).Font.Color
            .Font.Name = ActiveWorkbook.Styles(styleName).Font.Name ' Keep original font
            .Font.Size = ActiveWorkbook.Styles(styleName).Font.Size
            .Font.Bold = ActiveWorkbook.Styles(styleName).Font.Bold
        End If

        If Not IsMissing(borderColorHex) Then
            .Borders(xlLeft).Color = ActiveWorkbook.Styles(styleName).Borders(xlLeft).Color
            .Borders(xlRight).Color = ActiveWorkbook.Styles(styleName).Borders(xlRight).Color
            .Borders(xlTop).Color = ActiveWorkbook.Styles(styleName).Borders(xlTop).Color
            .Borders(xlBottom).Color = ActiveWorkbook.Styles(styleName).Borders(xlBottom).Color

            .Borders(xlLeft).LineStyle = ActiveWorkbook.Styles(styleName).Borders(xlLeft).LineStyle
            .Borders(xlRight).LineStyle = ActiveWorkbook.Styles(styleName).Borders(xlRight).LineStyle
            .Borders(xlTop).LineStyle = ActiveWorkbook.Styles(styleName).Borders(xlTop).LineStyle
            .Borders(xlBottom).LineStyle = ActiveWorkbook.Styles(styleName).Borders(xlBottom).LineStyle
        End If

        .Interior.Pattern = ActiveWorkbook.Styles(styleName).Interior.Pattern
    End With

    With ActiveWorkbook.Styles(styleName)
        If Not IsMissing(fillColorHex) Then .Interior.Color = HexToRGB(fillColorHex)
        If Not IsMissing(fontColorHex) Then
            .Font.Color = HexToRGB(fontColorHex)
            .Font.Name = ActiveWorkbook.Styles(styleName).Font.Name ' Keep original font
            .Font.Size = ActiveWorkbook.Styles(styleName).Font.Size
            .Font.Bold = ActiveWorkbook.Styles(styleName).Font.Bold
        End If

        If Not IsMissing(borderColorHex) Then
            .Borders(xlLeft).Color = HexToRGB(borderColorHex)
            .Borders(xlRight).Color = HexToRGB(borderColorHex)
            .Borders(xlTop).Color = HexToRGB(borderColorHex)
            .Borders(xlBottom).Color = HexToRGB(borderColorHex)
        End If
    End With
End Function

Function RestoreLightStyle(styleName As String)
    On Error Resume Next

    With ActiveWorkbook.Styles(styleName)
        .Interior.Color = ActiveWorkbook.Styles(BackupStyleName(styleName)).Interior.Color
        .Font.Color = ActiveWorkbook.Styles(BackupStyleName(styleName)).Font.Color
        .Font.Name = ActiveWorkbook.Styles(BackupStyleName(styleName)).Font.Name
        .Font.Size = ActiveWorkbook.Styles(BackupStyleName(styleName)).Font.Size
        .Font.Bold = ActiveWorkbook.Styles(BackupStyleName(styleName)).Font.Bold

        .Borders(xlLeft).Color = ActiveWorkbook.Styles(BackupStyleName(styleName)).Borders(xlLeft).Color
        .Borders(xlRight).Color = ActiveWorkbook.Styles(BackupStyleName(styleName)).Borders(xlRight).Color
        .Borders(xlTop).Color = ActiveWorkbook.Styles(BackupStyleName(styleName)).Borders(xlTop).Color
        .Borders(xlBottom).Color = ActiveWorkbook.Styles(BackupStyleName(styleName)).Borders(xlBottom).Color

        .Borders(xlLeft).LineStyle = ActiveWorkbook.Styles(BackupStyleName(styleName)).Borders(xlLeft).LineStyle
        .Borders(xlRight).LineStyle = ActiveWorkbook.Styles(BackupStyleName(styleName)).Borders(xlRight).LineStyle
        .Borders(xlTop).LineStyle = ActiveWorkbook.Styles(BackupStyleName(styleName)).Borders(xlTop).LineStyle
        .Borders(xlBottom).LineStyle = ActiveWorkbook.Styles(BackupStyleName(styleName)).Borders(xlBottom).LineStyle

        .Interior.Pattern = ActiveWorkbook.Styles(BackupStyleName(styleName)).Interior.Pattern
    End With

    ActiveWorkbook.Styles(BackupStyleName(styleName)).Delete
End Function

Sub ToggleBlackWhiteFontAndBorders()
    Dim ws As Worksheet, cell As Range
    Dim border As border
    Dim blackColor As Long: blackColor = RGB(0, 0, 0)
    Dim whiteColor As Long: whiteColor = RGB(255, 255, 255)
    Dim fontColor As Variant
    Dim isDarkFont As Boolean

    ' Loop through all worksheets
    For Each ws In ActiveWorkbook.Worksheets
        ' Loop through all used cells
        For Each cell In ws.UsedRange
            If cell.MergeCells Then GoTo SkipCell

            fontColor = cell.Font.Color
            If Not IsNull(fontColor) Then
                ' Check if the font is close to black (within a certain range)
                isDarkFont = (fontColor = blackColor) Or (fontColor < RGB(50, 50, 50))
            Else
                isDarkFont = False
            End If

            ' If font is black or dark, change it to white and add a comment to track it
            If isDarkFont And cell.Interior.Color = blackColor Then
                cell.Font.Color = whiteColor
                If cell.Comment Is Nothing Then
                    cell.AddComment "DarkFontSwapped"
                    cell.Comment.Visible = False
                End If
            End If

            ' Swap border colors if necessary
            For Each border In cell.Borders
                If border.LineStyle <> xlLineStyleNone Then
                    If border.Color = blackColor Then
                        border.Color = whiteColor
                    ElseIf border.Color = whiteColor Then
                        border.Color = blackColor
                    End If
                End If
            Next border
SkipCell:
        Next cell
    Next ws
End Sub

Sub RestoreBlackFontsFromDarkMode()
    Dim ws As Worksheet, cell As Range
    Dim whiteColor As Long: whiteColor = RGB(255, 255, 255)
    Dim blackColor As Long: blackColor = RGB(0, 0, 0)

    ' Loop through all worksheets
    For Each ws In ActiveWorkbook.Worksheets
        ' Loop through all used cells
        For Each cell In ws.UsedRange
            If Not cell.Comment Is Nothing Then
                If cell.Comment.Text = "DarkFontSwapped" Then
                    If Not IsNull(cell.Font.Color) Then
                        If cell.Font.Color = whiteColor Then
                            cell.Font.Color = blackColor
                        End If
                    End If
                    cell.Comment.Delete
                End If
            End If
        Next cell
    Next ws
End Sub

Function DarkModeWithBackup()
    Call SetAllTableStyle("TableStyleDark1")
    Call ApplyDarkStyle("Normal", "#000000", "#FFFFFF", "#454545")
    Call ApplyDarkStyle("Heading 1", "#000000", "#FFFFFF")
    Call ApplyDarkStyle("Heading 2", "#000000", "#FFFFFF")
    Call ApplyDarkStyle("Heading 3", "#000000", "#FFFFFF")
    Call ApplyDarkStyle("Heading 4", "#000000", "#FFFFFF")
    Call ApplyDarkStyle("Title", "#000000", "#FFFFFF")
    Call ApplyDarkStyle("Total", "#000000", "#FFFFFF")
    Call ApplyDarkStyle("Note", "#B2B2B2", "#000000", "#454545")
    Call ApplyDarkStyle("Explanatory Text", "#000000", "#FFFFFF", "#454545")
End Function

Function LightModeFromBackup()
    Call SetAllTableStyle("TableStyleLight1")
    Call RestoreLightStyle("Normal")
    Call RestoreLightStyle("Heading 1")
    Call RestoreLightStyle("Heading 2")
    Call RestoreLightStyle("Heading 3")
    Call RestoreLightStyle("Heading 4")
    Call RestoreLightStyle("Title")
    Call RestoreLightStyle("Total")
    Call RestoreLightStyle("Note")
    Call RestoreLightStyle("Explanatory Text")
End Function

Sub ToggleDarkMode()
    Application.ScreenUpdating = False
    Dim flag As String: flag = "DARK_MODE_0292"

    If Not CustomPropertyExists(flag) Then
        ActiveWorkbook.CustomDocumentProperties.Add Name:=flag, Value:=0, _
            LinkToContent:=False, Type:=msoPropertyTypeNumber
    End If

    If ActiveWorkbook.CustomDocumentProperties(flag).Value = 1 Then
        ActiveWorkbook.CustomDocumentProperties(flag).Value = 0
        Call RestoreBlackFontsFromDarkMode
        Call LightModeFromBackup
    Else
        ActiveWorkbook.CustomDocumentProperties(flag).Value = 1
        Call DarkModeWithBackup
        Call ToggleBlackWhiteFontAndBorders
    End If

    Application.ScreenUpdating = True
End Sub

See my post here on how to add it to your ribbon (use as a template how-to):

Change cursor color in Excel 2021, W11 Pro

This is driving me nuts. The curson in Excel 2021 is almost invisible to me which makes working in Excel very frustrating as I hunt for the cursor all over the screen. I searched on the web but none of the solutions worki for me. Most tell you to open Excel Options/advanced/Display but I can...
www.elevenforum.com www.elevenforum.com

original baseline code that i modified from:
github.com

GitHub - stu-bell/ExcelDarkMode: Customisable dark mode for Excel cell backgrounds

Customisable dark mode for Excel cell backgrounds. Contribute to stu-bell/ExcelDarkMode development by creating an account on GitHub.
github.com github.com
 

My Computer

System One

  • OS
    Windows 11 Pro
You must log in or register to reply here.

Latest Support Threads

Latest Tutorials

Back
Top Bottom