sprite.bas

Powerbasic 对GDI 的操作 很漂亮的代码!

             WHILE PeekMessage(Msg, %NULL, %NULL, %NULL, %PM_REMOVE): WEND
          LOOP
          IF IsIconic(hFound) THEN CALL ShowWindow(hFound, %SW_RESTORE)
          CALL SetForeGroundWindow(hFound)
          FUNCTION = 0
          EXIT FUNCTION
       END IF
    END IF
'
    IsInitialized& = GetClassInfoEx(zInstance, zClass, wc)
    IF IsInitialized&   = 0 THEN
       wc.cbSize        = SIZEOF(wc)
       wc.style         = %CS_HREDRAW OR %CS_VREDRAW
       wc.lpfnWndProc   = CODEPTR(WndProc)
       wc.cbClsExtra    = 0
       wc.cbWndExtra    = 0
       wc.hInstance     = zInstance
       wc.hIcon         = LoadIcon(wc.hInstance, "PROGRAM")
       wc.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
       wc.hbrBackground = %NULL ' GetStockObject(%BLACK_BRUSH)
       wc.lpszMenuName  = %NULL
       wc.lpszClassName = VARPTR(zClass)
       wc.hIconSm       = wc.hIcon
       IF RegisterClassEx(wc) THEN IsInitialized& = %TRUE
    END IF
'
    IF IsInitialized& THEN

     ' ************************************************************************************
     ' Load the GDImage.dll
       IF RegisterGDImageClass() = 0 THEN
          FUNCTION = 99:  EXIT FUNCTION ' If it fails to register then return ERROR = 99
       END IF
     ' ************************************************************************************

     ' Load the WinXP Theme support (if applicable)
       hWinXP_Lib = LoadLibrary("UxTheme.dll")
       IF hWinXP_Lib THEN
          hWinXP_IsThemeActive = GetProcAddress(hWinXP_Lib, "IsThemeActive")
       END IF
'
       CALL InitCommonControls
'
     ' Window Extended Style
       dwExStyle = %WS_EX_APPWINDOW OR %WS_EX_WINDOWEDGE
     ' Windows Style
       dwStyle = %WS_VISIBLE OR %WS_CLIPSIBLINGS OR %WS_CLIPCHILDREN OR %WS_CAPTION OR _
                 %WS_SYSMENU ' OR %WS_MAXIMIZEBOX OR %WS_MINIMIZEBOX
'
       CALL SetRect(rc, 0, 0, 740, 420)
       CALL AdjustWindowRectEx(rc, dwStyle, %FALSE, dwExStyle)  ' Adjust Window To True Requested Size
'
       x = MAX&((GetSystemMetrics(%SM_CXSCREEN) - rc.nRight - rc.nLeft) \ 2, 0)
       y = MAX&((GetSystemMetrics(%SM_CYSCREEN) - rc.nBottom - rc.nTop) \ 2, 0)
'
     ' Create The Window
       MyTitle$ = "GDImage control " + ZI_Version + " Sprite demo"
       hMain = CreateWindowEx(dwExStyle, _            ' Extended Style For The Window
                             zClass, _                ' Class Name
                             (MyTitle$), _            ' Window Title
                             dwStyle OR _             ' Defined Window Style
                             %WS_CLIPSIBLINGS OR _    ' Required Window Style
                             %WS_CLIPCHILDREN, _      ' Required Window Style
                             x, y, _                  ' Window Position
                             rc.nRight - rc.nLeft, _  ' Calculate Window Width
                             rc.nBottom - rc.nTop, _  ' Calculate Window Height
                             %NULL, _                 ' No Parent Window
                             %NULL, _                 ' No Menu
                             wc.hInstance, _          ' Instance
                             BYVAL %NULL)             ' Dont Pass Anything To WM_CREATE
'
       IF hMain THEN
'
        ' Apply WinXP Theme support
          LOCAL lRes AS LONG, pProc AS DWORD
          IF hWinXP_IsThemeActive THEN
             CALL DWORD hWinXP_IsThemeActive USING IsThemeActive TO lRes
             IF lRes  THEN pProc = GetProcAddress(lRes, "EnableThemeDialogTexture")
             IF pProc THEN CALL DWORD pProc USING EnableDialogTheme(hMain, &H01 Or &H02 Or &H04 Or &H06)
          END IF
'
        ' Create button "START"
          CALL CreateWindowEx(0, "BUTTON", "START", %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP, _
                           740 - (7 + 120 + 8), 10, 120, 22, hMain, %ID_START_SHOW, zInstance, BYVAL %NULL)
          CALL zSetCTLFont(GetDlgItem(hMain, %ID_START_SHOW), zDefaultFont)

        ' Create button "STOP"
          CALL CreateWindowEx(0, "BUTTON", "STOP", %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP, _
                           740 - (7 + 120 + 8), 10 + (22 + 5) * 1, 120, 22, hMain, %ID_STOP_SHOW, zInstance, BYVAL %NULL)
          CALL zSetCTLFont(GetDlgItem(hMain, %ID_STOP_SHOW), zDefaultFont)

        ' Create button "STOP"
          CALL CreateWindowEx(0, "BUTTON", "Drag sprite", %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP, _
                           740 - (7 + 120 + 8), 10 + (22 + 5) * 2, 120, 22, hMain, %ID_MOUSE_DRAG, zInstance, BYVAL %NULL)
          CALL zSetCTLFont(GetDlgItem(hMain, %ID_MOUSE_DRAG), zDefaultFont)

        ' Create Static 
          CALL zStaticCenter("Fps ", 740 - (10 + 50 + 6), 410 - 18, 52, 18, hMain, %ID_STATIC)

        ' ******************************************************************************
        ' Helper function to create A GDImage control (with automatic scrollbar support)
        ' ------------------------------------------------------------------------------
          hCtrl = ZI_CreateWindow(hMain, 10, 10, 580, 400, %ID_CTRL)
        ' Use gradient for background
          CALL ZI_SetProperty(hCtrl, %ZI_GradientTop, RGB(93,3,28))
          CALL ZI_SetProperty(hCtrl, %ZI_GradientBottom, RGB(0,3,40))

        ' Show the main window
          CALL ShowWindow(hMain, iCmdShow)
          CALL SetForegroundWindow(hMain)                  ' Slightly Higher Priority
          CALL SetFocus(hCtrl)                             ' Sets Keyboard Focus To The Window

        ' This is a special message loop to render fast animation
          WHILE Done = %FALSE                              ' Loop That Runs While done = %FALSE
             IF PeekMessage(Msg, %NULL, 0, 0, %PM_REMOVE) THEN ' Is There A Message Waiting?
                IF msg.message = %WM_QUIT THEN             ' Have We Received A Quit Message?
                   Done = %TRUE                            ' If So done = %TRUE
                ELSE                                       ' If Not, Deal With Window Messages
                   'IF TranslateAccelerator(ghWnd, hAccel, Msg) = 0 THEN
                      CALL TranslateMessage(msg)           ' Translate The Message
                      CALL DispatchMessage(msg)            ' Dispatch The Message
                   'END IF
                END IF
             ELSE                                          ' If There Are No Messages
              ' Draw The Scene.
                IF Active THEN
                   IF Animate < 0 THEN' = -1 THEN 
                      IF fps = 0 THEN T??? = TimeGetTime() + 2000

                      CALL DrawSprite                      ' Draw The Scene (Don't Draw When Inactive 1% CPU Use)

                      IF T??? THEN
                         IF TimeGetTime() > T??? THEN
                            CALL SetWindowText(GetDlgItem(hMain, %ID_STATIC), _
                                          EXTRACT$(zGetCTLText(GetDlgItem(hMain, %ID_STATIC)), " ") + STR$(fps \ 2))
                            T??? = 0
                         END IF
                      END IF
                   ELSEIF Animate = 0 THEN
                      CALL apisleep(10)
                   END IF
                ELSE                                       ' When minimized don't hog the CPU.
                   CALL apiSleep(100)
                END IF
             END IF
          WEND

          FUNCTION = msg.wParam
       END IF

     ' UNLOAD the WinXP Theme DLL (if necessary)
       IF hWinXP_Lib THEN CALL FreeLibrary(hWinXP_Lib)

    END IF
'
    IF hMutex THEN CALL CloseHandle(hMutex)
'
END FUNCTION

SUB DrawSprite()
    REGISTER k AS LONG
    LOCAL x AS LONG, y AS LONG
    IF Animate = -1 THEN
       FOR k = 1 TO 4
           x = RND(0, 580): y = RND(0, 400)
           'CALL ZD_SetObjectXY(%ID_OBJECT_SPRITE + k, x, y, %TRUE): IF T??? THEN INCR fps
           CALL ZD_SetObjectXY(%ID_OBJECT_SPRITE + k, x, y, %FALSE)
       NEXT
     ' This has been moved there to show you that the frame count was accurate  
'call apisleep(3)
       CALL ZI_UpdateWindow(hCtrl, 0): IF T??? THEN INCR fps
       IF T??? = 0 AND fps > 0 THEN 
          CALL apisleep(fps \ 30)
       END IF
    END IF
END SUB

SUB GetMyBitmap(BYVAL hWin AS LONG)
    LOCAL rc AS RECT

    DIM hBitmap(1 TO 4)
    CALL GetClientRect(hCtrl, rc)
    CALL ZI_GetBitmapSize(hBitmap&, bmW&, bmH&)
    hBitmap(1) = ZI_CreateBitmapFromFile("yellow.png", bmW&, bmH&)
    hBitmap(2) = ZI_CreateBitmapFromFile("blue.png", bmW&, bmH&)
    hBitmap(3) = ZI_CreateBitmapFromFile("green.png", bmW&, bmH&)
    hBitmap(4) = ZI_CreateBitmapFromFile("red.png", bmW&, bmH&)
    x& = (rc.nRight - bmW&) \ 2: y& = (rc.nBottom - bmH&) \ 2
    FOR K& = 1 TO 4
        CALL ZD_DrawBitmapToCtrl(hCtrl, x&, y&, hBitmap(K&), &HFFFFFFFF, %ID_OBJECT_SPRITE + K&, %ZS_VISIBLE)
    NEXT
    
    CALL ZD_SetObjectImageLabel(%ID_OBJECT_SPRITE + 1, ("yellow"))
    CALL ZD_SetObjectImageLabel(%ID_OBJECT_SPRITE + 2, ("blue"))
    CALL ZD_SetObjectImageLabel(%ID_OBJECT_SPRITE + 3, ("green"))
    CALL ZD_SetObjectImageLabel(%ID_OBJECT_SPRITE + 4, ("red"))

END SUB

FUNCTION WndProc(BYVAL hWin&, BYVAL Msg&, BYVAL wParam&, BYVAL lParam&) EXPORT AS LONG
    LOCAL ps AS PAINTSTRUCT
    LOCAL lp AS POINTAPI

    STATIC wasX&, wasY&

    SELECT CASE Msg&

    CASE %WM_ACTIVATE                                ' Watch For Window Activate Message
         IF HIWRD(wParam&) = 0 THEN                   ' Check Minimization State
            Active = 1                               ' Program Is Active
         ELSE                                        ' Otherwise
            Active = 0                               ' Program Is No Longer Active
         END IF

    CASE %WM_SETCURSOR
         IF Animate = 2 AND wParam& = hCtrl THEN
            CALL ZD_GetObjectBound(%ID_OBJECT_SPRITE + 4, bmW&, bmH&)
            CursorLoaction& = GetMessagePos
            lp.x = LOWRD(CursorLoaction&)
            lp.y = HIWRD(CursorLoaction&)
            CALL ScreenToClient(hCtrl, lp)
            x& = lp.x - (bmW& \ 2)
            y& = lp.y - (bmH& \ 2)
            IF DragDetect(wParam&, lp) THEN
               IF x& <> wasX& OR y& <> wasY& THEN
                  CALL ZD_SetObjectAlpha(%ID_OBJECT_SPRITE + 4, 200, %FALSE)
                  CALL ZD_SetObjectXY(%ID_OBJECT_SPRITE + 4, x&, y&, %TRUE)           
                  CALL ZD_SetObjectAlpha(%ID_OBJECT_SPRITE + 4, 255, %FALSE)
               END IF
               wasX& = x&: wasY& = y&
            END IF
         END IF

    CASE %WM_COMMAND
         wP& = LOWRD(wParam&)

         SELECT CASE LONG wP&
         CASE %ID_START_SHOW
              IF LBOUND(hBitmap) < 1 THEN
                 CALL GetMyBitmap(hWin&)
                 Animate = -1
              ELSE
                 Animate = -1
              END IF
  
         CASE %ID_STOP_SHOW
              Animate = 0: fps = 0
              CALL SetWindowText(GetDlgItem(hWin&, %ID_STATIC), EXTRACT$(zGetCTLText(GetDlgItem(hWin&, %ID_STATIC)), " "))

         CASE %ID_MOUSE_DRAG
              IF LBOUND(hBitmap) < 1 THEN
                 CALL GetMyBitmap(hWin&)
                 Animate = 2
              ELSE
                 Animate = 2
              END IF

         END SELECT

    CASE %WM_CREATE
    CASE %WM_PAINT
         CALL GradientPaint(hWin&, RGB(228,227,227), RGB(168,167,191))
         FUNCTION = 0: EXIT FUNCTION
    CASE %WM_CLOSE
    CASE %WM_DESTROY
         IF LBOUND(hBitmap)> 0 THEN
            FOR K& = LBOUND(hBitmap) TO UBOUND(hBitmap): CALL DeleteObject(hBitmap(K&)): NEXT
         END IF
         CALL PostQuitMessage(0)
         FUNCTION = 0: EXIT FUNCTION
    END SELECT
    FUNCTION = DefWindowProc(hWin&, Msg&, wParam&, lParam&)
END FUNCTION

SUB GradientPaint(BYVAL hWin&, BYVAL TopRGB&, BYVAL BottomRGB&)
    LOCAL ps AS PAINTSTRUCT
    LOCAL rc AS RECT
  ' Tile the background
    CALL GetClientRect (hWin&, rc)
    hDC& = BeginPaint(hWin&, ps)
    CALL ZI_GradientPaintDC(hDC&, 0, 0, rc.nRight, rc.nBottom, TopRGB&, BottomRGB&)
    CALL EndPaint(hWin&, ps)
END SUB