Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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 Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) 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 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 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 LoadImage Lib "user32" Alias "LoadImageA" _
(ByVal hInst As Long, ByVal lpsz As String, ByVal iType As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal fOptions As Long) As Long
Private Const IMAGE_BITMAP = 0
Private Const LR_LOADFROMFILE = &H10
Private Const SRCCOPY = &HCC0020
Public Sub fnTileWindow( _
ByVal lhWnd As Long, ByVal sTileFile As String, ByVal lTileNo As Long, _
Optional ByVal lTileWidth As Long = 32, _
Optional ByVal lTileHeight As Long = 32, _
Optional lTilesPerRow As Long = 1)
' lhWnd = Handle of Window to Tile
' sTileFile = Location of Bitmap File to use which contains 1 or more tiles.
' lTileNo = Tile No. to use, (reading tiles left to right, top to bottom.)
' lTileWidth = Width of Each Tile in the Tile Bitmap
' lTileHeight = Height of Each Tile in the Tile Bitmap
' lTilesPerRow = No. of tiles in each row of the Bitmap
Dim lDC As Long, lTileDC As Long
Dim lDestDC As Long
Dim lTileBmp As Long, lBmp As Long
Dim tRECT As RECT
Dim lSrcTileX As Long, lSrcTileY As Long
Dim x As Long, y As Long
Dim lTileCountX As Long, lTileCountY As Long
Dim lDestWidth As Long, lDestHeight As Long
' Determine the X/Y Coords of the Source Tile within the Tiles Image
lSrcTileX = ((lTileNo - 1) Mod lTilesPerRow) * lTileWidth
lSrcTileY = ((lTileNo - 1) / lTilesPerRow) * lTileHeight
' Get the Dimensions of the Client area of the window to tile
Call GetClientRect(lhWnd, tRECT)
' Calculate the Window's Width/Height
lDestWidth = tRECT.Right - tRECT.Left
lDestHeight = tRECT.Bottom - tRECT.Top
' Get the Window's DC
lDestDC = GetDC(lhWnd)
' Create 2 Compatible Device Contexts', 1 for the Buffer the
' other for the Tiles Image
lDC = CreateCompatibleDC(lDestDC)
lTileDC = CreateCompatibleDC(lDestDC)
' Load the Tiles Bitmap
lTileBmp = LoadImage(0, sTileFile, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)
' Select the Tiles Bitmap into the Buffer DC
Call SelectObject(lDC, lTileBmp)
' Create a Bitmap Compatible with the Tiles Bitmap which is as
' big as the target window's client area in the Buffer DC
lBmp = CreateCompatibleBitmap(lDC, lDestWidth, lDestHeight)
' Select the Buffer BMP into the Buffer DC
Call SelectObject(lDC, lBmp)
' Select the Tiles BMP into the Tiles DC
Call SelectObject(lTileDC, lTileBmp)
' Calculate how many tiles it'll take to tile the window
lTileCountX = lDestWidth / lTileWidth
lTileCountY = lDestHeight / lTileHeight
' Start drawing the tiles to the Buffer DC
For y = 0 To lTileCountY
For x = 0 To lTileCountX
BitBlt lDC, x * lTileWidth, y * lTileHeight, lTileWidth, lTileHeight, _
lTileDC, lSrcTileX, lSrcTileY, SRCCOPY
Next
Next
' Copy the whole Buffer to the Destination Window in one go.
BitBlt lDestDC, 0, 0, lDestWidth, lDestHeight, lDC, 0, 0, SRCCOPY
' Clean Up the DC's and BMP's
Call DeleteDC(lDC)
Call DeleteDC(lTileDC)
Call ReleaseDC(lhWnd, lDestDC)
Call DeleteObject(lBmp)
Call DeleteObject(lTileBmp)
End Sub
