Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

CopyBitMapEx

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Chris Boss
    replied
    I started a thread here:

    http://www.powerbasic.com/support/pb...ad.php?t=45420

    for discussing your code and the basic concept of sprites. I hope it offers some insights.

    Leave a comment:


  • james klutho
    replied
    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 FUNCTION

    Leave a comment:


  • james klutho
    replied
    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 FUNCTION
    Last edited by james klutho; 11 Nov 2009, 08:54 PM.

    Leave a comment:


  • james klutho
    started a topic PBWin CopyBitMapEx

    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 FUNCTION
    Last edited by james klutho; 9 Nov 2009, 08:13 AM.
Working...
X