Cool Multicolored Worksheet Cells and with Gradient -No XL2007 required :)

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,245
Office Version
  1. 2016
Platform
  1. Windows
Hi all,

Here is a workbook example http://www.datafilehost.com/download-917323fd.html that shows how, with a bit of trickery, you can apply a gradient to XL2000 & XL2003 worksheet cells
thus simulating the XL2007 CF new feature.

With a bit of more tweaking, the same principle i applied in the code can be used to make MultiColored cells as well as performing basic InCell charting !

This is for educational purposes and is by no means a robust solution but it was challenging and i've never seen this done before. Maybe some day with some more work this cool functionality can be improved on.

Current limitations:

- U Cannot change the Column width or Row height of the Range to which this technique is applied.
- The code uses a timer which is not a stable coding approach but was needed to make the
coloring persistent after editing the worksheet.
- The change of worksheet Zoom may sometimes affect the results.
- Memory leaks may occur : Please save your work before trying this !!


Here is the code in a standard module:

Code:
Option Base 1
Option Explicit
 
Enum ColorConstantes
 
    White = 1
    Black = 8
    Red = 10
    Green = 11
    Brown = 16
    Pink = 33
    Yellow = 34
    Blue = 48
    Orange = 52
    Gray = 67
 
End Enum
 
Private Type Rect
 
    Left As Double
    Top As Double
    Right As Double
    Bottom As Double
 
End Type
 
 
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" ( _
ByVal hwnd As Long) As Long
 
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) As Long
 
Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90
Const PointsPerInch = 72
 
Private Declare Function ReleaseDC Lib "user32" ( _
ByVal hwnd As Long, ByVal hdc As Long) As Long
 
Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long
 
Private Declare Function InvalidateRect _
Lib "user32" (ByVal hwnd As Long, _
lpRect As Long, ByVal bErase As Long) As Long
 
Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal nPlanes As Long, _
ByVal nBitCount As Long, lpBits As Any) As Long
 
Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
(ByVal hdc As Long, ByVal nWidth As Long, _
ByVal nHeight As Long) As Long
 
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long
 
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
 
Private Declare Function BitBlt Lib "gdi32" _
(ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hSrcDC As Long, ByVal xSrc As Long, _
ByVal ySrc As Long, ByVal dwRop As Long) As Long
 
Private Const SRCCOPY = &HCC0020
Private Const SRCAND = &H8800C6
 
Declare Function SetBkColor Lib "gdi32" _
(ByVal hdc As Long, ByVal crColor As Long) As Long
 
Private Declare Function SetTimer Lib "user32" _
(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
 
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
 
Private lTimerID        As Long
Private oTargetRange    As Range
Private lhDC            As Long
Private lMemoryDC       As Long
 
Sub CopyShapeFill _
(ByRef TargetRange As Range, ByVal Color As ColorConstantes, _
ByVal Gradient As Boolean)
 
    Dim lbmp As Long
    Dim i As Long
    Dim oTempShape As Shape
    Dim tRect As Rect
 
    If lTimerID Then GoTo Warning
 
    With TargetRange
        Set oTempShape = .Parent.Shapes.AddShape _
        (msoShapeRectangle, .Cells(1).Left, .Cells(1).Top, _
        .Cells(1).Width, .Cells(1).Height)
        With oTempShape
            .Line.Visible = msoFalse
            If Gradient Then
                .Fill.BackColor.SchemeColor = 1 'white
                .Fill.ForeColor.SchemeColor = Color
                .Fill.TwoColorGradient msoGradientVertical, 1
            Else
                .Fill.BackColor.SchemeColor = Color
                .Fill.ForeColor.SchemeColor = Color
                .Fill.TwoColorGradient msoGradientVertical, 1
            End If
        End With
    End With
 
    With GetObjRect(oTempShape)
        lhDC = GetDC(0)
        lMemoryDC = CreateCompatibleDC(lhDC)
        lbmp = CreateCompatibleBitmap _
        (lhDC, .Right - .Left, .Bottom - .Top)
        lbmp = SelectObject(lMemoryDC, lbmp)
        DeleteObject (lbmp)
        BitBlt lMemoryDC, 0, 0, .Right - .Left, _
        .Bottom - .Top, lhDC, .Left, .Top, SRCCOPY
    End With
    oTempShape.Delete
    Set oTargetRange = TargetRange
    DeleteObject (lbmp)
    lTimerID = SetTimer(0, 0, 100, AddressOf TimerProc)
    Exit Sub
Warning:
    MsgBox "Press the 'Finish' button to Start again", vbCritical
 
End Sub
 
Private Function GetObjRect(Obj As Object) As Rect
 
    Const PointsPerInch As Long = 72
    Dim hdc As Long
    Dim lDevCapsX As Double
    Dim lDevCapsY As Double
    Dim lCurZoom As Double
    Dim tRect As Rect
 
    lhDC = GetDC(0)
    lCurZoom = (ActiveWindow.Zoom / 100)
    lDevCapsX = _
    (GetDeviceCaps(lhDC, LOGPIXELSX) / PointsPerInch * lCurZoom)
    lDevCapsY = _
    (GetDeviceCaps(lhDC, LOGPIXELSY) / PointsPerInch * lCurZoom)
    With ActiveWindow
        tRect.Left = _
        .PointsToScreenPixelsX(Obj.Left * lDevCapsX)
        tRect.Top = _
        .PointsToScreenPixelsY(Obj.Top * lDevCapsY)
        tRect.Right = _
        .PointsToScreenPixelsX _
        ((Obj.Left + Obj.Width) * lDevCapsX)
        tRect.Bottom = _
        .PointsToScreenPixelsY _
        ((Obj.Top + Obj.Height) * lDevCapsY)
    End With
    ReleaseDC 0, lhDC
    DeleteDC (lhDC)
    GetObjRect = tRect
 
End Function
 
Private Sub TimerProc()
 
    Dim k As Long
    Dim lhDC As Long
    On Error Resume Next
    If Intersect(ActiveWindow.VisibleRange, oTargetRange).Address _
    <> oTargetRange.Address Then
 
    Else
        lhDC = GetDC(0)
        For k = 1 To oTargetRange.Cells.Count
            With GetObjRect(oTargetRange.Cells(k))
                BitBlt lhDC, .Left, .Top, _
                (.Right - .Left) * oTargetRange.Cells(k), _
                .Bottom - .Top, lMemoryDC, 0, 0, SRCAND
            End With
        Next k
 
        ReleaseDC 0, lhDC
        DeleteDC (lhDC)
 
   End If
 
End Sub
 
 
Sub Terminate()
 
    KillTimer 0, lTimerID
    lTimerID = 0
    ReleaseDC 0, lhDC
    ReleaseDC 0, lMemoryDC
    DeleteDC (lMemoryDC)
    DeleteDC (lhDC)
    InvalidateRect 0&, 0&, False
 
End Sub

To test the Code run the following test codes -Change the Targent Range as required:

Code:
 Sub Test1()
 
    Call CopyShapeFill _
    (TargetRange:=Sheets(1).Range("d6:d11"), Color:=Blue, Gradient:=True)
 
End Sub
 
Sub Test2()
 
    Call CopyShapeFill _
    (TargetRange:=Sheets(1).Range("d6:d11"), Color:=Blue, Gradient:=False)
 
End Sub

Note: The code uses the Enum Keyword which I believe wasn't introduced until XL2000 meaning that testing the code in XL97 will generate a compiler error- This can be easily overcome by
writing the Color Constantes directly into the Test Sub Color Argument.

Regards.
 
Last edited:

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Has anybody taken the trouble to test the workbook link ? :)

I would love to know if this works as expected in other machines .

Regards.
 
Upvote 0
didn't work too well for me

I ran the Test1 macro, which worked beautifully, but then I reopened the VBA code editor, which put that window on top of the excel spreadsheet window
and the blue cell colors on the worksheet underneath showed in the VBA editor, so the colors "bled" through the window
 
Upvote 0
didn't work too well for me

I ran the Test1 macro, which worked beautifully, but then I reopened the VBA code editor, which put that window on top of the excel spreadsheet window
and the blue cell colors on the worksheet underneath showed in the VBA editor, so the colors "bled" through the window


Thanks for the feedback james.

Yes, that is something that i will work on next.

What version of Windows and Excel are you using James ?

Regards.
 
Upvote 0
ADVERTISEMENT
Here is an update of the demo workbook : http://www.datafilehost.com/download-538cbf64.html

this simple line at the start of the TimerProc Procedure prevented the colors from showing through overlapping windows :

Code:
If GetForegroundWindow <> Application.hwnd Then Exit Sub

I am still trying to figure out how I can best overcome the problem associated with the refreshing of the cells color when resizing the Cells.

Regards.
 
Upvote 0
Darn it Jaafar! I was just getting ready to go to bed when I saw you had posted. Well, I simply could *not* go to bed without seeing what you're up to! :biggrin:

I gave it a try on Excel 2007, 2003 & then 2002 under Vista 64. A bit twitchy. For me even though Excel was on top it looked like the windows underneath bled through - I could see text from IE8 showing through into the XL2007 window. Then when I opened in 2003 & 2002 it seemed like something was held in memory in the bars for though I had minimized IE8, I still saw text from the previous XL2007 session - though 2007 was now closed.

Also I only seem to really be getting a gradient fill in the top cell the other cells are not really showing gradient fills.

I really do need to get to bed. Perhaps tomorrow I can try taking some screen shots to see if I can capture and share what I'm seeing.

Great to see you on the boards!

Take care,
 
Upvote 0
ADVERTISEMENT
Darn it Jaafar! I was just getting ready to go to bed when I saw you had posted. Well, I simply could *not* go to bed without seeing what you're up to! :biggrin:

I gave it a try on Excel 2007, 2003 & then 2002 under Vista 64. A bit twitchy. For me even though Excel was on top it looked like the windows underneath bled through - I could see text from IE8 showing through into the XL2007 window. Then when I opened in 2003 & 2002 it seemed like something was held in memory in the bars for though I had minimized IE8, I still saw text from the previous XL2007 session - though 2007 was now closed.

Also I only seem to really be getting a gradient fill in the top cell the other cells are not really showing gradient fills.

I really do need to get to bed. Perhaps tomorrow I can try taking some screen shots to see if I can capture and share what I'm seeing.

Great to see you on the boards!

Take care,


Thanks Greg. Long time no see :)

Have u tried the updated workbook in the second Link ? : http://www.datafilehost.com/download-538cbf64.html

I fixed that and seems to work on my machine pretty well. I don't get the bleding and all the cells are filled not just the top one.

Thanks for the interest.
 
Upvote 0
Yes, I only used the second WB.

I read that many security related settings have been tightened in Windows Vista making programming on Win32 more troublesome.

I don't have access to Win Vista so i couldn't tell.

A case in point is using a WH_JOURNALPLAYBACK hook that records and play back Keyboard and Mouse actions.I was told it doesn't work under Win Vista. Here is an attempt that you may want to take a look at that implements this hook on Win XP (See my last post here) :http://www.mrexcel.com/forum/showthread.php?t=377491

Regards.
 
Upvote 0

Forum statistics

Threads
1,196,205
Messages
6,014,002
Members
441,802
Latest member
Aneurysm

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top