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

Ask Your Question
0

change cell background color with mouse click

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

cybersurfer5000 gravatar image

Hello.

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")
   ThisComponent.getCurrentController().addMouseClickHandler(oMouseClickHandler)
   cntClick(-1)
End Sub

Sub UnregisterMouseClickHandler
    On Error Resume Next
    ThisComponent.getCurrentController().removeMouseClickHandler(oMouseClickHandler)
    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
                    oCell.clearContents(1023)
                    If tmp.Color > -1 Then
                        oCell.LeftBorder = tmp
                        oCell.BottomBorder = tmp
                        oCell.RightBorder = tmp
                        oCell.TopBorder = tmp
                    EndIf
                Next nRow
            Next nColumn
            cntClick(-1)
        EndIf
    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, _
        "-1",createUNOStruct("com.sun.star.table.CellAddress"),0)
    oNamedRange = oNamedRanges.getByName(varName)
    If IsMissing(newValue) Then
        sContent = oNamedRange.getContent()
        iRes = Val(sContent)+1
        oNamedRange.setContent("" & iRes)
        cntClick = iRes
    Else
        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

Comments

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
2

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
            EndIf 
        Next i
        oEvent.CellBackColor = colors(0)    ' Current color not found and not default, set default '
    EndIf 
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

Comments

Wonderful! THANK YOU @JohnSUN

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

Question Tools

1 follower

Stats

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

Seen: 246 times

Last updated: Jul 23 '20