'// have fun, and put it to good use
'//
'// still have some things to add up
'// RESOURCE:
'// http://www.flipcode.com/articles/article_win32skins.shtml
'// http://www.vbwm.com/articles/builder/viewer.asp?ArticleID=16&CurrentPage=1
Option Compare Database
Option Explicit
'// module level constants
Private Const conGraphiixFolder As String * 7 = "\files\"
'// General Api Declarations
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' API INFO:
' The SetWindowRgn function sets the window region of a window. The window region
' determines the area within the window where the system permits drawing. The system
' does not display any portion of a window that lies outside of the window region
'
' PARAMETER(S):
' hWnd
' [in] Handle to the window whose window region is to be set.
' hRgn
' [in] Handle to a region. The function sets the window region of the window to
' this region. If hRgn is NULL, the function sets the window region to NULL.
' bRedraw
' [in] Specifies whether the system redraws the window after setting the window region.
' If bRedraw is TRUE, the system does so; otherwise, it does not.
'
' Typically, you set bRedraw to TRUE if the window is visible.
'
' SOURCE(S):
' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/gdi/pantdraw_2him.asp
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Public Declare Function SetWindowRgn Lib "user32" ( _
ByVal hWnd As Long, _
ByVal hRgn As Long, _
ByVal bRedraw As Boolean) As Long
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' API INFO:
' The DeleteObject function deletes a logical pen, brush, font, bitmap, region, or
' palette, freeing all system resources associated with the object. After the object is
' deleted, the specified handle is no longer valid.
'
' PARAMETER(S):
' hObject
' [in] Handle to a logical pen, brush, font, bitmap, region, or palette.
'
' SOURCE(S):
' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/gdi/devcons_1vsk.asp
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Public Declare Function DeleteObject Lib "gdi32" ( _
ByVal hObject As Long) As Long
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' API INFO:
' The CreateCompatibleDC function creates a memory device context (DC) compatible with
' the specified device.
'
' PARAMETER(S):
' hdc
' [in] Handle to an existing DC. If this handle is NULL, the function creates a
' memory DC compatible with the application's current screen
'
' SOURCE(S):
' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/gdi/devcons_499f.asp
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
ByVal hdc As Long) As Long
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' API INFO:
' The SelectObject function selects an object into the specified device context (DC).
' The new object replaces the previous object of the same type.
' PARAMETER(S):
' hDc
' [in] Handle to the DC.
' hgdiObj
' [in] Handle to the object to be selected. The specified object must have been
' created by using one of the following functions.
'
' Bitmap - CreateBitmap, CreateBitmapIndirect, CreateCompatibleBitmap,
' CreateDIBitmap, CreateDIBSection
' (Bitmaps can be selected for memory DCs only, and for only one DC at a time.)
' Brush - CreateBrushIndirect, CreateDIBPatternBrush, CreateDIBPatternBrushPt,
' CreateHatchBrush, CreatePatternBrush, CreateSolidBrush
' Font - CreateFont, CreateFontIndirect
' Pen - CreatePen, CreatePenIndirect
' Region - CombineRgn, CreateEllipticRgn, CreateEllipticRgnIndirect,
' CreatePolygonRgn, CreateRectRgn, CreateRectRgnIndirect
'
' SOURCE(S):
' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/gdi/devcons_9v3o.asp
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Private Declare Function SelectObject Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal hgdiObj As Long) As Long
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' API INFO:
' The GetObject function retrieves information for the specified graphics object.
'
' PARAMETER(S):
' hgdiObj
' [in] Handle to the graphics object of interest. This can be a handle to one of
' the following: a logical bitmap, a brush, a font, a palette, a pen, or
' a device independent bitmap created by calling the CreateDIBSection function.
' cbBuffer
' [in] Specifies the number of bytes of information to be written to the buffer.
' lpvObject
' [out] Pointer to a buffer that receives the information about the specified graphics object.
'
' SOURCE(S):
' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/gdi/devcons_912s.asp
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" ( _
ByVal hdiObj As Long, _
ByVal cbBuffer As Long, _
lpvObject As Any) As Long
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' API INFO:
' The CreateRectRgn function creates a rectangular region.
'
' PARAMETER(S):
' nLeftRect
' [in] Specifies the x-coordinate of the upper-left corner of the region in logical units.
' nTopRect
' [in] Specifies the y-coordinate of the upper-left corner of the region in logical units.
' nRightRect
' [in] Specifies the x-coordinate of the lower-right corner of the region in logical units.
' nBottomRect
' [in] Specifies the y-coordinate of the lower-right corner of the region in logical units.
'
' SOURCE(S):
' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/gdi/regions_2h0u.asp
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Private Declare Function CreateRectRgn Lib "gdi32" ( _
ByVal nLeftRect As Long, _
ByVal nTopRect As Long, _
ByVal nRightRect As Long, _
ByVal nBottomRect As Long) As Long
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' API INFO:
' The CombineRgn function combines two regions and stores the result in a third region.
' The two regions are combined according to the specified mode.
'
' PARAMETER(S):
' hRgnDest
' [in] Handle to a new region with dimensions defined by combining two other regions.
' (This region must exist before CombineRgn is called.)
' hRgnSrc1
' [in] Handle to the first of two regions to be combined.
' hRgnSrc2
' [in] Handle to the second of two regions to be combined.
' fnCombineMode
' [in] Specifies a mode indicating how the two regions will be combined. This parameter
' can be one of the following values.
'
' RGN_AND - Creates the intersection of the two combined regions.
' RGN_COPY - Creates a copy of the region identified by hrgnSrc1.
' RGN_DIFF - Combines the parts of hrgnSrc1 that are not part of hrgnSrc2.
' RGN_OR - Creates the union of two combined regions.
' RGN_XOR - Creates the union of two combined regions except for any overlapping areas.
'
' SOURCE(S):
' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/gdi/regions_7tf2.asp
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Private Declare Function CombineRgn Lib "gdi32" ( _
ByVal hRgnDest As Long, _
ByVal hRgnSrc1 As Long, _
ByVal hRgnSrc2 As Long, _
ByVal fnCombineMode As Long) As Long
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' API INFO:
' The DeleteDC function deletes the specified device context (DC).
'
' PARAMETER(S):
' hDc
' [in] Handle to the device context.
'
' SOURCE(S):
' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/gdi/devcons_2p2b.asp
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Private Declare Function DeleteDC Lib "gdi32" ( _
ByVal hdc As Long) As Long
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' API INFO:
' The GetPixel function retrieves the red, green, blue (RGB) color value of the pixel
' at the specified coordinates.
'
' PARAMETER(S):
' hDC
' [in] Handle to the device context.
' nXPos
' [in] Specifies the x-coordinate, in logical units, of the pixel to be examined.
' nYPos
' [in] Specifies the y-coordinate, in logical units, of the pixel to be examined.
'
' SOURCE(S):
' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/gdi/bitmaps_0rho.asp
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Private Declare Function GetPixel Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal nXPos As Long, _
ByVal nYPos As Long) As Long
Private Type typPicStructure
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Const RGN_OR As Long = 4
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' PURPOSE:
' Point of entry to shape the form to a bitmap
'
' PARAMETER(S):
' [in] frm - (form object)
' The form accepting the new shaped region
' [in] stPictureName - (string)
' The name of the bitmap (myfilename.bmp) image to be used for the shape
' [in] TransparentColor - (long)
' The color value to be used as transparency, it could the access format or
' as RGB(0,0,0)
' [in] OPTIONAL FolderPath (string)
' The name of the path of the folder where the image is located
' [in] OPTIONAL IndexCollection (boolean)
' True if the handle to the new shaped region is to be added to a collection
' to prevent rescanning over and over the same form.
'
' RETURNS:
'
' REWRITTEN:
'
' AUTHOR: xyon x-avier hernández(dgh)
' (xyon_x@yahoo.com)
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Public Function fInitFormShape( _
frm As Form, _
stPictureName As String, _
TransparentColor As Long, _
Optional FolderPath As String, _
Optional IndexCollection As Boolean) As Boolean
'// dimension variables
Dim F As Form
Dim objBitmap As StdPicture
Dim hRgn As Long
'// in the event of an error process to our
'// predefined error handler
On Error GoTo Err_finitformshape
'// set the new picture to scan
Set objBitmap = fLoadShapedPicture(frm, stPictureName)
'// first check if the image is found to avoid
'// any errors down the line, if the image to be used
'// is not a valid one then exit the function
If objBitmap Is Nothing Then Exit Function
'// create object instance
'// of the form to be shaped
Set F = frm
'// reference the created instance
With F
'// function to create shaped region region
'// and return the handle to the new shaped region
'// which resides in the system's memory buffer
hRgn = fCreateShapedRegion(objBitmap, TransparentColor)
'// set the new shaped region of our form
SetWindowRgn .hWnd, hRgn, True
fInitFormShape = True
End With
Exit_finitformshape:
'// clean up
Set F = Nothing
Set objBitmap = Nothing
'// delete region from memory
DeleteObject hRgn
Exit Function
Err_finitformshape:
'// notify user of error
MsgBox Err.Number & " : " & Err.Description, vbOKOnly, "Microsoft Access Error"
'// resume to exit the funtion
Resume Exit_finitformshape
End Function
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' PURPOSE:
' the fFileExists function checks if a file exist
'
' PARAMETER(S):
' [in] stFileName (string)
' The path and name of the file to check for
'
' RETURNS:
' TRUE, if the file is found
' FALSE, if the file is not found
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Private Function fFileExists(stFileName) As Boolean
'// dimension variable(s)
Dim objFSO As Object
'// create FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'// return True if file is found
'// return False if not
fFileExists = objFSO.FileExists(stFileName)
'// clean up
Set objFSO = Nothing
End Function
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' PURPOSE:
' The fLoadShapedPicture creates a picture from a specified file using the
' LoadPicture("ImageFile") function
'
' PARAMETER(S):
' [in] frm (form object)
' The form to accept the new shaped region
' [in] PictureName (string)
' The name of the picture to use in the forms' shape, to include the .bmp extension
' RETURNS:
' StdPicture object if successfull
' Nothing if fails
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Private Function fLoadShapedPicture(frm As Form, PictureName As String) As StdPicture
On Error Resume Next
'// dimension varible(s)
Dim stBitmapPath As String
Dim iWidth As Integer
Dim iHeight As Integer
'// assign picture name & path
stBitmapPath = CurrentProject.Path & conGraphiixFolder & PictureName
'// check for file
If fFileExists(stBitmapPath) Then
'// reference the background image control
With frm.Controls("imgFormBG")
'// load the picture to the form's
'// background image control
.Picture = stBitmapPath
'// move image control to align to form
'// if you ommit this you will some parts of
'// image display the transparent color
.top = 10
.left = 10
'// get image dimensions
iWidth = .ImageWidth
iHeight = .ImageHeight
'// rezise the form to match picture
.Parent.InsideWidth = iWidth
.Parent.InsideHeight = iHeight + 10
'// resize image control to match image
.Width = iWidth
.Height = iHeight
End With
'// load and return the picture data
Set fLoadShapedPicture = LoadPicture(stBitmapPath)
'//Else
'// notify user image was not found
'// MsgBox "The background image for this form was not found.", vbOKOnly + vbInformation
End If
End Function
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' PURPOSE:
' Make an image shaped form by scanning the image passed to it and then remove all
' lines that correspond to the transparent colour, creating a new virtual image, but
' without a specified colour
'
' PARAMETER(S):
' [In] BitmapPicture - (StdPicture)
' The StdPicture OBJECT enables you to manipulate bitmaps, icons, metafiles ,
' enhanced metafiles, GIF, and JPEG images assigned to objects having a
' Picture property.
' [In] TransColor = the color to be used for transparency
'
' RETURNS:
' LONG - The handle to the new shaped region
' =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Private Property Get fCreateShapedRegion( _
BitmapPicture As StdPicture, _
TransColor As Long) As Long
'// dimension variable(s)
Dim hRgn As Long
Dim tmpRgn As Long
Dim lngRow As Integer
Dim lngCol As Integer
Dim lngPosition As Integer
Dim hdc As Long
Dim pic As typPicStructure
Dim lngTransColor As Long
'// assign transparent color
lngTransColor = TransColor
'// create a new memory DC(Device Context),
'// where we will scan the picture
hdc = CreateCompatibleDC(0)
'// if the DC exist process procedure
If hdc Then
'// let the new DC select the Picture
SelectObject hdc, BitmapPicture
'// get the picture dimensions
GetObject BitmapPicture, Len(pic), pic
'// create a new empty rectangular region using the
hRgn = CreateRectRgn(0, 0, pic.bmWidth, pic.bmHeight)
'// scan the picture pixel by pixel from top to bottom
For lngRow = 0 To pic.bmHeight
'// scan the picture pixel by pixel from left to right
For lngCol = 0 To pic.bmWidth
'// scan and skip non-transparent pixels
While lngCol <= pic.bmWidth And GetPixel(hdc, lngCol, lngRow) <> lngTransColor
'// add 1 to the variable lngCol
'// and we move to the next pixel
lngCol = lngCol + 1
Wend
'// remember the position of the first transparent pixel
lngPosition = lngCol
'// scan a line for transparent pixels
While lngCol <= pic.bmWidth And GetPixel(hdc, lngCol, lngRow) = lngTransColor
'// add 1 to the variable lngCol
'// and move to the next pixel
lngCol = lngCol + 1
Wend
If lngPosition < lngCol Then
'// create a new temporary transparent region and return it's handle
tmpRgn = CreateRectRgn(lngPosition, lngRow, lngCol, lngRow + 1)
'// combine the two regions
CombineRgn hRgn, hRgn, tmpRgn, RGN_OR
'// release memory, delete temporary region
DeleteObject tmpRgn
End If
Next lngCol
Next lngRow
'// return the handle to the new shaped region
fCreateShapedRegion = hRgn
'// release memory by deleting the hDc
DeleteObject SelectObject(hdc, BitmapPicture)
End If
'// clean up, release memory by deleting the created DC
DeleteDC hdc
End Property
