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

PB DLL 5 or 6: A game for you

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

  • PB DLL 5 or 6: A game for you

    A game for you.

    Code:
    '-------------------------------------------------------------------------------
    '   GAME1.BAS
    '   9.20.99 Created
    '  Released to public domain by author, Michael Mattias
    '  commented source code available by sending e-mail to [email protected]
    '-------------------------------------------------------------------------------
    
    $COMPILE EXE
    '#DEBUG ERROR ON
    $REGISTER NONE
    $INCLUDE "WIN32API.INC"
    $INCLUDE "COMMCTRL.INC"
    
    DECLARE SUB GetNewButtonPos (BYVAL hWnd AS LONG, BYVAL HStatus AS LONG, BYVAL BW AS LONG, BYVAL BH AS LONG, BX AS LONG, BY AS LONG)
    DECLARE FUNCTION ButtonSubClassProc (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _
                      BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG
    DECLARE FUNCTION NextStatusText AS STRING
    GLOBAL hInstance AS LONG
    GLOBAL DefaultButtonProc AS LONG
    '------------------------------------------------------------------------------
    
    FUNCTION WINMAIN (BYVAL hInst         AS LONG, _
                      BYVAL hPrevInstance AS LONG, _
                      lpCmdLine           AS ASCIIZ PTR, _
                      BYVAL iCmdShow      AS LONG) AS LONG
    
      LOCAL Msg         AS tagMsg
      LOCAL wndclass    AS WndClassEx
      LOCAL szAppName   AS ASCIIZ * 80
      LOCAL hWnd        AS LONG
    
      szAppName              = "Game_One"
      hInstance              = hInst
      wndclass.cbSize        = SIZEOF(WndClass)
      wndclass.style         = %CS_HREDRAW OR %CS_VREDRAW
      wndclass.lpfnWndProc   = CODEPTR( WndProc )
      wndclass.cbClsExtra    = 0
      wndclass.cbWndExtra    = 0
      wndclass.hInstance     = hInstance
      wndclass.hIcon         = LoadIcon( hInstance, "HELLOWIN" )
      wndclass.hCursor       = LoadCursor( %NULL, BYVAL %IDC_ARROW )
      wndclass.hbrBackground = GetStockObject( %WHITE_BRUSH )
      wndclass.lpszMenuName  = %NULL
      wndclass.lpszClassName = VARPTR( szAppName )
      wndclass.hIconSm       = LoadIcon( hInstance, BYVAL %IDI_APPLICATION )
      RegisterClassEx wndclass
      hWnd = CreateWindow(szAppName, _
                          "A Game For You", _
                          %WS_OVERLAPPEDWINDOW, _
                          %CW_USEDEFAULT, _
                          %CW_USEDEFAULT, _
                          %CW_USEDEFAULT, _
                          %CW_USEDEFAULT, _
                          %NULL, _
                          %NULL, _
                          hInstance, _
                          BYVAL %NULL)
    
      ShowWindow hWnd, iCmdShow
      UpdateWindow hWnd
    
      WHILE GetMessage(Msg, %NULL, 0, 0)
        TranslateMessage Msg
        DispatchMessage Msg
      WEND
    
      FUNCTION = msg.wParam
    
    END FUNCTION
    
    
    %StatusLineID   = 200&
    %ButtonID       = 201&
    
    FUNCTION WndProc (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _
                      BYVAL wParam AS LONG, BYVAL lParam AS LONG) EXPORT AS LONG
    
      LOCAL  hDC         AS LONG
      LOCAL  LpPaint     AS PaintStruct
      LOCAL  tRect       AS Rect
      LOCAL   tPoint     AS PointApi
      STATIC hButton     AS LONG
      STATIC hStatus     AS LONG
      STATIC ButtonX     AS LONG, ButtonY AS LONG, ButtonWidth AS LONG, ButtonHeight AS LONG
      STATIC ButtonLabel AS ASCIIZ * 12
      STATIC MessageLine AS ASCIIZ * 36
      LOCAL  tm          AS TextMetric
      STATIC CxChar      AS LONG, CyChar AS LONG
      LOCAL Stat         AS LONG
      STATIC FirstPaint  AS LONG
    
      SELECT CASE wMsg
    
        CASE %WM_CREATE
             hDC = GetDC(Hwnd)
             GetTextMetrics hDC, tm
             CxChar = tm.tmAveCharWidth
             CyChar = tm.tmHeight + tm.tmExternalLeading
             ReleaseDC hWnd, hDC
             ButtonWidth = 20 * CxChar: ButtonHeight = 7 * CyChar / 4
             RANDOMIZE
             hButton = CreateWindow("button", _
                          "Click Me", _
                          %WS_CHILD _
                           OR %WS_VISIBLE _
                           OR %BS_PUSHBUTTON, _
                          0, _
                          0, _
                          0, _
                          0, _
                          hWnd, _
                          %NULL, _
                          hInstance, _
                          BYVAL %NULL)
            DefaultButtonProc = SetWindowLong (hButton, %GWL_WNDPROC, CODEPTR(ButtonSubClassProc))
            hStatus = CreateStatusWindow(%WS_CHILD OR %WS_BORDER OR %WS_VISIBLE OR %SBS_SIZEGRIP, _
                                       "Ready", hWnd, %StatusLineID)
    
             FUNCTION = 0
             EXIT FUNCTION
    
    
          CASE %WM_PAINT
    
            IF ISFALSE(FirstPaint) THEN
               GetClientRect hWnd, tRect
               ButtonX = (tRect.nRight - tRect.nleft - ButtonWidth)  / 2
               ButtonY = (tRect.nbottom - tRect.nTop - ButtonHeight) / 2
               FirstPaint = %TRUE
            END IF
            hDC = BeginPaint(hWnd, LpPaint)
            EndPaint hWnd, LpPaint
            Stat = MoveWindow (hButton, ButtonX, ButtonY, ButtonWidth, ButtonHeight, %TRUE)
            MessageLine = NextStatusText
            SendMessage hStatus, %WM_SETTEXT, 0, VARPTR(MessageLine)
            MessageBeep %MB_ICONEXCLAMATION
    
          CASE %WM_COMMAND
    
            IF  (Lparam= hButton)  AND (HIWRD(WParam) = %BN_CLICKED) THEN      'LBUTTONDOWN)  THEN    '   %BN_CLICKED) THEN
                ShowWindow hButton, %SW_HIDE
                GetNewButtonPos hWnd, hStatus, ButtonWidth, ButtonHeight, ButtonX, ButtonY
                ShowWindow hButton, %SW_NORMAL
               FUNCTION = 0
               EXIT FUNCTION
           END IF
    
         CASE %WM_SIZE
            IF wParam <> %SIZE_MINIMIZED THEN
              SendMessage hStatus, wMsg, wParam, lParam
              GetNewButtonPos hWnd, hStatus, ButtonWidth, ButtonHeight, ButtonX, ButtonY
            END IF
            FUNCTION = 0
            EXIT FUNCTION
    
        CASE %WM_DESTROY, %WM_CLOSE
          PostQuitMessage 0
          FUNCTION = 0
          EXIT FUNCTION
    
        CASE %WM_MOUSEMOVE
            IF Lparam = hButton THEN
                GetClientRect hWnd,trect
                InvalidateRect hWnd, tRect, 0
                UpdateWindow hWnd
                FUNCTION = 0
                EXIT FUNCTION
             END IF
    
      END SELECT
    
      FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam)
    
    END FUNCTION
    
    SUB GetNewButtonPos (BYVAL hWnd AS LONG, BYVAL HStatus AS LONG, BYVAL BW AS LONG, BYVAL BH AS LONG, BX AS LONG, BY AS LONG)
    
       DIM R AS Rect
       DIM S AS Rect
       DIM StatLineHeight AS LONG
    
       GetClientRect hwnd, R       ' current client area of main Window
       GetClientRect hStatus, S    ' need height of status line to avoid puttting button there.
       StatLineHeight = S.nBottom - S.ntop
    
       BX = RND(0, R.nRight - BW)
       BY = RND(0, R.nBottom -StatLineHeight - BH)
    
    END SUB
    
    FUNCTION ButtonSubClassProc (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _
                      BYVAL wParam AS LONG, BYVAL lParam AS LONG) EXPORT AS LONG
    
        IF wMsg = %WM_MOUSEMOVE THEN
           SendMessage GetParent(hWnd), %WM_COMMAND, %BN_CLICKED * 65536& + %ButtonID, hWnd
    
        END IF
    
       FUNCTION = CallWindowProc(DefaultButtonProc, hWnd, wMSg, WParam, Lparam)
    
    END FUNCTION
    
    FUNCTION NextStatusText AS STRING
    
       FUNCTION = READ$(RND(1,DATACOUNT))
       EXIT FUNCTION
    
    DATA "Nope", "Nice Try", "Getting Slower with Age?", "Almost!", "Not even close"
    
    
    END FUNCTION
    Michael Mattias
    Tal Systems (retired)
    Port Washington WI USA
    [email protected]
    http://www.talsystems.com

  • #2
    PB/DLL 6.0... a DDT version of MCM's Game without the status bar (note, this is just for comparison purposes!)

    Code:
    #COMPILE EXE
    #INCLUDE "WIN32API.INC"
     
    DECLARE CALLBACK FUNCTION WndProc
    DECLARE SUB GetNewButtonPos (BYVAL hWnd AS LONG, BYVAL BW AS LONG, BYVAL BH AS LONG, BX AS LONG, BY AS LONG)
    DECLARE FUNCTION ButtonSubClassProc (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG
     
    GLOBAL DefaultButtonProc AS LONG
    %ButtonID = 201&
     
    FUNCTION PBMAIN
        DIM hDlg AS LONG
        DIALOG NEW 0, "Game One",,, 300, 200, %DS_CENTER OR %WS_CAPTION OR %WS_SYSMENU OR %WS_THICKFRAME OR %WS_MAXIMIZEBOX OR %WS_MINIMIZEBOX OR %WS_CLIPCHILDREN TO hDlg
        CONTROL ADD BUTTON, hDlg, %ButtonID, "Click Me", 130, 93, 40, 13
        DIALOG SHOW MODAL hDlg, CALL WndProc
    END FUNCTION
     
    CALLBACK FUNCTION WndProc
        LOCAL tRect AS Rect
        STATIC hButton AS LONG
        STATIC ButtonX AS LONG, ButtonY AS LONG, ButtonWidth AS LONG, ButtonHeight AS LONG
     
        SELECT CASE CBMSG
          CASE %WM_INITDIALOG
            ButtonWidth = 40 : ButtonHeight = 13
            RANDOMIZE TIMER
            CONTROL HANDLE CBHNDL, %ButtonID TO hButton
            DefaultButtonProc = SetWindowLong(hButton, %GWL_WNDPROC, CODEPTR(ButtonSubClassProc))
     
          CASE %WM_PAINT
            CONTROL SET LOC CBHNDL, %ButtonID, ButtonX, ButtonY
            MessageBeep %MB_ICONEXCLAMATION
     
          CASE %WM_COMMAND
            DIALOG END CBHNDL
             
          CASE %WM_USER
            ShowWindow hButton, %SW_HIDE
            GetNewButtonPos CBHNDL, ButtonWidth, ButtonHeight, ButtonX, ButtonY
            ShowWindow hButton, %SW_NORMAL
            UpdateWindow CBHNDL
     
          CASE %WM_SIZE
            IF CBWPARAM <> %SIZE_MINIMIZED THEN DIALOG SEND CBHNDL, %WM_USER, 0, 0
     
          CASE %WM_DESTROY
            SetWindowLong hButton, %GWL_WNDPROC, DefaultButtonProc
            DIALOG END CBHNDL
     
          END SELECT
    END FUNCTION
     
    SUB GetNewButtonPos (BYVAL hWnd AS LONG, BYVAL BW AS LONG, BYVAL BH AS LONG, BX AS LONG, BY AS LONG)
        DIM x&, y&
        DIALOG GET CLIENT hWnd TO x&, y&
        BX = RND(0, x& - BW)
        BY = RND(0, y& - BH)
    END SUB
     
    FUNCTION ButtonSubClassProc (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _
        BYVAL wParam AS LONG, BYVAL lParam AS LONG) EXPORT AS LONG
     
        IF wMsg = %WM_MOUSEMOVE THEN
            DIALOG SEND GetParent(hWnd), %WM_USER, 0, 0
        ELSE
            FUNCTION = CallWindowProc(DefaultButtonProc, hWnd, wMSg, WParam, Lparam)
        END IF
    END FUNCTION
    Lance
    PowerBASIC Support
    Lance
    mailto:[email protected]

    Comment


    • #3
      Michael, I have been having fun with this! I can catch the button by holding down the Left mouse button, so this must mean I win?

      Lance, I have tried your DDT version and I can resize the window until I trap it-- I guess I win? I also experience an Illegal operation each time I play your version, always near the end of the game.

      Thanks for the Fun! Regards, Jules
      Best regards
      Jules
      www.rpmarchildon.com

      Comment


      • #4
        Actually I never intended for anyone to win. I only wrote that because I wanted to experiment with subclassing, and I was sick and tired of the "academic" program exercises I'd been putting myself through.

        Never having written *any* "fun" or "game" program before, I am somewhat suprised at the responses I've gotten.

        First, I learn that you *can* "win." (??)

        Then, I sent a copy to my friend Phyllis. She told me her grandson liked it. For about ten minutes.

        Worst of all, I sent a copy to my father, and he responded by e-mail:

        THIS IS A MEAN & DIRTY LITTLE TRICK TP
        PULL ON AN OLD MAN. YOU SHOULD BE
        ASHAMED.......


        I think I'll get out of the games business while the getting is good...

        MCM






        Michael Mattias
        Tal Systems (retired)
        Port Washington WI USA
        [email protected]
        http://www.talsystems.com

        Comment


        • #5
          Michael,
          Us 'ol-dogs' learn much from these worthless
          programs. They can teach even hard-headed folks
          [ like me ] new 'tricks'.
          Please keep up the good work. Some of us are
          still learning.......
          Thanks,
          P.

          Comment

          Working...
          X