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

  • PBWin 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.

  • #2
    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.

    Comment


    • #3
      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

      Comment


      • #4
        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.
        Chris Boss
        Computer Workshop
        Developer of "EZGUI"
        http://cwsof.com
        http://twitter.com/EZGUIProGuy

        Comment

        Working...
        X