Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,596
- Office Version
- 2016
- Platform
- 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:
To test the Code run the following test codes -Change the Targent Range as required:
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.
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 SubTo 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 SubNote: 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:
