for discussing your code and the basic concept of sprites. I hope it offers some insights.
-
I started a thread here:
for discussing your code and the basic concept of sprites. I hope it offers some insights. -
PlgBlt CopyBitMapEx
I saw a listing by Patrice demostrating PlgBlt and was pretty impressed. I incorporated the call into CopyBitMapEx to get scaling and rotation. PlgBlt does require a 1 bit mask but it is pretty straight forward to use. Thanks Patrice.
Code:'CopyBitmapEx by Jim Klutho Nov 24,2010 'Attempt to use Powerbasic's built in graphic commands to combine PlgBlt and Alphablending 'This version has multiple red ball to show the burden of alphablending with the technique used 'PBWin 9.05 ' PlgBlt version for rotation and scaling ' Requires a bitmap monochrome mask ' Thanks to Patrice Terrier for posting a PlgBlt example that got me interested in this API call. #COMPILE EXE #DIM ALL #INCLUDE "WIN32API.INC" '--------Constants----------------------- %NUMBALLS = 20 %IDC_TRANS = 1000 %IDM_FILE_EXIT = 1001 %IDM_TOGGLEALPHA = 1002 %IDM_TOGGLETEXT = 1003 %IDM_TOGGLESCALE = 1004 %IDM_TOGGLEROTATE = 1005 '----------Types------------------------ TYPE BallType x AS LONG y AS LONG v AS LONG 'velocity a AS LONG 'alpha 1 to 255 s AS LONG 'scale 10 to 100 % r AS LONG 'MyAngle 1 to 360 degrees dx AS LONG dy AS LONG END TYPE '----------Macros------------------------ MACRO Pi = 3.141592653589793## MACRO HalfPI = 1.5707963267948965## MACRO DegreesToRadians(Deg) = Deg * 0.0174532925199432957## '--------Globals------------------------ GLOBAL lpPoint AS POINTAPI GLOBAL hMenu AS DWORD GLOBAL hDlg AS LONG GLOBAL hBoard AS DWORD GLOBAL hBmp AS DWORD GLOBAL Bkgnd AS DWORD GLOBAL Ball AS DWORD GLOBAL dx,dy AS LONG GLOBAL BkgndDC AS DWORD GLOBAL BallDC AS DWORD GLOBAL hBoardDC AS DWORD GLOBAL RedBalls() AS BallType GLOBAL AlphaToggle AS LONG GLOBAL TextToggle AS LONG GLOBAL ScaleToggle AS LONG GLOBAL RotateToggle AS LONG GLOBAL MyFont AS LONG GLOBAL hBallBitMapMask,hTempBallBitMapMask AS DWORD SUB CopyBitMapEx(BYVAL MyTargetDest AS LONG,BYVAL xDest AS LONG, BYVAL yDest AS LONG, _ BYVAL hSrcBmp AS LONG, BYVAL x AS LONG,BYVAL y AS LONG,BYVAL nWidth AS LONG, BYVAL nHeight AS LONG, _ BYVAL Alpha AS BYTE,BYVAL BitMapMask AS LONG,BYVAL MyAngle AS LONG,BYVAL MyScale AS LONG,BYVAL MyScaleBitMapMask AS LONG) LOCAL BF AS BLENDFUNCTION LOCAL hDestDC AS LONG LOCAL hSrcDC AS LONG LOCAL hTempBmp,hTempBmpPlgBlt,hTempBGBmpPlgBlt AS LONG LOCAL hTempDC,hTempPlgBltDC,hTempBGPlgBltDC AS LONG DIM PlgPts(0 TO 8) AS POINTAPI LOCAL TempRect,MaskRect AS RECT LOCAL dx,dy,xd,yd AS LONG LOCAL HalfWidth, HalfHeight AS LONG LOCAL sCos1 AS SINGLE LOCAL sSin1 AS SINGLE LOCAL sCos2 AS SINGLE LOCAL sSin2 AS SINGLE LOCAL AngleRad AS SINGLE LOCAL TransColor AS LONG ' LOCAL MonoDC,hTempBitMapMask AS LONG LOCAL DestBitMapDC,SrcBitMapDC,OldObject1,OldObject2 AS LONG GRAPHIC ATTACH hSrcBmp, 0 'Ball bitmpa GRAPHIC GET DC TO hSrcDC 'DC to ball bitmap '--------------------------------------------- TempRect.nTop=yDest TempRect.nLeft=xDest TempRect.nRight=xDest + nWidth TempRect.nBottom = yDest + nHeight xd =XDest: yd=YDest 'Scale can be from 10% the size to 200% the size of the original bitmap IF MyScale => 10 AND MyScale <= 100 THEN LOCAL s AS SINGLE s = 1 - MyScale/100 dx= CLNG(nWidth * s)/2 dy= CLNG(nHeight * s)/2 ELSE dx= 0 dy= 0 END IF '-------------------------------------------- 'For BitBlt PlgPts(6).x=TempRect.nLeft PlgPts(6).y=TempRect.nTop PlgPts(7).x=TempRect.nRight PlgPts(7).y=TempRect.nTop PlgPts(8).x=TempRect.nLeft PlgPts(8).y=TempRect.nBottom ' Get half picture size and angle in radians HalfWidth = (nWidth - (2 * dx)) \ 2 : HalfHeight = (nHeight-(2 * dx))\ 2 AngleRad = DegreesToRadians(MyAngle) sCos1 = COS(AngleRad) * HalfWidth sSin1 = SIN(AngleRad) * HalfWidth sCos2 = COS(AngleRad + HalfPi) * HalfHeight sSin2 = SIN(AngleRad + HalfPi) * HalfHeight IF MyAngle = 0 THEN PlgPts(0).x=TempRect.nLeft + dx PlgPts(0).y=TempRect.nTop + dy PlgPts(1).x=TempRect.nRight -dx PlgPts(1).y=TempRect.nTop + dy PlgPts(2).x=TempRect.nLeft + dx PlgPts(2).y=TempRect.nBottom -dy ELSE ' Project parallelogram points for rotated area for the bitmap PlgPts(0).X = XD + HalfWidth - sCos1 - sCos2 PlgPts(0).Y = YD + HalfHeight - sSin1 - sSin2 PlgPts(1).X = XD + HalfWidth - sCos2 + sCos1 PlgPts(1).Y = YD + HalfHeight - sSin2 + sSin1 PlgPts(2).X = XD + HalfWidth - sCos1 + sCos2 PlgPts(2).Y = YD + HalfHeight - sSin1 + sSin2 END IF XD=dx YD=dy ' Project parallelogram points for rotated area for the bitmap at 0,0 PlgPts(3).X = XD + HalfWidth - sCos1 - sCos2 PlgPts(3).Y = YD + HalfHeight - sSin1 - sSin2 PlgPts(4).X = XD + HalfWidth - sCos2 + sCos1 PlgPts(4).Y = YD + HalfHeight - sSin2 + sSin1 PlgPts(5).X = XD + HalfWidth - sCos1 + sCos2 PlgPts(5).Y = YD + HalfHeight - sSin1 + sSin2 IF Alpha <> 0 THEN 'TempBmp will hold the Destinatin Bitmap for alphablending GRAPHIC BITMAP NEW nWidth, nHeight TO hTempBmp GRAPHIC ATTACH hTempBmp, 0 GRAPHIC GET DC TO hTempDC GRAPHIC COPY MyTargetDest, 0,(xDest,yDest)-(xDest + nWidth,yDest + nHeight) TO (0,0) IF Alpha <> 0 AND (MyAngle <> 0 OR MyScale <>0)THEN GRAPHIC BITMAP NEW nWidth, nHeight TO hTempBmpPlgBlt GRAPHIC ATTACH hTempBmpPlgBlt, 0 GRAPHIC GET DC TO hTempPlgBltDC GRAPHIC CLEAR %RED END IF GRAPHIC ATTACH MyTargetDest,0, REDRAW GRAPHIC GET DC TO hDestDC 'Fill in the Alphablend structure BF.BlendOp = %AC_SRC_OVER BF.BlendFlags = 0 BF.SourceConstantAlpha = Alpha BF.AlphaFormat = 0 IF MyScale = 0 AND MyAngle = 0 THEN 'Alphablending but NO scaling or rotation AlphaBlend(hTempDC,0, 0&, nWidth, nHeight, hSrcDC, x, y, nWidth, nHeight, BYVAL CVDWD(bf)) PlgBlt(hDestDC, PlgPts(0), hTempDC, x, y, nWidth, nHeight, BitMapMask, 0, 0) ELSE 'we have an alphablend with scaling or rotation IF MyScale <>0 THEN 'Need to alter the mask DestBitMapDC=CreateCompatibleDC(hTempDC) OldObject1=SelectObject(DestBitMapDC,MyScaleBitMapMask) MaskRect.nTop=0 MaskRect.nLeft=0 MaskRect.nRight=nWidth MaskRect.nTop=nHeight FillRect DestBitMapDC,MaskRect,GetStockObject(%BLACK_BRUSH) SrcBitMapDC=CreateCompatibleDC(hTempDC) OldObject2=SelectObject(SrcBitMapDC,BitMapMask) PlgBlt(DestBitMapDC, PlgPts(3), SrcBitMapDC, 0, 0, nWidth, nHeight,0, 0, 0) 'Put at 0,0 of the temp bitmap DeleteDC SrcBitMapDC DeleteDC DestBitMapDC END IF PlgBlt(hTempPlgBltDC, PlgPts(3), hSrcDC, x, y, nWidth, nHeight, BitMapMask, 0, 0) 'Put at 0,0 of the temp bitmap AlphaBlend(hTempDC,0, 0, nWidth, nHeight, hTempPlgBltDC, 0, 0, nWidth, nHeight, BYVAL CVDWD(bf)) PlgBlt(hDestDC, PlgPts(6), hTempDC, 0, 0, nWidth, nHeight,MyScaleBitMapMask, 0, 0) ' The BitBlt at the destination END IF 'IF MyScale = 0 AND MyAngle = 0 GRAPHIC ATTACH hTempBmp, 0 GRAPHIC BITMAP END GRAPHIC ATTACH hTempBmpPlgBlt, 0 GRAPHIC BITMAP END GRAPHIC ATTACH MyTargetDest,0, REDRAW ELSE 'No Alpha GRAPHIC ATTACH MyTargetDest,0, REDRAW GRAPHIC GET DC TO hDestDC PlgBlt(hDestDC, PlgPts(0), hSrcDC, x, y, nWidth, nHeight, BitMapMask, 0, 0) END IF 'If Alpha END SUB FUNCTION MakeBitmapMask(hSrcDC AS LONG,lWidth AS LONG, lHeight AS LONG,TransColor AS LONG) AS LONG LOCAL MonoDC,MonoBitmap AS LONG LOCAL x,y AS LONG 'This is a 1 bit mask used by PlgBlt IF TransColor < 0 THEN TransColor = GetPixel(hSrcDC, 0, 0) MonoDC = CreateCompatibleDC(hSrcDC) MonoBitmap = CreateBitmap(lWidth, lHeight, 1, 1, BYVAL 0&) IF SelectObject(MonoDC, MonoBitmap) = 0 THEN EXIT FUNCTION FOR x = 0 TO lWidth -1 FOR y = 0 TO lHeight -1 IF GetPixel(hSrcDC, x, y) = TransColor THEN SetPixel(MonoDC, x, y,%BLACK) ELSE SetPixel(MonoDC, x, y,%WHITE) END IF NEXT y NEXT x DeleteDC MonoDC FUNCTION = MonoBitmap END FUNCTION SUB PrintText(MyText AS STRING,x AS LONG,y AS LONG,FontHandle AS LONG,MyTargetDest AS LONG) LOCAL nWidth,nHeight AS SINGLE LOCAL hMyTextBmp AS LONG LOCAL hMyTextBmpMask AS LONG GRAPHIC SET FONT FontHandle GRAPHIC TEXT SIZE MyText TO nWidth, nHeight GRAPHIC BITMAP NEW nWidth, nHeight TO hMyTextBmpMask GRAPHIC BITMAP NEW nWidth, nHeight TO hMyTextBmp GRAPHIC ATTACH hMyTextBmp, 0 GRAPHIC SET FONT FontHandle GRAPHIC COLOR %BLUE,%WHITE GRAPHIC PRINT MyText GRAPHIC ATTACH hMyTextBmpMask, 0 GRAPHIC SET FONT FontHandle GRAPHIC COLOR %WHITE,%BLACK GRAPHIC PRINT MyText GRAPHIC ATTACH MyTargetDest,0, REDRAW 'Write the Text to the screen; mask then image GRAPHIC COPY hMyTextBmpMask, 0 TO (x, y), %MIX_MERGESRC GRAPHIC COPY hMyTextBmp, 0 TO (x, y), %MIX_MASKSRC 'Delete the Bitmaps GRAPHIC ATTACH hMyTextBmp, 0 GRAPHIC BITMAP END GRAPHIC ATTACH hMyTextBmpMask, 0 GRAPHIC BITMAP END ' GRAPHIC ATTACH MyTargetDest,0, REDRAW END SUB SUB InitBalls LOCAL temp AS LONG FOR temp = 1 TO %NUMBALLS RedBalls(temp).x=RND(1,500) RedBalls(temp).y=RND(1,350) RedBalls(temp).v=RND(1,20) RedBalls(temp).a=RND(100,250) RedBalls(temp).s=RND(10,100) RedBalls(temp).r=RND(1,360) RedBalls(temp).dx=1 RedBalls(temp).dy=1 NEXT temp AlphaToggle=-1 TextToggle= 1 ScaleToggle=-1 RotateToggle=-1 FONT NEW "Times Roman",24,3,0,0,0 TO MyFont END SUB SUB MakeBitMaps LOCAL hBitmapDC AS LONG GRAPHIC BITMAP NEW 640, 480 TO bkgnd GRAPHIC ATTACH bkgnd, 0 GRAPHIC BOX (0, 0) - (640, 480),0,%BLACK ,%GREEN , 5 GRAPHIC BITMAP NEW 140, 140 TO ball GRAPHIC ATTACH ball, 0 GRAPHIC CLEAR %BLACK GRAPHIC ELLIPSE (0, 0) - (140, 140),%BLACK ,%RED , 0 GRAPHIC PIE (0, 0) - (140, 140),0,.3,%BLUE ,%BLUE , 0 GRAPHIC GET DC TO hBitMapDC hBallBitMapMask = MakeBitmapMask(hBitMapDC,140,140,0) hTempBallBitMapMask = MakeBitmapMask(hBitMapDC,140,140,0) END SUB CALLBACK FUNCTION ShowBmpWindowProc() LOCAL Result AS LONG LOCAL rc AS RECT LOCAL hThread AS DWORD LOCAL lResult AS LONG SELECT CASE AS LONG CBMSG CASE %WM_INITDIALOG CALL SetTimer(CBHNDL, 1, 1, %NULL) CASE %WM_TIMER SceneRedraw(hDlg) CASE %WM_NCACTIVATE STATIC hWndSaveFocus AS DWORD IF ISFALSE CBWPARAM THEN hWndSaveFocus = GetFocus() ELSEIF hWndSaveFocus THEN SetFocus(hWndSaveFocus) hWndSaveFocus = 0 END IF CASE %WM_CLOSE CALL DeleteObject(hBmp) CALL KillTimer(CBHNDL, 1) CASE %WM_PAINT SceneRedraw(hDlg) FUNCTION = 0: EXIT FUNCTION CASE %WM_COMMAND SELECT CASE AS LONG CBCTL CASE %IDC_TRANS CASE %IDM_FILE_EXIT DIALOG END CBHNDL , 0 CASE %IDM_TOGGLEALPHA AlphaToggle=-AlphaToggle IF AlphaToggle = 1 THEN MENU SET STATE hMenu, BYCMD %IDM_TOGGLEALPHA, %MF_CHECKED ELSE MENU SET STATE hMenu, BYCMD %IDM_TOGGLEALPHA, %MF_UNCHECKED END IF CASE %IDM_TOGGLETEXT TextToggle=-TextToggle IF TextToggle = 1 THEN MENU SET STATE hMenu, BYCMD %IDM_TOGGLETEXT, %MF_CHECKED ELSE MENU SET STATE hMenu, BYCMD %IDM_TOGGLETEXT, %MF_UNCHECKED END IF CASE %IDM_TOGGLESCALE ScaleToggle=-ScaleToggle IF ScaleToggle = 1 THEN MENU SET STATE hMenu, BYCMD %IDM_TOGGLESCALE, %MF_CHECKED ELSE MENU SET STATE hMenu, BYCMD %IDM_TOGGLESCALE, %MF_UNCHECKED END IF CASE %IDM_TOGGLEROTATE RotateToggle=-RotateToggle IF RotateToggle = 1 THEN MENU SET STATE hMenu, BYCMD %IDM_TOGGLEROTATE, %MF_CHECKED ELSE MENU SET STATE hMenu, BYCMD %IDM_TOGGLEROTATE, %MF_UNCHECKED END IF END SELECT END SELECT END FUNCTION FUNCTION SceneRedraw(hDlg AS LONG) AS LONG STATIC FPScounter AS LONG STATIC TextPos AS LONG STATIC BaseTime,ThisTime AS DOUBLE LOCAL temp,lResult AS LONG LOCAL a,s,r AS LONG INCR TextPos INCR FPScounter IF BaseTime=0 THEN BaseTime=TIMER GRAPHIC ATTACH hDlg, %IDC_TRANS, REDRAW GRAPHIC COPY bkgnd, 0 FOR temp = 1 TO %NUMBALLS RedBalls(temp).x=RedBalls(temp).x + RedBalls(temp).v * RedBalls(temp).dx RedBalls(temp).y=RedBalls(temp).y + RedBalls(temp).v * RedBalls(temp).dy IF RedBalls(temp).x + 140 > 640 THEN RedBalls(temp).dx=-1 IF RedBalls(temp).x < 0 THEN RedBalls(temp).dx=1 IF RedBalls(temp).y + 140 > 480 THEN RedBalls(temp).dy=-1 IF RedBalls(temp).y < 0 THEN RedBalls(temp).dy=1 IF AlphaToggle = 1 THEN a=RedBalls(temp).a ELSE a=0 IF RotateToggle = 1 THEN r=RedBalls(temp).r ELSE r=0 IF ScaleToggle = 1 THEN s=RedBalls(temp).s ELSE s=0 'This is the main function CopyBitmapEx(hBoard, RedBalls(temp).x, RedBalls(temp).y,ball, 0, 0, 140, 140,a,hBallBitMapMask,r,s,hTempBallBitMapMask) IF RedBalls(temp).r <> 0 THEN RedBalls(temp).r= RedBalls(temp).r + 5 IF RedBalls(temp).r > 360 THEN RedBalls(temp).r = 1 ' do not let equal to zero END IF NEXT temp IF FPScounter > 40 THEN ThisTime=TIMER DIALOG SET TEXT hDlg, "CopyBitMapEx (PlgBlt Version) - FPS=" & FORMAT$(FPSCounter/(ThisTime-BaseTime),"0") FPScounter = 0 BaseTime=ThisTime END IF IF TextToggle=1 THEN PrintText("PowerBasic",TextPos,440,MyFont,hBoard) IF TextPos > 640 THEN TextPos = -100 END IF GRAPHIC REDRAW END FUNCTION FUNCTION AttachMenu1(BYVAL hDlg AS DWORD) AS DWORD LOCAL hPopUp1 AS DWORD MENU NEW BAR TO hMenu MENU NEW POPUP TO hPopUp1 MENU ADD POPUP, hMenu, "File", hPopUp1, %MF_ENABLED MENU ADD STRING, hPopUp1, "Toggle Alpha", %IDM_TOGGLEALPHA, %MF_ENABLED MENU ADD STRING, hPopUp1, "Toggle Text", %IDM_TOGGLETEXT, %MF_ENABLED MENU ADD STRING, hPopUp1, "Toggle Scale", %IDM_TOGGLESCALE, %MF_ENABLED MENU ADD STRING, hPopUp1, "Toggle Rotate", %IDM_TOGGLEROTATE, %MF_ENABLED MENU ADD STRING, hPopUp1, "Exit", %IDM_FILE_EXIT, %MF_ENABLED MENU ATTACH hMenu, hDlg FUNCTION = hMenu END FUNCTION FUNCTION ShowBmpWindow(BYVAL hParent AS DWORD) AS LONG LOCAL lRslt AS LONG DIALOG NEW PIXELS, hParent, "CopyBitMapEx (PlgBlt Version)" , 70, 70, 650, 500, TO hDlg CONTROL ADD GRAPHIC, hDlg, %IDC_TRANS, "", 5, 0, 640, 480, %SS_NOTIFY CONTROL HANDLE hDlg,%IDC_TRANS TO hBoard REDIM RedBalls(%NUMBALLS) AS BallType InitBalls MakeBitmaps GRAPHIC ATTACH bkgnd, 0 GRAPHIC GET DC TO bkgndDC GRAPHIC ATTACH ball, 0 GRAPHIC GET DC TO ballDC GRAPHIC ATTACH hDlg, %IDC_TRANS, REDRAW GRAPHIC GET DC TO hBoardDC AttachMenu1 hDlg SceneRedraw(hDlg) MENU SET STATE hMenu, BYCMD %IDM_TOGGLETEXT, %MF_CHECKED DIALOG SHOW MODAL hDlg, CALL ShowBmpWindowProc TO lRslt FUNCTION = lRslt 'Delete the bitmaps GRAPHIC ATTACH bkgnd, 0 GRAPHIC BITMAP END GRAPHIC ATTACH ball, 0 GRAPHIC BITMAP END CALL DeleteObject(hBallBitMapMask) CALL DeleteObject(hTempBallBitMapMask) END FUNCTION FUNCTION PBMAIN() ShowBmpWindow %HWND_DESKTOP END FUNCTIONLeave a comment:
-
Updated CopyBitmapEx
I added a few more red balls to stress the CopyBitmapEx function. The alphablending really slows down the program. This is where Patrice and Chris efforts pay off (and in countless other ways). Try running this sample and toggle on the alphablending under the file menu. On my computer the frames per second cut in half from 64 FPS to 32 FPS and CPU usage went from 15% to 100% when alphablending was turned on. Have fun.
Jim
Code:'CopyBitmapEx by Jim Klutho Nov 10,2009 'Attempt to use Powerbasic's built in graphic commands to combine TransparentBlt and Alphablending 'This version has multiple red ball to show the burden of alphablending with the technique used 'PBWin 9.02 #COMPILE EXE #DIM ALL #INCLUDE "WIN32API.INC" '--------Constants----------------------- %IDC_TRANS = 1000 %IDM_FILE_EXIT = 1001 %IDM_TOGGLEALPHA = 1002 %IDM_TOGGLETEXT = 1003 '----------Types------------------------ TYPE BallType x AS LONG y AS LONG v AS LONG 'velocity a AS LONG 'alpha dx AS LONG dy AS LONG END TYPE '--------Globals------------------------ GLOBAL lpPoint AS POINTAPI GLOBAL hMenu AS DWORD GLOBAL hDlg AS LONG GLOBAL hBoard AS DWORD GLOBAL hBmp AS DWORD GLOBAL Bkgnd AS DWORD GLOBAL Ball AS DWORD GLOBAL dx,dy AS LONG GLOBAL BkgndDC AS DWORD GLOBAL BallDC AS DWORD GLOBAL hBoardDC AS DWORD GLOBAL RedBalls() AS BallType GLOBAL AlphaToggle AS LONG GLOBAL TextToggle AS LONG GLOBAL MyFont AS LONG SUB CopyBitMapEx(BYVAL MyTargetDest AS LONG,BYVAL xDest AS LONG, BYVAL yDest AS LONG, _ BYVAL hSrcBmp AS LONG, BYVAL x AS LONG,BYVAL y AS LONG,BYVAL nWidth AS LONG, BYVAL nHeight AS LONG, _ BYVAL TransColor AS LONG, BYVAL Alpha AS BYTE) 'Alphablend needs 32bpp bitmaps to work 'If Alpha is zero then Alphablending is ignored otherwise 'This routine will 1) copy the soon to be overlaid destination to a buffer ' 2) copy the portion of the source bitmap to be used to a buffer ' 3) alphablend the source bitmap buffer to the destination buffer ' 4) replace the colorkey location pix in the destination buffer with the Transcolor ' 5) tranparentblt the thing to the screen LOCAL BF AS BLENDFUNCTION LOCAL ScrBits AS STRING LOCAL TempBits AS STRING LOCAL hDestDC AS LONG LOCAL hSrcDC AS LONG LOCAL TransColorBGR AS LONG LOCAL hTempBmp AS LONG LOCAL hTempDC AS LONG LOCAL hMyScrBmp AS LONG GRAPHIC ATTACH hSrcBmp, 0 GRAPHIC GET DC TO hSrcDC IF Alpha <> 0 THEN 'Make a temp bitmap to alter and display and grab just enough source bitmap in case many frame are included GRAPHIC BITMAP NEW nWidth, nHeight& TO hMyScrBmp GRAPHIC ATTACH hMyScrBmp, 0 GRAPHIC COPY hSrcBmp, 0,(0,0)-(nWidth,nHeight) TO (0,0) GRAPHIC GET BITS TO ScrBits GRAPHIC BITMAP NEW nWidth, nHeight TO hTempBmp GRAPHIC ATTACH hTempBmp, 0 GRAPHIC GET DC TO hTempDC GRAPHIC COPY MyTargetDest, 0,(xDest,yDest)-(xDest + nWidth,yDest + nHeight) TO (0,0) END IF 'need to put back the proper drawing surface GRAPHIC ATTACH MyTargetDest,0, REDRAW GRAPHIC GET DC TO hDestDC IF TransColor < 0 THEN TransColor = GetPixel(hSrcDC, 0, 0) IF Alpha <> 0 THEN 'Fill in the Alphablend structure BF.BlendOp = %AC_SRC_OVER BF.BlendFlags = 0 BF.SourceConstantAlpha = Alpha BF.AlphaFormat = 0 AlphaBlend(hTempDC,0, 0&, nWidth, nHeight, hSrcDC, x, y, nWidth, nHeight, BYVAL CVDWD(bf)) 'Now need to GetBits and swap out the TransColor GRAPHIC ATTACH hTempBmp, 0 GRAPHIC GET BITS TO TempBits LOCAL ScrPixelPtr AS LONG PTR LOCAL TempPixelPtr AS LONG PTR LOCAL xsize,ysize,i AS LONG xsize = CVL(TempBits,1) ysize = CVL(TempBits,5) ScrPixelPtr = STRPTR(ScrBits) + 8 TempPixelPtr = STRPTR(TempBits) + 8 TransColorBGR = BGR(TransColor&) FOR i = 1 TO xsize * ysize IF @ScrPixelPtr = TransColorBGR THEN @TempPixelPtr = TransColorBGR END IF INCR ScrPixelPtr INCR TempPixelPtr NEXT GRAPHIC SET BITS TempBits GRAPHIC ATTACH MyTargetDest,0, REDRAW CALL TransparentBlt(hDestDC, xDest, yDest, nWidth, nHeight, htempDC, x, y, nWidth, nHeight, TransColor) ELSE CALL TransparentBlt(hDestDC, xDest, yDest, nWidth, nHeight, hSrcDC, x, y, nWidth, nHeight, TransColor) END IF IF Alpha <> 0 THEN 'Destroy the temp bitmaps and return focus to the target GRAPHIC ATTACH hMyScrBmp, 0 GRAPHIC BITMAP END GRAPHIC ATTACH hTempBmp, 0 GRAPHIC BITMAP END GRAPHIC ATTACH MyTargetDest,0, REDRAW END IF END SUB SUB PrintText(MyText AS STRING,x AS LONG,y AS LONG,FontHandle AS LONG,MyTargetDest AS LONG) LOCAL nWidth,nHeight AS SINGLE LOCAL hMyTextBmp AS LONG GRAPHIC SET FONT FontHandle GRAPHIC TEXT SIZE MyText TO nWidth, nHeight GRAPHIC BITMAP NEW nWidth, nHeight TO hMyTextBmp GRAPHIC ATTACH hMyTextBmp, 0 GRAPHIC SET FONT FontHandle GRAPHIC COLOR %BLUE,%CYAN GRAPHIC PRINT MyText GRAPHIC ATTACH MyTargetDest,0, REDRAW CopyBitMapEx MyTargetDest, x, y, hMyTextBmp, 0, 0, nWidth,nHeight, -1,0 GRAPHIC ATTACH hMyTextBmp, 0 GRAPHIC BITMAP END GRAPHIC ATTACH MyTargetDest,0, REDRAW END SUB SUB InitBalls LOCAL temp AS LONG FOR temp = 1 TO 20 RedBalls(temp).x=RND(1,500) RedBalls(temp).y=RND(1,350) RedBalls(temp).v=RND(1,20) RedBalls(temp).a=RND(1,250) RedBalls(temp).dx=1 RedBalls(temp).dy=1 NEXT temp AlphaToggle=1 TextToggle=1 FONT NEW "Times Roman",24,3,0,0,0 TO MyFont END SUB SUB MakeBitMaps GRAPHIC BITMAP NEW 640, 480 TO bkgnd GRAPHIC ATTACH bkgnd, 0 'GRAPHIC CLEAR %GREEn,5 GRAPHIC BOX (0, 0) - (640, 480),0,%BLACK ,%GREEN , 5 GRAPHIC BITMAP NEW 140, 140 TO ball GRAPHIC ATTACH ball, 0 GRAPHIC CLEAR %CYAN GRAPHIC ELLIPSE (0, 0) - (140, 140),%BLACK ,%RED , 0 END SUB CALLBACK FUNCTION ShowBmpWindowProc() LOCAL Result AS LONG LOCAL rc AS RECT SELECT CASE AS LONG CBMSG CASE %WM_INITDIALOG CALL SetTimer(CBHNDL, 1, 1, %NULL) CASE %WM_TIMER SceneRedraw CASE %WM_NCACTIVATE STATIC hWndSaveFocus AS DWORD IF ISFALSE CBWPARAM THEN hWndSaveFocus = GetFocus() ELSEIF hWndSaveFocus THEN SetFocus(hWndSaveFocus) hWndSaveFocus = 0 END IF CASE %WM_CLOSE CALL DeleteObject(hBmp) CALL KillTimer(CBHNDL, 1) CASE %WM_PAINT SceneRedraw FUNCTION = 0: EXIT FUNCTION CASE %WM_COMMAND SELECT CASE AS LONG CBCTL CASE %IDC_TRANS '%STN_CLICKED or %STN_DBLCLK assumed Result=GetCursorPos (lpPoint) Result=ScreenToClient (CBHNDL,lpPoint) CASE %IDM_FILE_EXIT DIALOG END CBHNDL , 0 CASE %IDM_TOGGLEALPHA AlphaToggle=-AlphaToggle CASE %IDM_TOGGLETEXT TextToggle=-TextToggle END SELECT END SELECT END FUNCTION SUB SceneRedraw STATIC FPScounter AS LONG STATIC TextPos AS LONG STATIC BaseTime,ThisTime AS DOUBLE LOCAL temp AS LONG INCR TextPos INCR FPScounter IF BaseTime=0 THEN BaseTime=TIMER GRAPHIC ATTACH hDlg, %IDC_TRANS, REDRAW GRAPHIC COPY bkgnd, 0 FOR temp = 1 TO 20 RedBalls(temp).x=RedBalls(temp).x + RedBalls(temp).v * RedBalls(temp).dx RedBalls(temp).y=RedBalls(temp).y + RedBalls(temp).v * RedBalls(temp).dy IF RedBalls(temp).x + 140 > 640 THEN RedBalls(temp).dx=-1 IF RedBalls(temp).x < 0 THEN RedBalls(temp).dx=1 IF RedBalls(temp).y + 140 > 480 THEN RedBalls(temp).dy=-1 IF RedBalls(temp).y < 0 THEN RedBalls(temp).dy=1 IF AlphaToggle = 1 THEN CopyBitmapEx(hBoard, RedBalls(temp).x, RedBalls(temp).y,ball, 0, 0, 140, 140, -1,0) ELSE CopyBitmapEx(hBoard, RedBalls(temp).x, RedBalls(temp).y,ball, 0, 0, 140, 140, -1,RedBalls(temp).a) END IF NEXT temp IF FPScounter > 40 THEN ThisTime=TIMER DIALOG SET TEXT hDlg, "CopyBitMapEx - FPS=" & FORMAT$(FPSCounter/(ThisTime-BaseTime),"0") FPScounter = 0 BaseTime=ThisTime END IF IF TextToggle=1 THEN PrintText("PowerBasic",TextPos,440,MyFont,hBoard) IF TextPos > 640 THEN TextPos = -100 END IF GRAPHIC REDRAW END SUB FUNCTION AttachMenu1(BYVAL hDlg AS DWORD) AS DWORD LOCAL hPopUp1 AS DWORD MENU NEW BAR TO hMenu MENU NEW POPUP TO hPopUp1 MENU ADD POPUP, hMenu, "File", hPopUp1, %MF_ENABLED MENU ADD STRING, hPopUp1, "Toggle Alpha", %IDM_TOGGLEALPHA, %MF_ENABLED MENU ADD STRING, hPopUp1, "Toggle Text", %IDM_TOGGLETEXT, %MF_ENABLED MENU ADD STRING, hPopUp1, "Exit", %IDM_FILE_EXIT, %MF_ENABLED MENU ATTACH hMenu, hDlg FUNCTION = hMenu END FUNCTION FUNCTION ShowBmpWindow(BYVAL hParent AS DWORD) AS LONG LOCAL lRslt AS LONG DIALOG NEW PIXELS, hParent, "CopyBitMapEx", 70, 70, 650, 500, TO hDlg CONTROL ADD GRAPHIC, hDlg, %IDC_TRANS, "", 5, 0, 640, 480, %SS_NOTIFY CONTROL HANDLE hDlg,%IDC_TRANS TO hBoard REDIM RedBalls(20) AS BallType InitBalls MakeBitmaps GRAPHIC ATTACH bkgnd, 0 GRAPHIC GET DC TO bkgndDC GRAPHIC ATTACH ball, 0 GRAPHIC GET DC TO ballDC GRAPHIC ATTACH hDlg, %IDC_TRANS, REDRAW GRAPHIC GET DC TO hBoardDC AttachMenu1 hDlg SceneRedraw DIALOG SHOW MODAL hDlg, CALL ShowBmpWindowProc TO lRslt FUNCTION = lRslt GRAPHIC ATTACH bkgnd, 0 GRAPHIC BITMAP END GRAPHIC ATTACH ball, 0 GRAPHIC BITMAP END END FUNCTION FUNCTION PBMAIN() ShowBmpWindow %HWND_DESKTOP END FUNCTIONLast edited by james klutho; 11 Nov 2009, 08:54 PM.Leave a comment:
-
CopyBitMapEx
Powerbasic's Graphic commands are simple and easy to use but glaring omissions in my opinion were colorkeying and alphablending in the GRAPHIC COPY statement. Here is how I implemented them using the Windows API calls TransparentBlt and AlphaBend.
Code:'CopyBitmapEx by Jim Klutho Nov 7,2009 'Attempt to use Powerbasic's built in graphic commands to combine TransparentBlt and Alphablending 'PBWin 9.02 #COMPILE EXE #DIM ALL #INCLUDE "WIN32API.INC" '--------Constants----------------------- %IDM_FILE_EXIT = 1001 %IDC_TRANS = 1000 '--------Globals------------------------ GLOBAL lpPoint AS POINTAPI GLOBAL hMenu AS DWORD GLOBAL hDlg AS LONG GLOBAL hBoard AS DWORD GLOBAL hBmp AS DWORD GLOBAL Bkgnd AS DWORD GLOBAL Ball AS DWORD GLOBAL dx,dy AS LONG GLOBAL BkgndDC AS DWORD GLOBAL BallDC AS DWORD GLOBAL hBoardDC AS DWORD SUB CopyBitMapEx(BYVAL MyTargetDest AS LONG,BYVAL xDest AS LONG, BYVAL yDest AS LONG, _ BYVAL hSrcBmp AS LONG, BYVAL x AS LONG,BYVAL y AS LONG,BYVAL nWidth AS LONG, BYVAL nHeight AS LONG, _ BYVAL TransColor AS LONG, BYVAL Alpha AS BYTE) 'Alphablend needs 32bpp bitmaps to work 'If Alpha is zero then Alphablending is ignored otherwise 'This routine will 1) copy the soon to be overlaid destination to a buffer ' 2) copy the portion of the source bitmap to be used to a buffer ' 3) alphablend the source bitmap buffer to the destination buffer ' 4) replace the colorkey location pix in the destination buffer with the Transcolor ' 5) tranparentblt the thing to the screen LOCAL BF AS BLENDFUNCTION LOCAL ScrBits AS STRING LOCAL TempBits AS STRING LOCAL hDestDC AS LONG LOCAL hSrcDC AS LONG LOCAL TransColorBGR AS LONG LOCAL hTempBmp AS LONG LOCAL hTempDC AS LONG LOCAL hMyScrBmp AS LONG GRAPHIC ATTACH hSrcBmp, 0 GRAPHIC GET DC TO hSrcDC IF Alpha <> 0 THEN 'Make a temp bitmap to alter and display and grab just enough source bitmap in case many frame are included GRAPHIC BITMAP NEW nWidth, nHeight& TO hMyScrBmp GRAPHIC ATTACH hMyScrBmp, 0 GRAPHIC COPY hSrcBmp, 0,(0,0)-(nWidth,nHeight) TO (0,0) GRAPHIC GET BITS TO ScrBits GRAPHIC BITMAP NEW nWidth, nHeight TO hTempBmp GRAPHIC ATTACH hTempBmp, 0 GRAPHIC GET DC TO hTempDC GRAPHIC COPY MyTargetDest, 0,(xDest,yDest)-(xDest + nWidth,yDest + nHeight) TO (0,0) END IF 'need to put back the proper drawing surface GRAPHIC ATTACH MyTargetDest,0, REDRAW GRAPHIC GET DC TO hDestDC IF TransColor < 0 THEN TransColor = GetPixel(hSrcDC, 0, 0) IF Alpha <> 0 THEN 'Fill in the Alphablend structure BF.BlendOp = %AC_SRC_OVER BF.BlendFlags = 0 BF.SourceConstantAlpha = Alpha BF.AlphaFormat = 0 AlphaBlend(hTempDC,0, 0&, nWidth, nHeight, hSrcDC, x, y, nWidth, nHeight, BYVAL CVDWD(bf)) 'Now need to GetBits and swap out the TransColor GRAPHIC ATTACH hTempBmp, 0 GRAPHIC GET BITS TO TempBits LOCAL ScrPixelPtr AS LONG PTR LOCAL TempPixelPtr AS LONG PTR LOCAL xsize,ysize,i AS LONG xsize = CVL(TempBits,1) ysize = CVL(TempBits,5) ScrPixelPtr = STRPTR(ScrBits) + 8 TempPixelPtr = STRPTR(TempBits) + 8 TransColorBGR = BGR(TransColor&) FOR i = 1 TO xsize * ysize IF @ScrPixelPtr = TransColorBGR THEN @TempPixelPtr = TransColorBGR END IF INCR ScrPixelPtr INCR TempPixelPtr NEXT GRAPHIC SET BITS TempBits GRAPHIC ATTACH MyTargetDest,0, REDRAW CALL TransparentBlt(hDestDC, xDest, yDest, nWidth, nHeight, htempDC, x, y, nWidth, nHeight, TransColor) ELSE CALL TransparentBlt(hDestDC, xDest, yDest, nWidth, nHeight, hSrcDC, x, y, nWidth, nHeight, TransColor) END IF IF Alpha <> 0 THEN 'Destroy the temp bitmaps and return focus to the target GRAPHIC ATTACH hMyScrBmp, 0 GRAPHIC BITMAP END GRAPHIC ATTACH hTempBmp, 0 GRAPHIC BITMAP END GRAPHIC ATTACH MyTargetDest,0, REDRAW END IF END SUB SUB PrintText(MyText AS STRING) END SUB SUB MakeBitMaps GRAPHIC BITMAP NEW 640, 480 TO bkgnd GRAPHIC ATTACH bkgnd, 0 'GRAPHIC CLEAR %GREEn,5 GRAPHIC BOX (0, 0) - (640, 480),0,%BLACK ,%GREEN , 5 GRAPHIC BITMAP NEW 140, 140 TO ball GRAPHIC ATTACH ball, 0 GRAPHIC CLEAR %CYAN GRAPHIC ELLIPSE (0, 0) - (140, 140),%BLACK ,%RED , 0 END SUB CALLBACK FUNCTION ShowBmpWindowProc() LOCAL Result AS LONG LOCAL rc AS RECT SELECT CASE AS LONG CBMSG CASE %WM_INITDIALOG CALL SetTimer(CBHNDL, 1, 15, %NULL) CASE %WM_TIMER SceneRedraw CASE %WM_NCACTIVATE STATIC hWndSaveFocus AS DWORD IF ISFALSE CBWPARAM THEN hWndSaveFocus = GetFocus() ELSEIF hWndSaveFocus THEN SetFocus(hWndSaveFocus) hWndSaveFocus = 0 END IF CASE %WM_CLOSE CALL DeleteObject(hBmp) CALL KillTimer(CBHNDL, 1) CASE %WM_PAINT SceneRedraw FUNCTION = 0: EXIT FUNCTION CASE %WM_COMMAND SELECT CASE AS LONG CBCTL CASE %IDC_TRANS '%STN_CLICKED or %STN_DBLCLK assumed Result=GetCursorPos (lpPoint) Result=ScreenToClient (CBHNDL,lpPoint) CASE %IDM_FILE_EXIT DIALOG END CBHNDL , 0 END SELECT END SELECT END FUNCTION SUB SceneRedraw GRAPHIC ATTACH hDlg, %IDC_TRANS, REDRAW GRAPHIC COPY bkgnd, 0 dx=dx+2 IF dx> 550 THEN dx = 1 CopyBitmapEx(hBoard, dx, 250,ball, 0, 0, 140, 140, -1,dx) CopyBitmapEx(hBoard, dx, 100,ball, 0, 0, 140, 140, -1,0) GRAPHIC REDRAW END SUB FUNCTION AttachMenu1(BYVAL hDlg AS DWORD) AS DWORD LOCAL hPopUp1 AS DWORD MENU NEW BAR TO hMenu MENU NEW POPUP TO hPopUp1 MENU ADD POPUP, hMenu, "File", hPopUp1, %MF_ENABLED MENU ADD STRING, hPopUp1, "Exit", %IDM_FILE_EXIT, %MF_ENABLED MENU ATTACH hMenu, hDlg FUNCTION = hMenu END FUNCTION FUNCTION ShowBmpWindow(BYVAL hParent AS DWORD) AS LONG LOCAL lRslt AS LONG DIALOG NEW PIXELS, hParent, "CopyBitMapEx", 70, 70, 650, 500, TO hDlg CONTROL ADD GRAPHIC, hDlg, %IDC_TRANS, "", 5, 0, 640, 480, %SS_NOTIFY CONTROL HANDLE hDlg,%IDC_TRANS TO hBoard MakeBitmaps GRAPHIC ATTACH bkgnd, 0 GRAPHIC GET DC TO bkgndDC GRAPHIC ATTACH ball, 0 GRAPHIC GET DC TO ballDC GRAPHIC ATTACH hDlg, %IDC_TRANS, REDRAW GRAPHIC GET DC TO hBoardDC AttachMenu1 hDlg SceneRedraw DIALOG SHOW MODAL hDlg, CALL ShowBmpWindowProc TO lRslt FUNCTION = lRslt GRAPHIC ATTACH bkgnd, 0 GRAPHIC BITMAP END GRAPHIC ATTACH ball, 0 GRAPHIC BITMAP END END FUNCTION FUNCTION PBMAIN() ShowBmpWindow %HWND_DESKTOP END FUNCTIONLast edited by james klutho; 9 Nov 2009, 08:13 AM.
Leave a comment: