Simple skin for VB - Set the picture property of t - Visual Basic , VB.NET

	Find Code:
Home : Code : Forums : Submit : Mailing List : About : Contact

All

VB.NET

ASP.NET

C#

Snippets

Popular

Forums

Articles

Tips

Links

Books

Contest

Simple skin for VB - Set the picture property of t...
Author: Duncan Jones
Website: http://www.merrioncomputing.com
Submitted: 1/30/2002
Version: VB4
Compatibility: VB4, VB5, VB6
Category: Windows API
Views: 20299
Simple skin for VB - Set the picture property of the form and the background colour to the mask colour and call this and it will shape your form to the picture...
Declarations:
Option Explicit Private Type BITMAP '14 bytes bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long bmPlanes As Integer bmBitsPixel As Integer bmBits 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 biClrUsed As Long biClrImportant As Long End Type Private Type RGBQUAD rgbBlue As Byte rgbGreen As Byte rgbRed As Byte rgbReserved As Byte End Type Private Type BITMAPINFO bmiHeader As BITMAPINFOHEADER bmiColors As RGBQUAD End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type XFORM eM11 As Double eM12 As Double eM21 As Double eM22 As Double eDx As Double eDy As Double End Type Private Type RGNDATAHEADER dwSize As Long iType As Long nCount As Long nRgnSize As Long rcBound As RECT End Type Private Type RGNDATA rdh As RGNDATAHEADER Buffer As Byte End Type Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) 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, ByVal wUsage As Long) As Long Private Declare Function ExtCreateRegion Lib "gdi32" (ByVal lpXform As Long, ByVal nCount As Long, ByVal lpRgnData As Long) As Long Private Declare Sub CopyMemoryByte Lib "kernel32" Alias "RtlMoveMemory" (Destination As Byte, ByVal Source As Long, ByVal Length As Long) Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Const BI_RGB = 0& Private Const DIB_RGB_COLORS = 0 ' color table in RGBs Private Const RGN_OR = 2
Code:
'\\ --[SkinFormByPicture]-------------------------------------------------------------- '\\ Creates the region that corresponds to the given bitmap where the mask colour '\\ is considered external to the region. '\\ ---------------------------------------------------------------------------------- '\\ (c) 2001 Merrion Computing Ltd. All rights reserved '\\ http://www.merrioncomputing.com Public Sub SkinFormByPicture(ByVal ctl As Form, ByVal MaskColour As Long) Dim lret As Long Dim hdcThis As Long Dim BITMAP As Picture Dim biThis As BITMAPINFO Dim bmThis As BITMAP Dim colourBuffer() As Long Dim lIndex As Long, lItem As Long Dim nullXForm As XFORM Dim bInRegion As Boolean Dim numRects As Long Dim rgnThis As RGNDATA Dim lRow As Long Dim lColumn As Long Dim Buffer() As Byte Dim lByteSize As Long Dim rgnTemp As Long Dim rectBuffer() As RECT Set BITMAP = ctl.Picture If Not BITMAP = 0 Then hdcThis = CreateCompatibleDC(ctl.hdc) lret = GetObject(BITMAP.Handle, Len(bmThis), bmThis) If Err.LastDllError = 0 Then With biThis.bmiHeader .biBitCount = 32 .biCompression = BI_RGB .biPlanes = 1 .biSize = Len(biThis.bmiHeader) .biWidth = bmThis.bmWidth .biHeight = bmThis.bmHeight ReDim Preserve colourBuffer(1 To (.biWidth * .biHeight)) As Long End With lret = GetDIBits(hdcThis, BITMAP.Handle, 0, bmThis.bmHeight, colourBuffer(1), biThis, DIB_RGB_COLORS) '\\ Note: NT4 quirk - bitmap must be read upside down For lRow = (biThis.bmiHeader.biHeight - 1) To 0 Step -1 For lColumn = 0 To (biThis.bmiHeader.biWidth - 1) lIndex = (lColumn + (lRow * biThis.bmiHeader.biWidth)) + 1 '\\ If at the end of a column, close any rectangle... If lColumn = 0 Then bInRegion = False End If If (MaskColour = colourBuffer(lIndex)) Then '\\ Colour matches mask colour. bInRegion = False Else '\\ Colour is not mask colour If bInRegion Then rectBuffer(numRects).Right = lColumn + 1 Else '\\ Start a new region rectangle... numRects = numRects + 1 ReDim Preserve rectBuffer(1 To numRects) As RECT With rectBuffer(numRects) .Left = lColumn .Top = (biThis.bmiHeader.biHeight) - lRow .Bottom = .Top + 1 .Right = .Left + 1 End With bInRegion = True End If End If Next lColumn Next lRow '\\ Now create a region object from this data With rgnThis.rdh .iType = 1 .dwSize = Len(rgnThis.rdh) .nRgnSize = .dwSize + (numRects * Len(rectBuffer(1))) .nCount = numRects .rcBound.Left = 0 .rcBound.Top = 0 .rcBound.Right = bmThis.bmWidth .rcBound.Bottom = bmThis.bmHeight End With If Err.LastDllError = 0 Then lByteSize = LenB(rgnThis) lByteSize = lByteSize + (numRects * Len(rectBuffer(1))) - 1 '\\ copy the region data to the buffer ReDim Buffer(lByteSize) As Byte CopyMemoryByte Buffer(0), VarPtr(rgnThis.rdh), Len(rgnThis.rdh) CopyMemoryByte Buffer(Len(rgnThis.rdh) - 1), VarPtr(rectBuffer(1)), numRects * Len(rectBuffer(1)) lret = ExtCreateRegion(ByVal 0&, lByteSize, ByVal VarPtr(Buffer(0))) If Err.LastDllError = 0 Then If lret = 0 Then '\\ Have to resort to the slow method.... With rectBuffer(1) lret = CreateRectRgn(.Left, .Top, .Right, .Bottom) End With For lIndex = 2 To UBound(rectBuffer) With rectBuffer(lIndex) rgnTemp = CreateRectRgn(.Left, .Top, .Right, .Bottom) Call CombineRgn(lret, lret, rgnTemp, RGN_OR) DeleteObject rgnTemp End With Next lIndex End If Call SetWindowRgn(ctl.hWnd, lret, True) End If End If End If If hdcThis <> 0 Then Call DeleteDC(hdcThis) End If End If End Sub 'use.... Private Sub Form_Load() Call SkinFormByPicture(Me, Me.BackColor) End Sub