Metallic Background Colours / Other Colours

thorpyuk · Oct 29, 2007

Hiya,

Does anyone know if this is possible? The idea came about after wanting to show a 'gold' 'silver' and 'bronze' background colour, but having to plump for yellow, grey and orange looked a little crap :f

Does anyone know if this is possible?

If not, can a workaround be created by using code and a picture or 2?

Thanks guys

ADAMC · Oct 29, 2007

http://www.mrexcel.com/board2/viewtopic.php?t=298779&highlight=

This post i started on inserting pictrues might help.....

Legacy 98055 · Oct 29, 2007

You can use any valid picture that you wish. Here is a built in custom background designer using Excel's autoshapes. Download the workbook to see how it works. It simply resizes an autoshape to the visible range, takes its picture, and then sets that picture as the worksheets background. The third example shows how to use a group to design a background with a watermark.

Example Download: WorkSheetBackgroundDesigner.zip

<table width="100%" border="1" bgcolor="White" style="filter

rogid:DXImageTransform.Microsoft.Gradient(endColorstr='#C0CFE2', startColorstr='#FFFFFF', gradientType='0');"><tr><TD> Option Explicit

 Private Type PicInformation
 Length As Long
 PicType As Long
 Handle As Long
 NotUsedHere As Long
 End Type

 Private Type GUID
 Data1 As Long
 Data2 As Integer
 Data3 As Integer
 Data4(7) As Byte
 End Type

 Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicInformation, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
 Private Declare Function CloseClipboard Lib "user32" () As Long
 Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
 Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
 Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long

 Private Const CF_BITMAP As Long = 2
 Private Const OLE_PICTYPE_BITMAP = 1

 Sub Example1()
 Shape2SheetBG Sheet1.Shapes("Rectangle 1"), Sheet2
 End Sub

 Sub Example2()
 Shape2SheetBG Sheet1.Shapes("Rectangle 2"), Sheet2
 End Sub

 Sub Example3()
 Shape2SheetBG Sheet1.Shapes("Group 1"), Sheet2
 End Sub

 Sub Example4()
 Shape2SheetBG Sheet1.Shapes("Rectangle 4"), Sheet2
 End Sub

 Private Sub Shape2SheetBG(sh As Shape, ApplyToWs As Worksheet)
 Dim PicPtr As Long, Pic As IPictureDisp, IIG As GUID, PicInfo As PicInformation
 Dim OldWidth As Single, OldHeight As Single

 Application.ScreenUpdating = False
 ApplyToWs.Activate

 OldWidth = sh.Width
 OldHeight = sh.Height

 With ActiveWindow
 sh.Width = .VisibleRange.Width
 sh.Height = .VisibleRange.Height
 End With

 sh.CopyPicture , xlBitmap
 OpenClipboard 0
 If IsClipboardFormatAvailable(CF_BITMAP) = 0 Then Exit Sub
 PicPtr = GetClipboardData(CF_BITMAP)
 CloseClipboard

 With IIG
 .Data1 = &H7BF80980
 .Data2 = &HBF32
 .Data3 = &H101A
 .Data4(0) = &H8B
 .Data4(1) = &HBB
 .Data4(3) = &HAA
 .Data4(5) = &H30
 .Data4(6) = &HC
 .Data4(7) = &HAB
 End With

 With PicInfo
 .Length = Len(PicInfo)
 .PicType = OLE_PICTYPE_BITMAP
 .Handle = PicPtr
 End With

 OleCreatePictureIndirect PicInfo, IIG, True, Pic
 SavePicture Pic, "C:\Users\Tom\Documents\TempWsBg.bmp"
 ApplyToWs.SetBackgroundPicture "C:\Users\Tom\Documents\TempWsBg.bmp"

 sh.Width = OldWidth
 sh.Height = OldHeight
 End Sub
</td></tr></table><button onclick='document.all("1029200712813621").value=document.all("1029200712813621").value.replace(/ \s\s/g,"");document.all("1029200712813621").value=document.all("1029200712813621").value.replace(/ /g,"");window.clipboardData.setData("Text",document.all("1029200712813621").value);'>Copy to Clipboard</BUTTON><textarea style="position:absolute;visibility:hidden" name="1029200712813621" wrap="virtual">
Option Explicit

Private Type PicInformation
Length As Long
PicType As Long
Handle As Long
NotUsedHere As Long
End Type

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicInformation, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long

Private Const CF_BITMAP As Long = 2
Private Const OLE_PICTYPE_BITMAP = 1

Sub Example1()
Shape2SheetBG Sheet1.Shapes("Rectangle 1"), Sheet2
End Sub

Sub Example2()
Shape2SheetBG Sheet1.Shapes("Rectangle 2"), Sheet2
End Sub

Sub Example3()
Shape2SheetBG Sheet1.Shapes("Group 1"), Sheet2
End Sub

Sub Example4()
Shape2SheetBG Sheet1.Shapes("Rectangle 4"), Sheet2
End Sub

Private Sub Shape2SheetBG(sh As Shape, ApplyToWs As Worksheet)
Dim PicPtr As Long, Pic As IPictureDisp, IIG As GUID, PicInfo As PicInformation
Dim OldWidth As Single, OldHeight As Single

Application.ScreenUpdating = False
ApplyToWs.Activate

OldWidth = sh.Width
OldHeight = sh.Height

With ActiveWindow
sh.Width = .VisibleRange.Width
sh.Height = .VisibleRange.Height
End With

sh.CopyPicture , xlBitmap
OpenClipboard 0
If IsClipboardFormatAvailable(CF_BITMAP) = 0 Then Exit Sub
PicPtr = GetClipboardData(CF_BITMAP)
CloseClipboard

With IIG
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(3) = &HAA
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With

With PicInfo
.Length = Len(PicInfo)
.PicType = OLE_PICTYPE_BITMAP
.Handle = PicPtr
End With

OleCreatePictureIndirect PicInfo, IIG, True, Pic
SavePicture Pic, "C:\Users\Tom\Documents\TempWsBg.bmp"
ApplyToWs.SetBackgroundPicture "C:\Users\Tom\Documents\TempWsBg.bmp"

sh.Width = OldWidth
sh.Height = OldHeight
End Sub</textarea>

eblake · Oct 29, 2007

Not sure if this will help any, but here is a site I use when I have to dump stuff from our website to excel so we can keep the colors as close as possible...

http://www.mvps.org/dmcritchie/excel/colors.htm

thorpyuk · Nov 2, 2007

Hmmm...

Thanks for your replies guys.. I couldnt download the example right_click, and didn't manage to get the example to work. All it seemed to do was to make my picture blank!

Does anyone else have any ideas?

Are more colours not available in VBA?

Legacy 98055 · Nov 2, 2007

Is anyone else having trouble downloading from the link? I just downloaded it without any problem. My server is not local.

Scott Huish · Nov 2, 2007

Are more colours not available in VBA?

You can define colors with RGB, but Excel (at least pre-XL2007) is limited to the color palette. Any colors defined with RGB will change to what Excel thinks is the closest color in the pallette.

So if you want other colors, you need to change the color pallete.

thorpyuk · Nov 5, 2007

Well, i'm not too interested in other colours, I just want a nice metallic (silver, gold etc) background behind my cells.....

Sorry right_click, it wasn't your link that was bad, it's my internet server here at work that wont allow me to download .exe files. If it was a .xls file i'd have no problems

Legacy 98055 · Nov 5, 2007

It's a zip file. Here is an xls of the same.

WorkSheetBackgroundDesigner.xls

Scott Huish · Nov 5, 2007

Well, i'm not too interested in other colours, I just want a nice metallic (silver, gold etc) background behind my cells....

I think you misunderstand what I'm getting at. If you want to use the standard fills, and want a gold then you have to put that color in the pallette. Now it would just be a gold color, not reflective like metal or anything.

Metallic Background Colours / Other Colours

thorpyuk

Well-known Member

Excel Facts

ADAMC

Well-known Member

Legacy 98055

Guest

eblake

Active Member

thorpyuk

Well-known Member

Legacy 98055

Guest

Scott Huish

MrExcel MVP

thorpyuk

Well-known Member

Legacy 98055

Guest

Scott Huish

MrExcel MVP

Similar threads

Forum statistics

Share this page

Metallic Background Colours / Other Colours

thorpyuk

Well-known Member

Excel Facts

ADAMC

Well-known Member

Legacy 98055

Guest

eblake

Active Member

thorpyuk

Well-known Member

Legacy 98055

Guest

Scott Huish

MrExcel MVP

thorpyuk

Well-known Member

Legacy 98055

Guest

Scott Huish

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock