VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "cSprite_Bitmap" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit '============================================================================================================= ' ' cSprite_Bitmap Module ' --------------------- ' ' Created By : Kevin Wilson ' http://www.TheVBZone.com ( The VB Zone ) ' http://www.TheVBZone.net ( The VB Zone .net ) ' ' Last Update : January 27, 2000 ' ' VB Versions : 5.0 / 6.0 ' ' Requires : modBitmap.bas (Bitmap processing module written by Kevin Wilson) ' ' Description : This module is designed to be used with the "cSprite_Background" class module as an ' easy implementation of a technology or technique called "Sprites". Sprites is a word ' to describe a picture that is drawn with transparency onto a background picture ' repeatedly in different locations. This effect gives the appearance of animation and ' is used in some games. This module handles the the image(s) to be drawn transparently ' onto the background while the "cSprite_Background" class module handles the background ' for the animation to be drawn on. ' ' Example Use : ' ' Option Explicit ' Private cBG As cSprite_Background ' Private cImage(10) As cSprite_Bitmap ' ' Private Sub Form_Load() ' Dim MyCounter As Integer ' Dim PicBG As StdPicture ' Dim PicImg As StdPicture ' Dim TheHeight As Long ' Dim TheWidth As Long ' Set PicBG = LoadPicture("C:\Background.bmp") ' Set PicImg = LoadPicture("C:\Image.bmp") ' ' Convert the measurements of the pictures form their standard measurement (HiMetric) to the Win32 API standard measurement (Pixels). ' Convert_HM_PX PicBG.Height, PicBG.Width, TheHeight, TheWidth, True ' ' Set the form to automatically redraw itself so the images aren't lost ' With Me ' .AutoRedraw = True ' .ScaleMode = vbPixels ' .Left = 0 ' .Top = 0 ' .ScaleHeight = TheHeight ' .ScaleWidth = TheWidth ' .Caption = "Sprite Animation Demo" ' .Show ' End With ' ' Set the picture for the background ' Set cBG = New cSprite_Background ' cBG.hPicture = PicBG.Handle ' cBG.Render Me.hDC ' RefreshHWND Me.hWnd ' ' Set the picture for the sprite and specify the transparency color ' For MyCounter = 0 To 10 ' Set cImage(MyCounter) = New cSprite_Bitmap ' cImage(MyCounter).TransparentColor = CLng("&H00FF00") ' cImage(MyCounter).hPicture = PicImg.Handle ' cImage(MyCounter).Render Me.hDC ' RefreshHWND Me.hWnd ' ' Specify the velocity of the image ' Randomize ' cImage(MyCounter).VelocityX = CLng((10 * Rnd) + 0) ' Randomize ' cImage(MyCounter).VelocityY = CLng((10 * Rnd) + 0) ' If cImage(MyCounter).VelocityX = 0 And cImage(MyCounter).VelocityY = 0 Then ' cImage(MyCounter).VelocityX = 1 ' End If ' Next ' ' Start the loop that draws the sprite animation ' Timer1.Interval = 15 ' Timer1.Enabled = True ' ' Delete the StdPicture objects ' Set PicBG = Nothing ' Set PicImg = Nothing ' End Sub ' ' Private Sub Form_Unload(Cancel As Integer) ' Dim MyCounter As Integer ' Set cBG = Nothing ' For MyCounter = 0 To 10 ' Set cImage(MyCounter) = Nothing ' Next ' End Sub ' ' Private Sub Timer1_Timer() ' Dim MyCounter As Integer ' Dim TempDC As Long ' Dim TempBMP As Long ' Dim PrevBMP As Long ' Dim hScreenDC As Long ' ' Create a buffer to draw to, then paint to the destination... this eliminates flicker and sprite overlap mis-drawing. ' TempDC = MemoryDC_Create ' hScreenDC = GetDC(GetDesktopWindow) ' TempBMP = CreateCompatibleBitmap(hScreenDC, cBG.Width, cBG.Height) ' ReleaseDC GetDesktopWindow, hScreenDC ' LoadPictureToDC TempDC, TempBMP, PrevBMP ' ' Draw the background onto the buffer ' cBG.Render TempDC ' ' Draw the sprites to the buffer ' For MyCounter = 0 To 10 ' With cImage(MyCounter) ' ' Increment the image's location ' .CurrentX = .CurrentX + .VelocityX ' .CurrentY = .CurrentY + .VelocityY ' ' Keep the image within the viewable area ' If .CurrentX > cBG.Width Then .CurrentX = -1 * .Width ' If .CurrentY > cBG.Height Then .CurrentY = -1 * .Height ' ' Draw the image in the new place ' .Render TempDC, .CurrentX, .CurrentY, , , , False ' End With ' Next ' ' Draw the buffer to the destination ' BitBlt Form1.hDC, 0, 0, cBG.Width, cBG.Height, TempDC, 0, 0, SRCCOPY ' RefreshHWND Me.hWnd ' ' Clean up the memory used ' MemoryDC_Delete TempDC, PrevBMP ' End Sub ' '============================================================================================================= ' ' LEGAL: ' ' You are free to use this code as long as you keep the above heading information intact and unchanged. Credit ' given where credit is due. Also, it is not required, but it would be appreciated if you would mention ' somewhere in your compiled program that that your program makes use of code written and distributed by ' Kevin Wilson (www.TheVBZone.com). Feel free to link to this code via your web site or articles. ' ' You may NOT take this code and pass it off as your own. You may NOT distribute this code on your own server ' or web site. You may NOT take code created by Kevin Wilson (www.TheVBZone.com) and use it to create products, ' utilities, or applications that directly compete with products, utilities, and applications created by Kevin ' Wilson, TheVBZone.com, or Wilson Media. You may NOT take this code and sell it for profit without first ' obtaining the written consent of the author Kevin Wilson. ' ' These conditions are subject to change at the discretion of the owner Kevin Wilson at any time without ' warning or notice. Copyright© by Kevin Wilson. All rights reserved. ' '============================================================================================================= '============================================================================================================= ' CLASS PROPERTY VARIABLES '============================================================================================================= Private c_ColorDepth As Integer 'Read Private c_CurX As Long 'Read/Write Private c_CurY As Long 'Read/Write Private c_hDC As Long 'Read Private c_Height As Long 'Read Private c_hPicture As Long 'Read/Write Private c_hMaskDC As Long 'Read/Write Private c_hSpriteDC As Long 'Read/Write Private c_PrevBitmap As Long 'Internal Use Private c_PrevMask As Long 'Internal Use Private c_PrevSprite As Long 'Internal Use Private c_TransColor As Long 'Read/Write Private c_VelocityX As Long 'Read/Write Private c_VelocityY As Long 'Read/Write Private c_Width As Long 'Read '============================================================================================================= ' CLASS EVENTS '============================================================================================================= Private Sub Class_Terminate() Me.Clear End Sub '============================================================================================================= ' CLASS PROPERTIES '============================================================================================================= Public Property Get ColorDepth() As Integer ColorDepth = c_ColorDepth End Property Public Property Get CurrentX() As Long CurrentX = c_CurX End Property Public Property Let CurrentX(ByVal NewValue As Long) c_CurX = NewValue End Property Public Property Get CurrentY() As Long CurrentY = c_CurY End Property Public Property Let CurrentY(ByVal NewValue As Long) c_CurY = NewValue End Property Public Property Get hDC() As Long hDC = c_hDC End Property Public Property Get Height() As Long Height = c_Height End Property Public Property Get hMask() As Long hMask = c_hMaskDC End Property Public Property Get hPicture() As Long hPicture = c_hPicture End Property Public Property Let hPicture(ByVal NewValue As Long) Dim hTempBMP As Long Dim hTempBMP1 As Long Dim TempHeight As Long Dim TempWidth As Long Dim TempClrDpth As Integer ' Clear out the old data Me.Clear ' Create 2 copies of the specified picture... one to be the picture, one to be selected into the DC. ' This is designed this way to make sure that the original picture passed to this class isn't destroyed ' causing problems elsewhere when a picture that is expected to be there has been deleted. If CopyPicture(NewValue, hTempBMP) = False Then Exit Property If CopyPicture(NewValue, hTempBMP1) = False Then Exit Property ' Get the picture's dimentions If GetBitmapInfo(NewValue, TempHeight, TempWidth, TempClrDpth) = False Then Exit Property ' Save the specified picture info c_hPicture = hTempBMP c_Height = TempHeight c_Width = TempWidth c_ColorDepth = TempClrDpth ' Create a memory DC to hold the picture c_hDC = MemoryDC_Create ' Put the picture into the newly created DC c_PrevBitmap = SelectObject(c_hDC, hTempBMP1) ' Create the sprite and mask from the specified picture CreateMask c_hPicture, c_TransColor, c_hSpriteDC, c_hMaskDC, c_PrevSprite, c_PrevMask End Property Public Property Get hSprite() As Long hSprite = c_hSpriteDC End Property Public Property Get TransparentColor() As Long TransparentColor = c_TransColor End Property Public Property Let TransparentColor(ByVal vNewValue As Long) Dim TempClr As Long Dim PrevDelStatus As Boolean If c_hPicture <> 0 Then MsgBox "You can not change the 'TransparentColor' property once the 'hPicture' property is set. The reason for this is because this is used to create the 'hSprite' and 'hMask' DCs. Changing the transparent color would invalidate these." & Chr(13) & Chr(13) & "If you wish to change the 'TransparentColor' property, first use the 'Clear' method to clear the current picture data, then change the 'TransparentColor' property... and lastly reset the 'hPicture' property.", vbOKOnly + vbExclamation, " Can Not Change TransparentColor Property Yet" Exit Property End If TempClr = TranslateColor(vNewValue) If TempClr <> -1 Then c_TransColor = TempClr End Property Public Property Get VelocityX() As Long VelocityX = c_VelocityX End Property Public Property Let VelocityX(ByVal NewValue As Long) c_VelocityX = NewValue End Property Public Property Get VelocityY() As Long VelocityY = c_VelocityY End Property Public Property Let VelocityY(ByVal NewValue As Long) c_VelocityY = NewValue End Property Public Property Get Width() As Long Width = c_Width End Property '============================================================================================================= ' CLASS METHODS '============================================================================================================= Public Sub Clear() ' Delete the memory Device Contexts (DC) and their associated pictures If c_hDC <> 0 Then MemoryDC_Delete c_hDC, c_PrevBitmap If c_hSpriteDC <> 0 Then MemoryDC_Delete c_hSpriteDC, c_PrevSprite If c_hMaskDC <> 0 Then MemoryDC_Delete c_hMaskDC, c_PrevMask If c_hPicture <> 0 Then DeleteObject c_hPicture ' Reset the property variables to the defaults c_hDC = 0 c_hMaskDC = 0 c_hSpriteDC = 0 c_hPicture = 0 c_PrevBitmap = 0 c_PrevMask = 0 c_PrevSprite = 0 c_ColorDepth = 0 c_Height = 0 c_Width = 0 End Sub ' NOTE: If you set the "UseBuffer" parameter to FALSE and set the "Stretch" parameter ' to TRUE... the picture may not draw correctly. I think this could be a problem ' with the Win32 "StretchBlt" API. Public Function Render(ByVal Dest_hDC As Long, _ Optional ByVal X As Long, _ Optional ByVal Y As Long, _ Optional ByVal Stretch As Boolean = False, _ Optional ByVal StretchHeight As Long, _ Optional ByVal StretchWidth As Long, _ Optional ByVal UseBuffer As Boolean = True) As Boolean Dim TempDC As Long Dim TempBMP As Long Dim PrevBMP As Long Dim hScreenDC As Long Dim PrevStrMode As Long ' Make sure there's currently a background picture loaded to be used If c_hPicture = 0 Then Exit Function ' If the user specifies to use a buffer, create a memory DC to work with and copy from there If UseBuffer = True Then TempDC = MemoryDC_Create hScreenDC = GetDC(GetDesktopWindow) TempBMP = CreateCompatibleBitmap(hScreenDC, c_Width, c_Height) PrevBMP = SelectObject(TempDC, TempBMP) ' Copy the portion of the destination to be painted over to work with If Stretch = True Then StretchBlt TempDC, 0, 0, c_Width, c_Height, Dest_hDC, X, Y, StretchWidth, StretchHeight, SRCCOPY Else BitBlt TempDC, 0, 0, c_Width, c_Height, Dest_hDC, X, Y, SRCCOPY End If ' Insert a white silhouette to paint the picture on top of (prevents translucent images) BitBlt TempDC, 0, 0, c_Width, c_Height, c_hMaskDC, 0, 0, MERGEPAINT ' Paint the sprite over the white silhouette to make it apear transparent BitBlt TempDC, 0, 0, c_Width, c_Height, c_hSpriteDC, 0, 0, SRCAND ' Finally, paint the buffered image onto the specified destination If Stretch = True Then If StretchBlt(Dest_hDC, X, Y, StretchWidth, StretchHeight, TempDC, 0, 0, c_Width, c_Height, SRCCOPY) <> 0 Then Render = True Else If BitBlt(Dest_hDC, X, Y, c_Width, c_Height, TempDC, 0, 0, SRCCOPY) <> 0 Then Render = True End If ' Clean up the memory used creating the buffer ReleaseDC GetDesktopWindow, hScreenDC DeleteObject SelectObject(TempDC, PrevBMP) DeleteDC TempDC Else If Stretch = True Then PrevStrMode = SetStretchBltMode(Dest_hDC, COLORONCOLOR) ' This DRAMATICALLY improves the quality of the following stretch operation ' Insert a white silhouette to paint the picture on top of (prevents translucent images) If StretchBlt(Dest_hDC, X, Y, StretchWidth, StretchHeight, c_hMaskDC, 0, 0, c_Width, c_Height, MERGEPAINT) <> 0 Then ' Paint the sprite over the white silhouette to make it apear transparent If StretchBlt(Dest_hDC, X, Y, StretchWidth, StretchHeight, c_hMaskDC, 0, 0, c_Width, c_Height, SRCAND) <> 0 Then Render = True End If End If SetStretchBltMode Dest_hDC, PrevStrMode Else ' Insert a white silhouette to paint the picture on top of (prevents translucent images) If BitBlt(Dest_hDC, X, Y, c_Width, c_Height, c_hMaskDC, 0, 0, MERGEPAINT) <> 0 Then ' Paint the sprite over the white silhouette to make it apear transparent If BitBlt(Dest_hDC, X, Y, c_Width, c_Height, c_hSpriteDC, 0, 0, SRCAND) <> 0 Then Render = True End If End If End If End If End Function