We will be migrating from Ask to Discourse on the first week of August, read the details here

Ask Your Question

change cell background color with mouse click

asked 2020-05-31 11:26:41 +0200

cybersurfer5000 gravatar image


I would like to change the cell background color of the calender days J3:U33 (image below) via a mouse click. The cell should change to 3 different colors if you keep clicking that cell.

image description

Below macro from JohnSUN (link to his post and example file) is great! and does change the cell's background color.

Option Explicit
Option Base 0

Public oMouseClickHandler   

Sub RegisterMouseClickHandler
   oMouseClickHandler =  createUnoListener("MouseOnClick_", "com.sun.star.awt.XMouseClickHandler")
End Sub

Sub UnregisterMouseClickHandler
    On Error Resume Next
    On Error GOTO 0
End Sub

Sub MouseOnClick_disposing(oEvt)
End Sub

Function MouseOnClick_mousePressed(oEvt) As Boolean
    MouseOnClick_mousePressed = False
End Function

Function MouseOnClick_mouseReleased(oEvt) As Boolean
Dim oCell As Object
Dim oSheet As Object
Dim nColumn%, nRow%
Dim tmp
Dim colors

    MouseOnClick_mouseReleased = False
    colors = Array(RGB(119,188,101), RGB(255,109,109), RGB(221,221,221), RGB(221,221,221))
    oCell = ThisComponent.getCurrentSelection()
    If oCell.getImplementationName() <> "ScCellObj" Then Exit Function
    oSheet = oCell.getSpreadsheet()

    nColumn = oCell.getCellAddress().Column
    nRow = oCell.getCellAddress().Row

    If (nColumn < 5) AND (nRow < 5) Then
            oCell.CellBackColor = colors(Int((cntClick())/5) MOD UBound(colors))
        ElseIf (nColumn = 5) AND (nRow = 5) Then
            tmp =  oCell.LeftBorder
            On Error Resume Next
            tmp.InnerLineWidth = 50 
            tmp.LineWidth = 40
            On Error GOTO 0
            For nColumn = 0 To 4
                For nRow = 0 To 4
                    oCell = oSheet.getCellByPosition(nColumn, nRow)
                    tmp.Color = oCell.CellBackColor
                    If tmp.Color > -1 Then
                        oCell.LeftBorder = tmp
                        oCell.BottomBorder = tmp
                        oCell.RightBorder = tmp
                        oCell.TopBorder = tmp
                Next nRow
            Next nColumn
    End Function
Function cntClick(Optional newValue%) As Long
Dim oNamedRanges As Object
Dim oNamedRange As Object
Dim sContent As String
Dim iRes%
Const varName = "cntClick"
    oNamedRanges = ThisComponent.NamedRanges
    If not oNamedRanges.hasByName(varName) Then oNamedRanges.addNewByName(varName, _
    oNamedRange = oNamedRanges.getByName(varName)
    If IsMissing(newValue) Then
        sContent = oNamedRange.getContent()
        iRes = Val(sContent)+1
        oNamedRange.setContent("" & iRes)
        cntClick = iRes
        oNamedRange.setContent("" & newValue)
        cntClick = newValue
    End If
End Function

QUESTION: However, I need to edit the code (I am a total noob when it comes to macros), so that it applies to cells J3:U33 (in his example, it applies to A1:E5 -> "red circle" in image below). Does anyone know how to edit the row thats circled red, or has an alternative solution to change the background color via a mouse click?

I know it is a monster of a post for a question like this, but a wanted to make sure I explain myself correctly.

Thank you Sophie

edit retag flag offensive close merge delete


Hi. JohnSun has commented his code but in Russian so suggested people use Google translate to read the comments. These comments are likely to help you to answer your question, e.g.

    If (nColumn < 5) AND (nRow < 5) Then    ' This is area A1: E5
REM And now cntClick () will increase the click count by one and return that number

Rem and ' are comments and don't form part of the code

Earnest Al gravatar imageEarnest Al ( 2020-06-05 09:11:52 +0200 )edit

1 Answer

Sort by » oldest newest most voted

answered 2020-07-23 12:01:02 +0200

JohnSUN gravatar image

Oh Sophie, this is too long code - hard to read and hard to edit. For your task, the macro code is much shorter:

Function onDblClick(oEvent As Variant) As Boolean
Const RANGE_TO_COLORIZE = "J3:U33"  ' Set a range address that will respond to double clicks '
Dim colors As Variant
Dim i As Integer
    onDblClick = False
    If oEvent.getSpreadsheet().getCellRangeByName(RANGE_TO_COLORIZE).queryIntersection(oEvent.getRangeAddress()).getCount() Then 
        onDblClick = True
        colors = Array(-1, RGB(255,0,0), RGB(0,255,0), RGB(0,0,255)) ' -1 is "default color" (white), set values to other '
        For i = LBound(colors) To UBound(colors)
            If oEvent.CellBackColor = colors(i) Then
                oEvent.CellBackColor = colors((i + 1) Mod 4)    ' Current color found, set next '
                Exit Function
        Next i
        oEvent.CellBackColor = colors(0)    ' Current color not found and not default, set default '
End Function

Just assign this function to handle the desired event

Set macro to DblClick event.png

Demo - C:\fakepath\ColorDblClick.ods

edit flag offensive delete link more


Wonderful! THANK YOU @JohnSUN

cybersurfer5000 gravatar imagecybersurfer5000 ( 2020-08-31 02:11:59 +0200 )edit
Login/Signup to Answer

Question Tools

1 follower


Asked: 2020-05-31 11:26:41 +0200

Seen: 246 times

Last updated: Jul 23 '20