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

Transparent bitmap updated

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

  • Transparent bitmap updated

    This is an old example from the archive that I posted in 1999 http://www.powerbasic.com/support/fo...-7-000171.html

    Here is and updated version to work with PB/WIN 8+

    Code:
    '***************************************************************************
    '
    '   PROGRAM: transblt.bas
    '   This piece of code is an adaptation of the MSN transblt.c example.
    '
    '   Tanslated to PowerBASIC on 02-14-1999 by:
    '   Patrice TERRIER
    '   [email protected]
    '   www.zapsolution.com 
    '
    '   PURPOSE: transblt template for Windows applications
    '
    '***************************************************************************
    
    #COMPILE EXE
    
    #INCLUDE "WIN32API.INC"
    
    %IDM_MASK1 = 100
    %IDM_MASK2 = 101
    %IDM_MASK3 = 102
    %IDM_BLACK = 200
    %IDM_RED   = 201
    %IDM_DRED  = 202
    %IDM_GREEN = 203
    %IDM_CYAN  = 204
    
    GLOBAL hInst&, bTransMaskBuilt%
    GLOBAL hbmHouse&, hbmFade&, hbmDefault&, hbmBinoculars&
    GLOBAL hbmTransMask&, hdcMem&, hdcMem2&
    GLOBAL wMaskType&, wTransColor&, rgbWhite&, rgbBlack&, rgbTransparent&
    GLOBAL HouseColor&()
    
    FUNCTION MyMenu& ()
    
        hMenu& = CreateMenu
    
            sMenu& = CreatePopUpMenu
            CALL AppendMenu(hMenu&, %MF_POPUP, sMenu&, "&Samples")
            CALL AppendMenu(sMenu&, %MF_STRING, %IDM_MASK1, "&True Mask")
            CALL AppendMenu(sMenu&, %MF_STRING, %IDM_MASK2, "&Color Trans/True")
            CALL AppendMenu(sMenu&, %MF_STRING, %IDM_MASK3, "&Color Trans/Black-Source")
    
            sMenu& = CreatePopUpMenu
            CALL AppendMenu(hMenu&, %MF_POPUP, sMenu&, "&Colors")
                CALL AppendMenu(sMenu&, %MF_STRING, %IDM_BLACK, "&Black")
                CALL AppendMenu(sMenu&, %MF_STRING, %IDM_RED, "&Red")
                CALL AppendMenu(sMenu&, %MF_STRING, %IDM_DRED, "&Dark Red")
                CALL AppendMenu(sMenu&, %MF_STRING, %IDM_GREEN, "&Green")
                CALL AppendMenu(sMenu&, %MF_STRING, %IDM_CYAN, "&Cyan")
        FUNCTION = hMenu&
    END FUNCTION
    
    FUNCTION WndProc&(BYVAL hWnd&, BYVAL Msg&, BYVAL wParam&, BYVAL lParam&)
    
        DIM poly(2) AS POINTAPI
    
        SELECT CASE Msg&
            case %WM_CREATE
    
                hdcScreen& = GetDC(%NULL)
    
                hbmHouse& = CreateCompatibleBitmap(hdcScreen&, 50, 50)
                hbmFade& = CreateCompatibleBitmap(hdcScreen&, 100, 100)
                hbmBinoculars& = CreateBitmap(50, 50, 1, 1, BYVAL %NULL)
                hbmTransMask& = CreateBitmap(50, 50, 1, 1, BYVAL %NULL)
                hdcMem& = CreateCompatibleDC(hdcScreen&)
                hdcMem2& = CreateCompatibleDC(hdcScreen&)
    
                CALL ReleaseDC(%NULL, hdcScreen&)
    
              ' Draw the house bitmap.  This will be the basic source bitmap.
    
                CALL SelectObject(hdcMem&, GetStockObject(%NULL_PEN))
                hbmDefault& = SelectObject(hdcMem&, hbmHouse&)
    
              ' sky.
                hbr& = CreateSolidBrush(RGB(0, 255, 255))
                hbr& = SelectObject(hdcMem&, hbr&)
                CALL PatBlt(hdcMem&, 0, 0, 50, 30, %PATCOPY)
                hbr& = SelectObject(hdcMem&, hbr&)
                CALL DeleteObject(hbr&)
    
              ' horizon.
                CALL PatBlt(hdcMem&, 0, 30, 50, 31, %BLACKNESS)
    
              ' lawn
                hbr& = CreateSolidBrush(RGB(0, 255, 0))
                hbr& = SelectObject(hdcMem, hbr&)
                CALL PatBlt(hdcMem, 0, 31, 50, 20, %PATCOPY)
                hbr& = SelectObject(hdcMem, hbr&)
                CALL DeleteObject(hbr&)
    
              ' house body
                hbr& = CreateSolidBrush(RGB(255, 0, 0))
                hbr& = SelectObject(hdcMem, hbr&)
                CALL PatBlt(hdcMem, 5, 20, 40, 20, %PATCOPY)
                hbr& = SelectObject(hdcMem&, hbr&)
                CALL DeleteObject(hbr&)
    
              ' house roof
                hbr& = CreateSolidBrush(RGB(128, 0, 0))
                hbr& = SelectObject(hdcMem&, hbr&)
                poly(0).x = 2
                poly(0).y = 20
                poly(1).x = 47
                poly(1).y = 20
                poly(2).x = 25
                poly(2).y = 5
                CALL Polygon(hdcMem&, poly(0), 3)
                hbr& = SelectObject(hdcMem&, hbr&)
                CALL DeleteObject(hbr&)
    
              ' windows
                hbr& = SelectObject(hdcMem&, GetStockObject(%BLACK_BRUSH))
                CALL PatBlt(hdcMem&, 10, 22, 12, 13, %BLACKNESS)
                CALL PatBlt(hdcMem&, 28, 22, 12, 13, %BLACKNESS)
    
    
              ' build the fade background bitmap.
                CALL SelectObject(hdcMem&, hbmFade&)
                FOR I% = 56 TO 256 STEP 2
                    IF I% > 255 THEN EXIT FOR
                    hbr& = CreateSolidBrush(RGB(I%, 0, I%))
                    hbr& = SelectObject(hdcMem&, hbr&)
                    CALL PatBlt(hdcMem&, 0, (I% - 56)/2, 100, 3, %PATCOPY)
                    hbr& = SelectObject(hdcMem&, hbr&)
                    CALL DeleteObject(hbr&)
                NEXT
    
              ' build the binoculars true mask.
                CALL SelectObject(hdcMem&, hbmBinoculars&)
                CALL PatBlt(hdcMem&, 0, 0, 50, 50, %WHITENESS)
                CALL SelectObject(hdcMem&, GetStockObject(%BLACK_BRUSH))
                CALL Ellipse(hdcMem&, 7, 7, 24, 43)
                CALL Ellipse(hdcMem&, 26, 7, 43, 43)
    
                CALL SelectObject(hdcMem&, hbmDefault&)
                FUNCTION = 0: EXIT FUNCTION
    
            case %WM_INITMENU
                CALL CheckMenuItem(wParam&, wMaskType&, %MF_CHECKED)
                CALL CheckMenuItem(wParam&, wTransColor&, %MF_CHECKED)
                FUNCTION = 0: EXIT FUNCTION
    
            case %WM_COMMAND ' message: command from application menu
                SELECT CASE wParam&
                case %IDM_MASK1, %IDM_MASK2, %IDM_MASK3
                     IF wParam& <> wMaskType& THEN
                        CALL CheckMenuItem(GetMenu(hWnd&), wMaskType&, %MF_UNCHECKED)
                        wMaskType& = wParam&
                        CALL CheckMenuItem(GetMenu(hWnd&), wMaskType&, %MF_CHECKED)
                        CALL InvalidateRect(hWnd&, BYVAL %NULL, %TRUE)
                     END IF
                     FUNCTION = 0: EXIT FUNCTION
                case %IDM_BLACK, %IDM_RED, %IDM_DRED, %IDM_GREEN, %IDM_CYAN
                     IF wParam& <> wTransColor& THEN
                        CALL CheckMenuItem(GetMenu(hWnd&), wTransColor&, %MF_UNCHECKED)
                        wTransColor& = wParam&
                        CALL CheckMenuItem(GetMenu(hWnd&), wTransColor&, %MF_UNCHECKED)
    
                        rgbTransparent& = HouseColor&(wTransColor& - %IDM_BLACK)
    
                        bTransMaskBuilt% = %FALSE
                        CALL InvalidateRect(hWnd&, BYVAL %NULL, %TRUE)
                     END IF
                     FUNCTION = 0: EXIT FUNCTION
                END SELECT
            case %WM_PAINT
                CALL PaintIt(hWnd&)
                FUNCTION = 0: EXIT FUNCTION
    
            case %WM_DESTROY
                CALL DeleteObject(hbmHouse&)
                CALL DeleteObject(hbmFade&)
                CALL DeleteObject(hbmBinoculars&)
                CALL DeleteObject(hbmTransMask&)
                CALL DeleteDC(hdcMem&)
                CALL DeleteDC(hdcMem2&)
    
                CALL PostQuitMessage(0)
                FUNCTION = 0: EXIT FUNCTION
            END SELECT
    
        FUNCTION = DefWindowProc(hWnd&, Msg&, wParam&, lParam&)
    END FUNCTION
    
    FUNCTION WinMain& (BYVAL hInstance&, BYVAL hPrevInstance&, BYVAL lpCmdLine AS ASCIIZ PTR, _
                       BYVAL nCmdShow&)
    
        LOCAL Msg AS tagMsg
        LOCAL wc AS WndClassEx
    
        LOCAL szClassName AS ASCIIZ * 80
        LOCAL szMenuName AS ASCIIZ * 80
    
        hInst& = hInstance&
        bTransMaskBuilt% = %FALSE
        wMaskType& = %IDM_MASK1                   ' mask being demoed.
        wTransColor& = %IDM_BLACK                 ' transparent color
        rgbWhite& = RGB(255,255,255)
        rgbBlack& = RGB(0,0,0)
    
        DIM HouseColor&(4)
        HouseColor&(0) = RGB(0,0,0)
        HouseColor&(1) = RGB(255,0,0)
        HouseColor&(2) = RGB(128,0,0)
        HouseColor&(3) = RGB(0,255,0)
        HouseColor&(4) = RGB(0,255,255)
        rgbTransparent& = HouseColor&(wTransColor& - %IDM_BLACK)
    
        szClassName = "transbltWClass"
    
        wc.cbSize        = SIZEOF(wc)
        wc.style         = %CS_HREDRAW OR %CS_VREDRAW ' %NULL                    ' Class style(s).
        wc.lpfnWndProc   = CODEPTR(WndProc)
        wc.cbClsExtra    = 0                    ' No per-class extra data.
        wc.cbWndExtra    = 0                    ' No per-window extra data.
        wc.hInstance     = hInst&               ' Application that owns the class.
        wc.hIcon         = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
        wc.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
        wc.hbrBackground = GetStockObject(%WHITE_BRUSH)
        wc.lpszMenuName  = %NULL
        wc.lpszClassName = VARPTR (szClassName) ' Name used in call to CreateWindow.
        wc.hIconSm       = LoadIcon(hInst&, BYVAL %IDI_APPLICATION)
        CALL RegisterClassEx(wc)
    
        hMenu& = MyMenu'LoadMenu(hInst&, "MAINMENU")
    
        hWnd& = CreateWindow(szClassName, _      ' See RegisterClass() call.
               "transblt Sample Application", _  ' Text for window title bar.
                %WS_OVERLAPPEDWINDOW, _          ' Window style.
                %CW_USEDEFAULT, _                ' Default horizontal position.
                %CW_USEDEFAULT, _                ' Default vertical position.
                410, _                ' Default width.
                320, _                ' Default height.
                %NULL, _                         ' Overlapped windows have no parent.
                hMenu&, _                        ' Use the window class menu.
                hInst&, _                        ' This instance owns this window.
                BYVAL %NULL)                     ' Pointer not needed.
    
        IF hWnd& THEN
           CALL ShowWindow(hWnd&, nCmdShow&)
           CALL UpdateWindow(hWnd&)
    
           WHILE GetMessage(Msg, %NULL, 0, 0)
               TranslateMessage Msg
               DispatchMessage Msg
           WEND
    
           FUNCTION = msg.wParam
        ELSE
           FUNCTION = %FALSE
        END IF
    END FUNCTION
    
    SUB PaintIt(hWnd&)
    
        LOCAl ps AS PAINTSTRUCT
    
        x% = 320: y% = 20
    
        hdcScreen& = BeginPaint(hWnd&, ps)
    
        CALL SelectObject(hdcMem&, hbmFade&)
        CALL BitBlt(hdcScreen&, 300, 0, 100, 100, hdcMem&, 0, 0, %SRCCOPY)
    
        CALL SetBkColor(hdcScreen&, rgbWhite&)
        CALL SetTextColor(hdcScreen&, rgbBlack&)
    
        SELECT CASE wMaskType&
        case %IDM_MASK1
             CALL SelectObject(hdcMem&, hbmHouse&)
             CALL SelectObject(hdcMem2&, hbmBinoculars&)
    
             CALL ShowStatus(hdcScreen&, hdcMem&, hdcMem2&)
    
             CALL BitBlt(hdcScreen&, x%, y%, 50, 50, hdcMem&, 0, 0, %SRCINVERT)
             CALL BitBlt(hdcScreen&, x%, y%, 50, 50, hdcMem2&, 0, 0, %SRCAND)
             CALL BitBlt(hdcScreen&, x%, y%, 50, 50, hdcMem&, 0, 0, %SRCINVERT)
    
        case %IDM_MASK2
        case %IDM_MASK3
             CALL SelectObject(hdcMem&, hbmHouse&)
             CALL SelectObject(hdcMem2&, hbmTransMask&)
    
           ' if the device supports transparency, let it do the work.
             IF (GetDeviceCaps(hdcScreen&, %CAPS1) AND %C1_TRANSPARENT) THEN
                oldMode& = SetBkMode(hdcScreen&, %NEWTRANSPARENT)
                rgbOld& = SetBkColor(hdcScreen&, rgbTransparent&)
                CALL BitBlt(hdcScreen&, x%, y%, 50, 50, hdcMem&, 0, 0, %SRCCOPY)
                CALL SetBkColor(hdcScreen&, rgbOld&)
                CALL SetBkMode(hdcScreen&, oldMode&)
             END IF
    
           ' build mask based on transparent color.
             IF NOT bTransMaskBuilt% THEN
                bTransMaskBuilt% = %TRUE
                CALL SetBkColor(hdcMem&, rgbTransparent&)
                CALL BitBlt(hdcMem2&, 0, 0, 50, 50, hdcMem&, 0, 0, %SRCCOPY)
             END IF
    
             CALL ShowStatus(hdcScreen&, hdcMem&, hdcMem2&)
    
           ' using a true mask.
             IF wMaskType& = %IDM_MASK2 THEN
                CALL BitBlt(hdcScreen&, x%, y%, 50, 50, hdcMem&, 0, 0, %SRCINVERT)
                CALL BitBlt(hdcScreen&, x%, y%, 50, 50, hdcMem2&, 0, 0, %SRCAND)
                CALL BitBlt(hdcScreen&, x%, y%, 50, 50, hdcMem&, 0, 0, %SRCINVERT)
    
             ELSE ' using the black-source method.
    
              ' if transparent color is black, the house bitmap is
              ' ready for use.  Otherwise, put black in the right
              ' place for masking.
                IF wTransColor& <> %IDM_BLACK THEN
                   CALL SetBkColor(hdcMem&, rgbBlack&)
                   CALL SetTextColor(hdcMem&, rgbWhite&)
                   CALL BitBlt(hdcMem&, 0, 0, 50, 50, hdcMem2&, 0, 0, %SRCAND)
    
                 ' show the modified bitmap
                   CALL BitBlt(hdcScreen&, 120, 150, 50, 50, hdcMem&, 0, 0, %SRCCOPY)
                   CALL TextOut(hdcScreen&, 100, 220, "(Modified Source)", 17)
                END IF
    
                CALL BitBlt(hdcScreen&, x%, y%, 50, 50, hdcMem2&, 0, 0, %SRCAND)
                CALL BitBlt(hdcScreen&, x%, y%, 50, 50, hdcMem&, 0, 0, %SRCPAINT)
    
              ' undo work on house bitmap.
                IF wTransColor& <> %IDM_BLACK THEN
                   CALL SetBkColor(hdcMem&, rgbTransparent&)
                   CALL SetTextColor(hdcMem&, rgbBlack&)
                   CALL BitBlt(hdcMem&, 0, 0, 50, 50, hdcMem2&, 0, 0, %SRCPAINT)
                END IF
             END IF
        END SELECT
    
        CALL SelectObject(hdcMem&, hbmDefault&)
        CALL SelectObject(hdcMem2&, hbmDefault&)
        CALL EndPaint(hWnd&, ps)
    
    END SUB
    
    SUB ShowStatus(hdcDst&, hdcSrc&, hdcMask&)
    
        hbm& = SelectObject(hdcSrc&, hbmFade&)
        CALL BitBlt(hdcDst&, 0, 0, 100, 100, hdcSrc&, 0, 0, %SRCCOPY)
        CALL SelectObject(hdcSrc&, hbm&)
        CALL TextOut(hdcDst&, 0, 110, "Destination", 11)
    
        CALL BitBlt(hdcDst&, 120, 20, 50, 50, hdcSrc&, 0, 0, %SRCCOPY)
        CALL TextOut(hdcDst&, 100, 110, "+ Source", 8)
    
        IF hdcMask& THEN
           CALL BitBlt(hdcDst&, 220, 20, 50, 50, hdcMask&, 0, 0, %SRCCOPY)
           CALL TextOut(hdcDst&, 200, 110, "+ Mask", 6)
        END IF
        CALL TextOut(hdcDst&, 300, 110, "= Transparency", 14)
    
    END SUB
    ------------------
    Patrice Terrier
    mailto[email protected][email protected]</A>
    www.zapsolution.com
    Addons: WinLIFT (Skin Engine), GDImage (Graphic control), Artwork (logo creation), GDI+ Helper (GDIPLUS)
    Patrice Terrier
    www.zapsolution.com
    www.objreader.com
    Addons: GDImage.DLL 32/64-bit (Graphic library), WinLIFT.DLL 32/64-bit (Skin Engine).
Working...
X