chart.bas

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

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

%ID_CTRL       = 101
%ID_RESET      = 103
%ID_UP         = 104
%ID_LEFT       = 105
%ID_RIGHT      = 106
%ID_DOWN       = 107
%ID_ZOOM_IN    = 109
%ID_ZOOM_OUT   = 110
%ID_STATIC     = 112

' 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 Active AS LONG, glWnd AS LONG

'/* OpenGL globals, defines, and prototypes */
'GLOBAL latitude AS SINGLE', longitude AS SINGLE', gYincr AS SINGLE, gXincr AS SINGLE

TYPE THISCHART
    chartnumber AS LONG
    chartseries AS LONG
    radius      AS SINGLE
    barsize     AS SINGLE
    xoff        AS SINGLE
    yoff        AS SINGLE
    zoff        AS SINGLE
    xrot        AS SINGLE
    yrot        AS SINGLE
    xcpy        AS SINGLE   
    ycpy        AS SINGLE   
    move        AS LONG     
    xdown       AS LONG    
    ydown       AS LONG    
    mouseDown   AS LONG
    listIndex   AS LONG
END TYPE
GLOBAL chart AS THISCHART
GLOBAL quadObj AS LONG
GLOBAL thisChartItem() AS LONG, ChartColor() 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

' We need this to share UseFont among procedures 
SUB GlobalFont(UseFont AS ZGLFONT, BYVAL RW AS LONG)
    STATIC WasFont AS ZGLFONT
    IF RW THEN WasFont = UseFont
    UseFont = WasFont
END SUB

' Perform smooth zoom while they hold down the "zoom" buttons
SUB MessageButton(BYVAL hMain AS LONG, Msg AS tagMsg)
    LOCAL ZoomIs AS LONG, pt AS POINTAPI
    LOCAL rc AS RECT
    STATIC wasLX AS LONG, wasLY AS LONG, LeftMousing AS LONG
    STATIC wasRX AS LONG, wasRY AS LONG, RightMousing AS LONG
    
  ' Detect mouse activity to compute new Image coordinates
    WindowIs& = WindowFromPoint(Msg.pt.X, Msg.pt.Y)
    IF WindowIs& = glWnd THEN
       IF Msg.message = %WM_LBUTTONDOWN THEN
          IF LeftMousing = %FALSE THEN
             pt.x = Msg.pt.X: pt.y = Msg.pt.Y
             CALL ScreenToClient(glWnd, pt)

             chart.xcpy = chart.xrot
             chart.ycpy = chart.yrot
             CALL SetClassLong(glWnd, %GCL_HCURSOR, LoadCursor(0, BYVAL %IDC_SIZEALL))
            
             chart.xdown = pt.x
             chart.ydown = pt.y
             
             LeftMousing = 1
          END IF
       ELSEIF Msg.message = %WM_LBUTTONUP THEN
          LeftMousing = 0
          CALL SetClassLong(glWnd, %GCL_HCURSOR, LoadCursor(0, BYVAL %IDC_ARROW))
       ELSEIF Msg.message = %WM_MOUSEMOVE THEN
        ' Make sure left mouse button is still down, if not bail out.
          IF ZI_IsLButtonDown = 0 THEN
             LeftMousing = 0
             IF RightMousing = 0 THEN CALL SetClassLong(glWnd, %GCL_HCURSOR, LoadCursor(0, BYVAL %IDC_ARROW))
          ELSE
             pt.x = Msg.pt.X: pt.y = Msg.pt.Y
             CALL ScreenToClient(glWnd, pt)
             IF wasLX <> pt.x OR wasLY <> pt.y THEN
                IF LeftMousing THEN
                   CALL GetClientRect(glWnd, rc)
                   dx& = pt.x - chart.xdown: chart.yrot = chart.ycpy + dx& / 2.0
                   dy& = pt.y - chart.ydown: chart.xrot = chart.xcpy + dy& / 2.0
                END IF
             END IF 
             wasLX = pt.x: wasLY = pt.y
             EXIT SUB
          END IF
       END IF

       IF Msg.message = %WM_RBUTTONDOWN THEN
          IF LeftMousing = %FALSE THEN
             pt.x = Msg.pt.X: pt.y = Msg.pt.Y
             CALL ScreenToClient(glWnd, pt)

             chart.xcpy = chart.xoff
             chart.ycpy = chart.yoff
             CALL SetClassLong(glWnd, %GCL_HCURSOR, LoadCursor(0,  BYVAL %IDC_HAND))
            
             chart.xdown = pt.x
             chart.ydown = pt.y
             
             RightMousing = 1
          END IF
       ELSEIF Msg.message = %WM_RBUTTONUP THEN
          RightMousing = 0
          IF LeftMousing = 0 THEN CALL SetClassLong(glWnd, %GCL_HCURSOR, LoadCursor(0, BYVAL %IDC_ARROW))
       ELSEIF Msg.message = %WM_MOUSEMOVE THEN
        ' Make sure left mouse button is still down, if not bail out.
          IF ZI_IsRButtonDown = 0 THEN
             RightMousing = 0
             CALL SetClassLong(glWnd, %GCL_HCURSOR, LoadCursor(0, BYVAL %IDC_ARROW))
          ELSE
             pt.x = Msg.pt.X: pt.y = Msg.pt.Y
             CALL ScreenToClient(glWnd, pt)
             IF wasRX <> pt.x OR wasRY <> pt.y THEN
                IF RightMousing THEN
                   CALL GetClientRect(glWnd, rc)
                   dx& = pt.x - chart.xdown: chart.xoff = chart.xcpy - (-45 * dx&) / (2.0 * rc.nRight)
                   dy& = pt.y - chart.ydown: chart.yoff = chart.ycpy + (-45 * dy&) / (2.0 * rc.nBottom)
                END IF
                EXIT SUB
             END IF 
             wasRX = pt.x: wasRY = pt.y
          END IF
       END IF
       EXIT SUB
    END IF

    SELECT CASE LONG GetFocus
    CASE GetDlgItem(hMain, %ID_ZOOM_IN)
         ZoomIs = ZI_GetGLzoom(glWnd)
         IF ZoomIs > 1 THEN
            CALL ZI_SetGLzoom(glWnd, ZoomIs - 1): CALL ZI_ResizeGLWindow(glWnd)
            CALL apiSleep(20)
         END IF
    CASE GetDlgItem(hMain, %ID_ZOOM_OUT)
         ZoomIs = ZI_GetGLzoom(glWnd)
         IF ZoomIs < 180 THEN
            CALL ZI_SetGLzoom(glWnd, ZoomIs + 1): CALL ZI_ResizeGLWindow(glWnd)
            CALL apiSleep(20)
         END IF   

    CASE GetDlgItem(hMain, %ID_LEFT)
         chart.xoff = chart.xoff - 0.05

    CASE GetDlgItem(hMain, %ID_RIGHT)
         chart.xoff = chart.xoff + 0.05

    CASE GetDlgItem(hMain, %ID_UP)
         chart.yoff = chart.yoff + 0.05

    CASE GetDlgItem(hMain, %ID_DOWN)
         chart.yoff = chart.yoff - 0.05

    END SELECT
END SUB

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 FlagPaint   AS LONG
'
    LOCAL hWinXP_Lib           AS LONG ' Handle to WinXP Theme DLL
    LOCAL hWinXP_IsThemeActive AS LONG ' Handle to WinXP's IsThemeActive function   
'
    DIM UseFont AS ZGLFONT 
'    
    zClass = "ZGLOBE"
'
    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