hal.bas

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

'+--------------------------------------------------------------------------+
'|                                   HAL                                    |
'|                           (Bouncing ball demo)                           |
'|            Example that shows you how to use the GDImage.dll             |
'|                                                                          |
'+--------------------------------------------------------------------------+
'|                                                                          |
'|                         Author Patrice TERRIER                           |
'|                                                                          |
'|                           copyright (c) 2005                             |
'|                                                                          |
'|                Patrice Terrier http://www.zapsolution.com                |
'|                                                                          |
'+--------------------------------------------------------------------------+
'|                  Project started on : 12-21-2005 (MM-DD-YYYY)            |
'|                        Last revised : 12-21-2005 (MM-DD-YYYY)            |
'+--------------------------------------------------------------------------+
#COMPILE EXE "Hal.exe"

' Equates:  34
'-----------------------------------------------------------------
%WINAPI                                         = 1
%TRUE                                           = 1
%FALSE                                          = 0
%NULL                                           = 0
%ERROR_ALREADY_EXISTS                           = 183
%ANSI_VAR_FONT                                  = 12
%SW_RESTORE                                     = 9
%WM_CREATE                                      = &H1
%WM_DESTROY                                     = &H2
%WM_ACTIVATE                                    = &H6
%WM_PAINT                                       = &HF
%WM_CLOSE                                       = &H10
%WM_QUIT                                        = &H12
%WM_SETCURSOR                                   = &H20
%WM_SETFONT                                     = &H30
%WM_COMMAND                                     = &H111
%WS_CHILD                                       = &H40000000
%WS_VISIBLE                                     = &H10000000
%WS_CLIPSIBLINGS                                = &H04000000
%WS_CLIPCHILDREN                                = &H02000000
%WS_CAPTION                                     = &H00C00000  ' WS_BORDER OR WS_DLGFRAME
%WS_SYSMENU                                     = &H00080000
%WS_TABSTOP                                     = &H00010000
%WS_EX_WINDOWEDGE                               = &H00000100
%WS_EX_APPWINDOW                                = &H00040000
%CS_VREDRAW                                     = &H1
%CS_HREDRAW                                     = &H2
%PM_REMOVE                                      = &H0001
%SM_CXSCREEN                                    = 0
%SM_CYSCREEN                                    = 1
%WS_EX_STATICEDGE                               = &H00020000
%MB_ICONHAND                                    = &H00000010&
%IDC_ARROW                                      = 32512&
%SS_CENTER                                      = &H00000001
%SS_SUNKEN                                      = &H00001000

'-----------------------------------------------------------------
' TYPE and UNION structures:  7
'-----------------------------------------------------------------
TYPE RECT
  nLeft AS LONG
  nTop AS LONG
  nRight AS LONG
  nBottom AS LONG
END TYPE

TYPE POINTAPI
  x AS LONG
  y AS LONG
END TYPE

TYPE POINTS
  x AS INTEGER
  y AS INTEGER
END TYPE

TYPE tagMSG
  hwnd AS DWORD
  message AS DWORD
  wParam AS LONG
  lParam AS LONG
  time AS DWORD
  pt AS POINTAPI
END TYPE

TYPE SECURITY_ATTRIBUTES
  nLength AS DWORD
  lpSecurityDescriptor AS LONG
  bInheritHandle AS LONG
END TYPE

TYPE WNDCLASSEX
    cbSize AS DWORD
    style AS DWORD
    lpfnWndProc AS LONG
    cbClsExtra AS LONG
    cbWndExtra AS LONG
    hInstance AS DWORD
    hIcon AS DWORD
    hCursor AS DWORD
    hbrBackground AS DWORD
    lpszMenuName AS ASCIIZ PTR
    lpszClassName AS ASCIIZ PTR
    hIconSm AS DWORD
END TYPE

TYPE PAINTSTRUCT
  hDC AS DWORD
  fErase AS LONG
  rcPaint AS RECT
  fRestore AS LONG
  fIncUpdate AS LONG
  rgbReserved(0 TO 31) AS BYTE
END TYPE

'-----------------------------------------------------------------
' Declared Functions:  37
'-----------------------------------------------------------------
DECLARE FUNCTION AdjustWindowRectEx LIB "USER32.DLL" ALIAS "AdjustWindowRectEx" (lpRect AS RECT, BYVAL dsStyle AS LONG, BYVAL bMenu AS LONG, BYVAL dwEsStyle AS DWORD) AS LONG
DECLARE FUNCTION BeginPaint LIB "USER32.DLL" ALIAS "BeginPaint" (BYVAL hWnd AS DWORD, lpPaint AS PAINTSTRUCT) AS LONG
DECLARE FUNCTION CloseHandle LIB "KERNEL32.DLL" ALIAS "CloseHandle" (BYVAL hObject AS DWORD) AS LONG
DECLARE FUNCTION CreateMutex LIB "KERNEL32.DLL" ALIAS "CreateMutexA" (lpMutexAttributes AS SECURITY_ATTRIBUTES, BYVAL bInitialOwner AS LONG, lpName AS ASCIIZ) AS LONG
DECLARE FUNCTION CreateWindowEx LIB "USER32.DLL" ALIAS "CreateWindowExA" (BYVAL dwExStyle AS DWORD, lpClassName AS ASCIIZ, lpWindowName AS ASCIIZ, BYVAL dwStyle AS DWORD, BYVAL x AS LONG, BYVAL y AS LONG, _
    BYVAL nWidth AS LONG, BYVAL nHeight AS LONG, BYVAL hWndParent AS DWORD, BYVAL hMenu AS DWORD, BYVAL hInstance AS DWORD, lpParam AS ANY) AS DWORD
DECLARE FUNCTION DefWindowProc LIB "USER32.DLL" ALIAS "DefWindowProcA" (BYVAL hWnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
DECLARE FUNCTION DeleteObject LIB "GDI32.DLL" ALIAS "DeleteObject" (BYVAL hObject AS DWORD) AS LONG
DECLARE FUNCTION DispatchMessage LIB "USER32.DLL" ALIAS "DispatchMessageA" (lpMsg AS tagMSG) AS LONG
DECLARE FUNCTION DragDetect LIB "USER32.DLL" ALIAS "DragDetect" (BYVAL hWnd AS DWORD, pt AS POINTAPI) AS LONG
DECLARE FUNCTION EndPaint LIB "USER32.DLL" ALIAS "EndPaint" (BYVAL hWnd AS DWORD, lpPaint AS PAINTSTRUCT) AS LONG
DECLARE FUNCTION FindWindow LIB "USER32.DLL" ALIAS "FindWindowA" (lpClassName AS ASCIIZ, lpWindowName AS ASCIIZ) AS LONG
DECLARE FUNCTION FreeLibrary LIB "KERNEL32.DLL" ALIAS "FreeLibrary" (BYVAL hLibModule AS DWORD) AS LONG
DECLARE FUNCTION GetParent LIB "USER32.DLL" ALIAS "GetParent" (BYVAL hWnd AS DWORD) AS LONG
DECLARE FUNCTION GetClassInfoEx LIB "USER32.DLL" ALIAS "GetClassInfoExA" (BYVAL hInst AS DWORD, lpszClass AS ASCIIZ, lpWndClass AS WNDCLASSEX) AS LONG
DECLARE FUNCTION GetClientRect LIB "USER32.DLL" ALIAS "GetClientRect" (BYVAL hwnd AS DWORD, lpRect AS RECT) AS LONG
DECLARE FUNCTION GetDlgItem LIB "USER32.DLL" ALIAS "GetDlgItem" (BYVAL hDlg AS DWORD, BYVAL nIDDlgItem AS LONG) AS DWORD
DECLARE FUNCTION GetLastError LIB "KERNEL32.DLL" ALIAS "GetLastError" () AS LONG
DECLARE FUNCTION GetMessagePos LIB "USER32.DLL" ALIAS "GetMessagePos" () AS LONG
DECLARE FUNCTION GetProcAddress LIB "KERNEL32.DLL" ALIAS "GetProcAddress" (BYVAL hModule AS DWORD, lpProcName AS ASCIIZ) AS LONG
DECLARE FUNCTION GetStockObject LIB "GDI32.DLL" ALIAS "GetStockObject" (BYVAL nIndex AS LONG) AS DWORD
DECLARE FUNCTION GetSystemMetrics LIB "USER32.DLL" ALIAS "GetSystemMetrics" (BYVAL nIndex AS LONG) AS LONG
DECLARE FUNCTION GetWindowText LIB "USER32.DLL" ALIAS "GetWindowTextA" (BYVAL hWnd AS DWORD, lpString AS ASCIIZ, BYVAL cch AS LONG) AS LONG
DECLARE FUNCTION IsIconic LIB "USER32.DLL" ALIAS "IsIconic" (BYVAL hWnd AS DWORD) AS LONG
DECLARE FUNCTION LoadCursor LIB "USER32.DLL" ALIAS "LoadCursorA" (BYVAL hInstance AS DWORD, lpCursorName AS ASCIIZ) AS DWORD
DECLARE FUNCTION LoadIcon LIB "USER32.DLL" ALIAS "LoadIconA" (BYVAL hInstance AS DWORD, lpIconName AS ASCIIZ) AS DWORD
DECLARE FUNCTION LoadLibrary LIB "KERNEL32.DLL" ALIAS "LoadLibraryA" (lpLibFileName AS ASCIIZ) AS LONG
DECLARE FUNCTION MessageBox LIB "USER32.DLL" ALIAS "MessageBoxA" (BYVAL hWnd AS DWORD, lpText AS ASCIIZ, lpCaption AS ASCIIZ, BYVAL dwType AS DWORD) AS LONG
DECLARE FUNCTION PeekMessage LIB "USER32.DLL" ALIAS "PeekMessageA" (lpMsg AS tagMSG, BYVAL hWnd AS DWORD, BYVAL dwMsgFilterMin AS DWORD, BYVAL dwMsgFilterMax AS DWORD, BYVAL dwRemoveMsg AS DWORD) AS LONG
DECLARE FUNCTION RegisterClassEx LIB "USER32.DLL" ALIAS "RegisterClassExA" (pcWndClassEx AS WNDCLASSEX) AS WORD
DECLARE FUNCTION ScreenToClient LIB "USER32.DLL" ALIAS "ScreenToClient" (BYVAL hWnd AS DWORD, lpPoint AS POINTAPI) AS LONG
DECLARE FUNCTION SendMessage LIB "USER32.DLL" ALIAS "SendMessageA" (BYVAL hWnd AS DWORD, BYVAL dwMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
DECLARE FUNCTION SetFocus LIB "USER32.DLL" ALIAS "SetFocus" (BYVAL hWnd AS DWORD) AS LONG
DECLARE FUNCTION SetForegroundWindow LIB "USER32.DLL" ALIAS "SetForegroundWindow" (BYVAL hWnd AS DWORD) AS LONG
DECLARE FUNCTION SetRect LIB "USER32.DLL" ALIAS "SetRect" (lpRect AS RECT, BYVAL X1 AS LONG, BYVAL Y1 AS LONG, BYVAL X2 AS LONG, BYVAL Y2 AS LONG) AS LONG
DECLARE FUNCTION SetWindowText LIB "USER32.DLL" ALIAS "SetWindowTextA" (BYVAL hWnd AS DWORD, lpString AS ASCIIZ) AS LONG
DECLARE FUNCTION ShowWindow LIB "USER32.DLL" ALIAS "ShowWindow" (BYVAL hWnd AS DWORD, BYVAL nCmdShow AS LONG) AS LONG
DECLARE FUNCTION timeGetTime LIB "WINMM.DLL" ALIAS "timeGetTime" () AS DWORD
DECLARE FUNCTION TranslateMessage LIB "USER32.DLL" ALIAS "TranslateMessage" (lpMsg AS tagMSG) AS LONG

'-----------------------------------------------------------------
' Declared Subs:  3
'-----------------------------------------------------------------
DECLARE SUB apiSleep LIB "KERNEL32.DLL" ALIAS "Sleep" (BYVAL dwMilliseconds AS DWORD)
DECLARE SUB InitCommonControls LIB "COMCTL32.DLL" ALIAS "InitCommonControls" ()
DECLARE SUB PostQuitMessage LIB "USER32.DLL" ALIAS "PostQuitMessage" (BYVAL nExitCode AS LONG)

%PM_NOREMOVE = &H0000
%WM_TIMER    = &H113
DECLARE FUNCTION SetTimer LIB "USER32.DLL" ALIAS "SetTimer" (BYVAL hWnd AS DWORD, BYVAL nIDEvent AS LONG, BYVAL uElapse AS DWORD, BYVAL lpTimerFunc AS LONG) AS LONG
DECLARE FUNCTION KillTimer LIB "USER32.DLL" ALIAS "KillTimer" (BYVAL hWnd AS DWORD, BYVAL nIDEvent AS LONG) AS LONG
DECLARE FUNCTION WaitMessage LIB "USER32.DLL" ALIAS "WaitMessage" () AS LONG
DECLARE FUNCTION GetMessage LIB "USER32.DLL" ALIAS "GetMessageA" (lpMsg AS tagMSG, BYVAL hWnd AS DWORD, BYVAL uMsgFilterMin AS DWORD, BYVAL uMsgFilterMax AS DWORD) AS LONG

'------------------------------------------------------------------------------------------
#RESOURCE "hal.pbr"
'------------------------------------------------------------------------------------------
#INCLUDE "gdimage.inc"
'------------------------------------------------------------------------------------------

TYPE SpriteDataStruct
    ImageName AS ASCIIZ * 128
    hBitmap   AS LONG
    ID        AS LONG
    xPos      AS LONG
    yPos      AS LONG
    xDir      AS LONG
    yDir      AS LONG
    nWidth    AS LONG
    nHeight   AS LONG
    MoveCount AS LONG
END TYPE

$Times_New_Roman = "Times New Roman" ' Must be a valid TTF

%CtrlW = 580
%CtrlH = 400

%ID_CTRL         = 101
%ID_START_SHOW   = 102
%ID_STOP_SHOW    = 103

' Warning each overlay object must have a unique identifier
%ID_OBJECT_MARQUEE = 1
%ID_OBJECT_SPRITE  = 10 ' Do not use 11,12,13,14

' WinXP Theme support declares (if applicable)
DECLARE FUNCTION EnableDialogTheme(BYVAL hDlg AS DWORD, BYVAL dwStyle AS DWORD) AS LONG
DECLARE FUNCTION IsThemeActive() AS LONG

GLOBAL Animate AS LONG, Active AS LONG, SpriteData() AS SpriteDataStruct, hCtrl AS LONG
GLOBAL xBoundWidth AS LONG, xBoundHeight AS LONG, FastComputer AS LONG

FUNCTION zDefaultFont() AS LONG
    STATIC hDefault&
    IF hDefault& = 0 THEN hDefault& = GetStockObject(%ANSI_VAR_FONT)
    FUNCTION = hDefault&
END FUNCTION

SUB zSetCTLFont(BYVAL hC&, BYVAL hFont&)
    CALL SendMessage(hC&, %WM_SETFONT, hFont&, 0)
END SUB

FUNCTION zStaticCenter(BYVAL Label$, BYVAL x&, BYVAL y&, BYVAL w&, BYVAL h&, BYVAL hParent&, BYVAL ID&) AS LONG
    hCtl& = CreateWindowEx(0, "STATIC", (Label$), %WS_CHILD OR %WS_VISIBLE OR %SS_SUNKEN OR %SS_CENTER, _
                           x&, y&, w&, h&, hParent&, ID&, zInstance, BYVAL %NULL)
    CALL zSetCTLFont(hCtl&, zDefaultFont)
    FUNCTION = hCtl&
END FUNCTION

FUNCTION zGetCTLText(BYVAL hC&) AS STRING
    LOCAL szText AS ASCIIZ * 4096
    Length& = GetWindowText(hC&, szText, SIZEOF(szText))
    IF Length& THEN FUNCTION = LEFT$(szText, Length&)
END FUNCTION

FUNCTION zReportError(BYVAL Message$) AS LONG
    REPLACE $zLim WITH $CR IN Message$
    FUNCTION = MessageBox(0, (Message$), ("GDImage version " + ZI_Version), %MB_ICONHAND)
END FUNCTION

FUNCTION WINMAIN (BYVAL hInstance     AS LONG, _
                  BYVAL hPrevInstance AS LONG, _
                  BYVAL lpCmdLine     AS ASCIIZ PTR, _
                  BYVAL iCmdShow      AS LONG) AS LONG

    LOCAL Msg         AS tagMsg
    LOCAL wc          AS WndClassEx
    LOCAL zClass      AS ASCIIZ * 80
    LOCAL dwExStyle   AS DWORD
    LOCAL dwStyle     AS DWORD
    LOCAL rc          AS RECT
    LOCAL x           AS LONG
    LOCAL y           AS LONG
    LOCAL Done        AS LONG
    LOCAL hMutex      AS DWORD
    LOCAL hFound      AS DWORD
    LOCAL hMain       AS LONG
    LOCAL hBitmap     AS LONG
    LOCAL hImage      AS LONG
    LOCAL bmW         AS LONG
    LOCAL bmH         AS LONG
'
    LOCAL hWinXP_Lib           AS LONG ' Handle to WinXP Theme DLL
    LOCAL hWinXP_IsThemeActive AS LONG ' Handle to WinXP's IsThemeActive function
'
    zClass = "ZHAL"
'
    hMutex = CreateMutex(BYVAL %Null, 0, zClass)
    IF hMutex THEN
       IF GetLastError = %ERROR_ALREADY_EXISTS THEN
          DO
             hFound = FindWindow(zClass, ""): IF hFound THEN EXIT DO
             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