'*******************************
' // This code Sets the BackColor of
' // Pages on a Multipage Control.(Excel)
'*******************************
Option Explicit
'=============================
' // Private Declarations..
'=============================
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Private Type BITMAPINFOHEADER '40 bytes
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biRUsed As Long
biRImportant As Long
End Type
' A BITMAPINFO structure for bitmaps with no color palette.
Private Type BITMAPINFO_NoColors
bmiHeader As BITMAPINFOHEADER
End Type
Private Type BITMAPFILEHEADER
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Private Type MemoryBitmap
hdc As Long
hbm As Long
oldhDC As Long
wid As Long
hgt As Long
bitmap_info As BITMAPINFO_NoColors
End Type
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) _
As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) _
As Long
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
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 DeleteObject Lib "gdi32" _
(ByVal hObject As Long) _
As Long
Private Declare Function CreateDIBSection Lib "gdi32" _
(ByVal hdc As Long, pBitmapInfo As BITMAPINFO_NoColors, _
ByVal un As Long, ByVal lplpVoid As Long, _
ByVal handle As Long, ByVal dw As Long) _
As Long
Private Declare Function GetDIBits Lib "gdi32" _
(ByVal aHDC As Long, ByVal hBitmap As Long, ByVal _
nStartScan As Long, ByVal nNumScans As Long, _
lpBits As Any, lpBI As BITMAPINFO_NoColors, _
ByVal wUsage As Long) _
As Long
Private Declare Function SetRect Lib "user32" _
(lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, _
ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetBkMode Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal nBkMode As Long) _
As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long
Private Declare Function FillRect Lib "user32" _
(ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal nIndex As Long) As Long
Private Const DIB_RGB_COLORS = 0&
Private Const BI_RGB = 0&
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const POINTSPERINCH As Long = 72
'=============================
' // Public Routines.
'=============================
Public Sub SetBackColor(Page As MSForms.Page, Color As Long)
Const sBMPFile As String = "C:\Temp.bmp"
Dim memory_bitmap As MemoryBitmap
' Create the memory bitmap.
memory_bitmap = MakeMemoryBitmap _
(Page)
' Draw on the bitmap.
DrawOnMemoryBitmap memory_bitmap, Color
' Save the bmp.
Call SaveMemoryBitmap(memory_bitmap, sBMPFile)
' load the bmp onto the page.
Set Page.Picture = LoadPicture(sBMPFile)
' Delete the memory bitmap.
DeleteMemoryBitmap memory_bitmap
' Delete BMP file.
Kill sBMPFile
End Sub
'=============================
' // Private Routines.
'=============================
' Make a memory bitmap according to the MultiPage size.
Private Function MakeMemoryBitmap _
(Page As MSForms.Page) As MemoryBitmap
Dim result As MemoryBitmap
Dim bytes_per_scanLine As Long
Dim pad_per_scanLine As Long
Dim new_font As Long
' Create the device context.
result.hdc = CreateCompatibleDC(0)
' Define the bitmap.
With result.bitmap_info.bmiHeader
.biBitCount = 32
.biCompression = BI_RGB
.biPlanes = 1
.biSize = Len(result.bitmap_info.bmiHeader)
.biWidth = PTtoPX(Page.Parent.Parent.InsideWidth, 0)
.biHeight = PTtoPX(Page.Parent.Parent.InsideHeight, 1)
bytes_per_scanLine = ((((.biWidth * .biBitCount) + _
31) \ 32) * 4)
pad_per_scanLine = bytes_per_scanLine - (((.biWidth _
* .biBitCount) + 7) \ 8)
.biSizeImage = bytes_per_scanLine * Abs(.biHeight)
End With
' Create the bitmap.
result.hbm = CreateDIBSection( _
result.hdc, result.bitmap_info, _
DIB_RGB_COLORS, ByVal 0&, _
ByVal 0&, ByVal 0&)
' Make the device context use the bitmap.
result.oldhDC = SelectObject(result.hdc, result.hbm)
' Return the MemoryBitmap structure.
result.wid = PTtoPX(Page.Parent.Parent.InsideWidth, 0)
result.hgt = PTtoPX(Page.Parent.Parent.InsideHeight, 1)
MakeMemoryBitmap = result
End Function
Private Sub DrawOnMemoryBitmap( _
memory_bitmap As _
MemoryBitmap, Color As Long _
)
Dim LB As LOGBRUSH, tRect As RECT
Dim hBrush As Long
LB.lbColor = Color
'Create a new brush
hBrush = CreateBrushIndirect(LB)
With memory_bitmap
SetRect tRect, 0, 0, .wid, .hgt
End With
SetBkMode memory_bitmap.hdc, 2 'Opaque
'Paint the mem dc.
FillRect memory_bitmap.hdc, tRect, hBrush
End Sub
' Save the memory bitmap into a bitmap file.
Private Sub SaveMemoryBitmap( _
memory_bitmap As MemoryBitmap, _
ByVal file_name As String _
)
Dim bitmap_file_header As BITMAPFILEHEADER
Dim fnum As Integer
Dim pixels() As Byte
' Fill in the BITMAPFILEHEADER.
With bitmap_file_header
.bfType = &H4D42 ' "BM"
.bfOffBits = Len(bitmap_file_header) + _
Len(memory_bitmap.bitmap_info.bmiHeader)
.bfSize = .bfOffBits + _
memory_bitmap.bitmap_info.bmiHeader.biSizeImage
End With
' Open the output bitmap file.
fnum = FreeFile
Open file_name For Binary As fnum
' Write the BITMAPFILEHEADER.
Put [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=fnum]#fnum[/URL] , , bitmap_file_header
' Write the BITMAPINFOHEADER.
' (Note that memory_bitmap.bitmap_info.bmiHeader.biHeight
' must be positive for this.)
Put [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=fnum]#fnum[/URL] , , memory_bitmap.bitmap_info
' Get the DIB bits.
ReDim pixels(1 To 4, _
1 To memory_bitmap.wid, _
1 To memory_bitmap.hgt)
GetDIBits memory_bitmap.hdc, memory_bitmap.hbm, _
0, memory_bitmap.hgt, pixels(1, 1, 1), _
memory_bitmap.bitmap_info, DIB_RGB_COLORS
' Write the DIB bits.
Put [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=fnum]#fnum[/URL] , , pixels
' Close the file.
Close fnum
End Sub
' Delete the bitmap and free its resources.
Private Sub DeleteMemoryBitmap( _
memory_bitmap As MemoryBitmap _
)
SelectObject memory_bitmap.hdc, memory_bitmap.oldhDC
DeleteObject memory_bitmap.hbm
DeleteDC memory_bitmap.hdc
End Sub
Private Function ScreenDPI(bVert As Boolean) As Long
Static lDPI(1), lDC
If lDPI(0) = 0 Then
lDC = GetDC(0)
lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
lDC = ReleaseDC(0, lDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function PTtoPX _
(Points As Single, bVert As Boolean) As Long
PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function
