illusion.bas

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

DECLARE FUNCTION SetBkMode LIB "GDI32.DLL" ALIAS "SetBkMode" (BYVAL hdc AS DWORD, BYVAL nBkMode AS LONG) AS LONG
DECLARE FUNCTION SetTextColor LIB "GDI32.DLL" ALIAS "SetTextColor" (BYVAL hdc AS DWORD, BYVAL crColor AS DWORD) AS DWORD
DECLARE FUNCTION CreateFontIndirect LIB "GDI32.DLL" ALIAS "CreateFontIndirectA" (lpLogFont AS LOGFONT) AS DWORD
DECLARE FUNCTION SetBkMode LIB "GDI32.DLL" ALIAS "SetBkMode" (BYVAL hdc AS DWORD, BYVAL nBkMode AS LONG) AS LONG
DECLARE FUNCTION GetDlgCtrlID LIB "USER32.DLL" ALIAS "GetDlgCtrlID" (BYVAL hWnd AS DWORD) AS LONG
DECLARE FUNCTION RoundRect LIB "GDI32.DLL" ALIAS "RoundRect" (BYVAL hdc AS DWORD, BYVAL X1 AS LONG, BYVAL Y1 AS LONG, BYVAL X2 AS LONG, BYVAL Y2 AS LONG, BYVAL X3 AS LONG, BYVAL Y3 AS LONG) AS LONG
DECLARE FUNCTION CreatePen LIB "GDI32.DLL" ALIAS "CreatePen" (BYVAL nPenStyle AS LONG, BYVAL nWidth AS LONG, BYVAL crColor AS DWORD) AS DWORD

'-----------------------------------------------------------------
' Declared Subs:  17
'-----------------------------------------------------------------
DECLARE SUB glBegin LIB "opengl32.dll" ALIAS "glBegin" (BYVAL mode AS DWORD)
DECLARE SUB glBindTexture LIB "opengl32.dll" ALIAS "glBindTexture" (BYVAL ntarget AS DWORD, BYVAL texture AS DWORD)
DECLARE SUB glBlendFunc LIB "opengl32.dll" ALIAS "glBlendFunc" (BYVAL sfactor AS DWORD, BYVAL dfactor AS DWORD)
DECLARE SUB glClear LIB "opengl32.dll" ALIAS "glClear" (BYVAL mask AS DWORD)
DECLARE SUB glEnable LIB "opengl32.dll" ALIAS "glEnable" (BYVAL cap AS DWORD)
DECLARE SUB glEnd LIB "opengl32.dll" ALIAS "glEnd" ()
DECLARE SUB glGenTextures LIB "opengl32.dll" ALIAS "glGenTextures" (BYVAL n&, textures AS ANY)
DECLARE SUB glLoadIdentity LIB "opengl32.dll" ALIAS "glLoadIdentity" ()
DECLARE SUB glRotatef LIB "opengl32.dll" ALIAS "glRotatef" (BYVAL angle AS SINGLE, BYVAL x AS SINGLE, BYVAL y AS SINGLE, BYVAL z AS SINGLE)
DECLARE SUB glTexCoord2f LIB "opengl32.dll" ALIAS "glTexCoord2f" (BYVAL s AS SINGLE, BYVAL t AS SINGLE)
DECLARE SUB glTexImage2D LIB "opengl32.dll" ALIAS "glTexImage2D" (BYVAL ntarget AS DWORD, BYVAL level&, BYVAL internalformat&, BYVAL nwidth&, BYVAL height&, BYVAL border&, BYVAL format AS DWORD, BYVAL ntype AS DWORD, npixels AS ANY)
DECLARE SUB glTexParameteri LIB "opengl32.dll" ALIAS "glTexParameteri" (BYVAL ntarget AS DWORD, BYVAL pname AS DWORD, BYVAL param&)
DECLARE SUB glTranslatef LIB "opengl32.dll" ALIAS "glTranslatef" (BYVAL x AS SINGLE, BYVAL y AS SINGLE, BYVAL z AS SINGLE)
DECLARE SUB glVertex3f LIB "opengl32.dll" ALIAS "glVertex3f" (BYVAL x AS SINGLE, BYVAL y AS SINGLE, BYVAL z AS SINGLE)
DECLARE SUB InitCommonControls LIB "COMCTL32.DLL" ALIAS "InitCommonControls" ()
DECLARE SUB PostQuitMessage LIB "USER32.DLL" ALIAS "PostQuitMessage" (BYVAL nExitCode AS LONG)
DECLARE SUB glClearDepth LIB "opengl32.dll" ALIAS "glClearDepth" (BYVAL depth AS DOUBLE)
DECLARE SUB glClearColor LIB "opengl32.dll" ALIAS "glClearColor" (BYVAL red AS SINGLE, BYVAL green AS SINGLE, BYVAL blue AS SINGLE, BYVAL alpha AS SINGLE)
DECLARE SUB glDepthFunc LIB "opengl32.dll" ALIAS "glDepthFunc" (BYVAL func AS DWORD)
DECLARE SUB glDepthMask LIB "opengl32.dll" ALIAS "glDepthMask" (BYVAL flag AS BYTE)
DECLARE SUB glShadeModel LIB "opengl32.dll" ALIAS "glShadeModel" (BYVAL mode AS DWORD)
DECLARE SUB glMatrixMode LIB "opengl32.dll" ALIAS "glMatrixMode" (BYVAL mode AS DWORD)
DECLARE SUB glDeleteTextures LIB "opengl32.dll" ALIAS "glDeleteTextures" (BYVAL n&, textures AS ANY)
DECLARE SUB glDisable LIB "opengl32.dll" ALIAS "glDisable" (BYVAL cap AS DWORD)

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

%ID_CTRL         = 101
%ID_START_SHOW   = 102
%ID_STOP_SHOW    = 103
%ID_NEW_IMAGE    = 104
%ID_STA_Help     = 105
%ID_BTN_CHECK    = 106

' 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, glWnd AS LONG
GLOBAL mt() AS ZGLTEXTURE

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 zCaptionFont() AS LONG
    DIM LF AS LogFont
    STATIC CaptionFont&
    IF CaptionFont& = 0 THEN
       LF.lfHeight = 8 ' -FontHeight&
       LF.lfWidth = 0
       LF.lfCharSet = %DEFAULT_CHARSET
       LF.lfOutPrecision = %OUT_DEFAULT_PRECIS
       LF.lfClipPrecision = %OUT_DEFAULT_PRECIS
       LF.lfQuality = %DEFAULT_QUALITY
       LF.lfPitchAndFamily = %DEFAULT_PITCH OR %FF_DONTCARE
       LF.lfWeight = 700
       LF.lfFaceName = "MS Sans Serif"
       CaptionFont& = CreateFontIndirect(LF)
    END IF
    FUNCTION = CaptionFont&
END FUNCTION

SUB zDeleteObject(hObject AS LONG)
    IF hObject THEN CALL DeleteObject(hObject): hObject = 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 hMutex      AS DWORD
    LOCAL hFound      AS DWORD
    LOCAL hMain       AS LONG
'
    LOCAL hWinXP_Lib           AS LONG ' Handle to WinXP Theme DLL
    LOCAL hWinXP_IsThemeActive AS LONG ' Handle to WinXP's IsThemeActive function
'
    zClass = "ZILLUSION"
'
    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
       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_OVERLAPPEDWINDOW
       CALL SetRect(rc, 0, 0, 668, 532)
       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 + " - ""Illusion"" OpenGL 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, _
                           672 - (7 + 120 + 8), 10, 120, 22, hMain, %ID_START_SHOW, zInstance, BYVAL %NULL)
          CALL zSetCTLFont(GetDlgItem(hMain, %ID_START_SHOW), zDefaultFont)
          CALL ZI_SetAnchorMode(GetDlgItem(hMain, %ID_START_SHOW), %ANCHOR_RIGHT)

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

        ' Create button "LOAD Image"
          CALL CreateWindowEx(0, "BUTTON", "LOAD Image", %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP, _
                           672 - (7 + 120 + 8), 10 + (22 + 5) * 2, 120, 22, hMain, %ID_NEW_IMAGE, zInstance, BYVAL %NULL)
          CALL zSetCTLFont(GetDlgItem(hMain, %ID_NEW_IMAGE), zDefaultFont)
          CALL ZI_SetAnchorMode(GetDlgItem(hMain, %ID_NEW_IMAGE), %ANCHOR_RIGHT)
          
        ' Create static help comment
          Label$ = $CR + $CR + "Transparence:" + $CR + $CR + "Load PNG file" + $CR + "using a name begining with ""il"" they use variable opacity."
                   
          CALL CreateWindowEx(0, "STATIC", (Label$), %WS_CHILD OR %WS_VISIBLE OR %SS_CENTER, _
                           672 - (7 + 120 + 8), 10 + (22 + 6) * 3, 120, 150, hMain, %ID_STA_Help, zInstance, BYVAL 0)
          CALL zSetCTLFont(GetDlgItem(hMain, %ID_STA_Help), zCaptionFont)
        ' Set the correct anchor property
          CALL ZI_SetAnchorMode(GetDlgItem(hMain, %ID_STA_Help), %ANCHOR_RIGHT)

        ' Create check button
          CALL CreateWindowEx(0, "Button", "Use GL depth test", _
                                 %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR _         ' window styles
                                 %BS_AUTOCHECKBOX OR %BS_LEFT OR %BS_VCENTER, _       ' class styles
                                 672 - (7 + 120 + 8), 502, _                          ' left, top
                                 120, 22, _                                           ' width, height
                                 hMain, %ID_BTN_CHECK, _                              ' handle of parent, control ID
                                 zInstance, BYVAL %NULL)                              ' handle of instance, creation parameters
          CALL zSetCTLFont(GetDlgItem(hMain, %ID_BTN_CHECK), zDefaultFont)
        ' Set the correct anchor property
          CALL ZI_SetAnchorMode(GetDlgItem(hMain, %ID_BTN_CHECK), %ANCHOR_BOTTOM_RIGHT)


        ' *******************************************************************************
        ' Alternate methode to create a GDImage OpenGL control
        ' Note: when GDImage is active the OpenGL $GLImageClassName is already registered
        ' -------------------------------------------------------------------------------
          ClientXsize& = 512: ClientYsize& = 512