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] ' [url="http://www.zapsolution.com"]www.zapsolution.com[/url] ' ' 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)