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

Animated Control

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

  • PBWin Animated Control

    Currently this control contains two spinning images, a rectangle and a pyramid. Working on being able to import STL, bitmap, and composited bitmap files. The bitmap will be converted to a 2-1/2 D voxel image, while the composited bitmap files would just animate.

    Comments, suggestions appreciated.

    The attached .zip file contains source code, exes, and dlls.

    DEMO CODE:
    Code:
    #COMPILE EXE
    DEFLNG I - N
    
    '/================================================================================/'
    '                             SPINCONTROL DLL IMPORTS
    '/================================================================================/'
    DECLARE FUNCTION FN_InitPbSpinCtl LIB "SPINCONTROL" ALIAS "FN_InitPbSpinCtl"_
            (BYVAL Prnt AS DWORD, BYVAL Xpos AS LONG, BYVAL Ypos AS LONG, _
            BYVAL DispImage AS STRING) AS DWORD
    DECLARE FUNCTION FN_ClosePbSpinCtl LIB "SPINCONTROL" ALIAS "FN_ClosePbSpinCtl"() AS LONG
    DECLARE FUNCTION FN_IsPbSpinCtlActive LIB "SPINCONTROL" ALIAS "FN_IsPbSpinCtlActive"() AS LONG
    
    '/================================================================================/'
    '/================================================================================/'
    FUNCTION PBMAIN () AS LONG
    
    LOCAL Ihndl AS DWORD
    
    DIALOG NEW PIXELS, 0, "TEST", , , 640, 480, %WS_OVERLAPPEDWINDOW, %WS_EX_APPWINDOW TO Ihndl
    
    CONTROL ADD BUTTON, Ihndl, 1, "Spinner", 5, 5, 45, 20
    CONTROL ADD BUTTON, Ihndl, 2, "End Spinner", 5, 48, 65, 20
    
    DIALOG SHOW MODAL Ihndl, CALL PbMainDlg_CB
    
    END FUNCTION
    
    '---------------------------------------------------------------------
    '---------------------------------------------------------------------
    
    CALLBACK FUNCTION PbMainDlg_CB()
    
    LOCAL CldHndl AS DWORD
    
    SELECT CASE CBMSG
      CASE %WM_COMMAND
        SELECT CASE CBCTLMSG
          CASE %BN_CLICKED, 1
            SELECT CASE CBCTL
              CASE 1
                CALL FN_InitPbSpinCtl(CBHNDL, 50, 50, "Pyrimid")
                'CALL FN_InitPbSpinCtl(CBHNDL, 50, 50, "Diamond")
              CASE 2
                CALL FN_ClosePbSpinCtl()
            END SELECT
        END SELECT
    END SELECT
    
    END FUNCTION
    
    '---------------------------------------------------------------------
    '---------------------------------------------------------------------
    DLL CODE:
    Code:
    #COMPILE DLL "SPINCONTROL"
    DEFLNG I - N
    
    '/======================================================================================/'
    '                           WINDOWS EQUATES
    '/======================================================================================/'
    '--------- REGISTER WINDOW ----------------'
    %CS_VREDRAW         = &H0001
    %CS_HREDRAW         = &H0002
    %CS_DBLCLKS         = &H0008
    %CS_OWNDC           = &H0020
    %CS_CLASSDC         = &H0040
    %CS_PARENTDC        = &H0080
    %CW_USEDEFAULT      = &H80000000& ' long
    
    '---------------- dll codes -------------------
    %DLL_PROCESS_ATTACH  = 1
    %DLL_THREAD_ATTACH   = 2
    %DLL_THREAD_DETACH   = 3
    %DLL_PROCESS_DETACH  = 0
    
    '------------ STOCK OBJECTS -------------------
    %BLACK_BRUSH         = 4
    %NULL_BRUSH          = 5
    %HOLLOW_BRUSH        = %NULL_BRUSH
    
    '---- Standard Icon IDs -------------------------
    %IDI_APPLICATION    = 32512
    
    '---- Standard Cursor IDs ----
    %IDC_ARROW           = 32512
    
    '--- ternary raster codes ------------------------
    %SRCCOPY             = &H00CC0020 ' dest = source
    
    '--- windows messages ------
    %WM_ERASEBKGND               = &H0014
    %NULL = 0
    
    '----------- Pen styles ------------------
    %PS_SOLID           = 0
    
    '------ PeekMessage() Options -------
    %PM_REMOVE         = &H0001
    
    %MAX_PATH = 260
    
    '/======================================================================================/'
    '                           DLL EQUATES
    '/======================================================================================/'
    
    $NSP = $NUL + $SPC
    '/======================================================================================/'
    '                           WINDOWS STRUCTURES
    '/======================================================================================/'
    TYPE WNDCLASSEXA
        cbSize        AS DWORD
        ' Win 3.x
        STYLE         AS DWORD
        lpfnWndProc   AS DWORD
        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
        ' Win 4.0
        hIconSm       AS DWORD
    END TYPE
    
    TYPE WNDCLASSEXW
        cbSize        AS DWORD
        ' Win 3.x
        STYLE         AS DWORD
        lpfnWndProc   AS DWORD
        cbClsExtra    AS LONG
        cbWndExtra    AS LONG
        hInstance     AS DWORD
        hIcon         AS DWORD
        hCursor       AS DWORD
        hbrBackground AS DWORD
        lpszMenuName  AS WSTRINGZ PTR
        lpszClassName AS WSTRINGZ PTR
        ' Win 4.0
        hIconSm       AS DWORD
    END TYPE
    
    #IF %DEF(%UNICODE)
    TYPE WNDCLASSEX
        WNDCLASSEXW
    END TYPE
    #ELSE
    TYPE WNDCLASSEX
        WNDCLASSEXA
    END TYPE
    #ENDIF ' UNICODE
    
    #IF %DEF(%UNICODE)
    TYPE WNDCLASS
        WNDCLASSEXW
    END TYPE
    #ELSE
    TYPE WNDCLASS
        WNDCLASSEXA
    END TYPE
    #ENDIF ' UNICODE
    
    TYPE MSG_type
        hwnd     AS DWORD
        message  AS DWORD
        wParam   AS DWORD
        lParam   AS LONG
        time     AS DWORD
        pt       AS POINT
      #IF %DEF(%MAC)
        lPrivate AS DWORD
      #ENDIF
    END TYPE
    
    ' [legacy]
    TYPE tagMSG
        MSG_type
    END TYPE
    
    
    '/======================================================================================/'
    '                           DLL STRUCTURES
    '/======================================================================================/'
    TYPE Image_Struct
      TotalPoints       AS DWORD
      TotalFaces        AS DWORD
      PointsPerFace     AS WORD
      AryStart          AS DWORD
      EdgeColor         AS DWORD
      FillColor         AS DWORD
    END TYPE
    
    TYPE SpinCtl_Struct
      DispName          AS STRING * %MAX_PATH
      OwnerHndl         AS DWORD
      BaseHndl          AS DWORD
      ChildHndl         AS DWORD
      ChildId           AS DWORD
      Xpos              AS LONG
      Ypos              AS LONG
      Active            AS WORD
    END TYPE
    
    TYPE Point_Struct
      X                 AS LONG
      Y                 AS LONG
    END TYPE
    
    TYPE Area_Struct
      Point_Struct
      X1                AS LONG
      Y1                AS LONG
    END TYPE
    
    '/======================================================================================/'
    '                           WINDOWS GDI FUNCTIONS
    '/======================================================================================/'
    DECLARE FUNCTION GetStockObject LIB "GDI32.DLL" ALIAS "GetStockObject" _
            (BYVAL nIndex AS LONG) AS DWORD
    DECLARE FUNCTION CreateSolidBrush LIB "GDI32.DLL" ALIAS "CreateSolidBrush" _
            (BYVAL crColor AS DWORD) AS DWORD
    DECLARE FUNCTION DeleteObject LIB "GDI32.DLL" ALIAS "DeleteObject" _
            (BYVAL hObject AS DWORD) AS LONG
    DECLARE FUNCTION BitBlt LIB "GDI32.DLL" ALIAS "BitBlt" (BYVAL hDestDC AS DWORD, _
            BYVAL x AS LONG, BYVAL y AS LONG, BYVAL nWidth AS LONG, BYVAL nHeight AS LONG, _
            BYVAL hSrcDC AS DWORD, BYVAL xSrc AS LONG, BYVAL ySrc AS LONG, _
            BYVAL dwRop AS DWORD) AS LONG
    DECLARE FUNCTION CreateSolidBrush LIB "GDI32.DLL" ALIAS "CreateSolidBrush" _
            (BYVAL crColor AS DWORD) AS DWORD
    DECLARE FUNCTION CreatePen LIB "GDI32.DLL" ALIAS "CreatePen"(BYVAL nPenStyle AS LONG, _
            BYVAL nWidth AS LONG, BYVAL crColor AS DWORD) AS DWORD
    DECLARE FUNCTION SelectObject LIB "GDI32.DLL" ALIAS "SelectObject" (BYVAL hdc AS DWORD, _
            BYVAL hObject AS DWORD) AS DWORD
    DECLARE FUNCTION DeleteObject LIB "GDI32.DLL" ALIAS "DeleteObject" _
            (BYVAL hObject AS DWORD) AS LONG
    DECLARE FUNCTION POLYGON LIB "GDI32.DLL" ALIAS "Polygon" (BYVAL hdc AS DWORD, _
            BYVAL lpPoint AS DWORD, BYVAL nCount AS LONG) AS LONG
    
    '/======================================================================================/'
    '                           WINDOWS USER32 FUNCTIONS
    '/======================================================================================/'
    #IF %DEF(%UNICODE)
      DECLARE FUNCTION GetClassInfoEx LIB "User32.dll" ALIAS "GetClassInfoExW" _
          (BYVAL hInst AS DWORD, BYREF lpszClass AS ANY, lpWndClass AS WNDCLASSEXW) AS LONG
      DECLARE FUNCTION RegisterClassEx LIB "User32.dll" ALIAS "RegisterClassExW" _
          (pcWndClassEx AS WNDCLASSEXW) AS WORD
      DECLARE FUNCTION CreateWindowEx LIB "User32.dll" ALIAS "CreateWindowExW" _
             (BYVAL dwExStyle AS DWORD, lpClassName AS WSTRINGZ, _
              lpWindowName AS WSTRINGZ, 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 "DefWindowProcW" _
              (BYVAL hWnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, _
              BYVAL lParam AS LONG) AS LONG
      DECLARE FUNCTION LoadIcon LIB "User32.dll" ALIAS "LoadIconW" _
              (BYVAL hInstance AS DWORD, lpIconName AS WSTRINGZ) AS DWORD
      DECLARE FUNCTION LoadCursor LIB "User32.dll" ALIAS "LoadCursorW" _
              (BYVAL hInstance AS DWORD, lpCursorName AS WSTRINGZ) AS DWORD
      DECLARE FUNCTION GetModuleHandle LIB "Kernel32.dll" ALIAS "GetModuleHandleW" _
        (lpModuleName AS WSTRINGZ) AS DWORD
      DECLARE FUNCTION PeekMessage LIB "User32.dll" ALIAS "PeekMessageW" _
              (lpMsg AS MSG_type, BYVAL hWnd AS DWORD, BYVAL dwMsgFilterMin AS DWORD, _
              BYVAL dwMsgFilterMax AS DWORD, BYVAL dwRemoveMsg AS DWORD) AS LONG
      DECLARE FUNCTION DispatchMessage LIB "User32.dll" ALIAS "DispatchMessageW" _
              (lpMsg AS MSG_type) AS LONG
    
    #ELSE
      DECLARE FUNCTION GetClassInfoEx LIB "User32.dll" ALIAS "GetClassInfoExA" _
          (BYVAL hInst AS DWORD, BYREF lpszClass AS ANY, lpWndClass AS WNDCLASSEXW) AS LONG
      DECLARE FUNCTION RegisterClassEx LIB "User32.dll" ALIAS "RegisterClassExA" _
          (pcWndClassEx AS WNDCLASSEXA) AS WORD
      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 LoadIcon LIB "User32.dll" ALIAS "LoadIconA" _
              (BYVAL hInstance AS DWORD, lpIconName AS ASCIIZ) AS DWORD
      DECLARE FUNCTION LoadCursor LIB "User32.dll" ALIAS "LoadCursorA" _
              (BYVAL hInstance AS DWORD, lpCursorName AS ASCIIZ) AS DWORD
      DECLARE FUNCTION GetModuleHandle LIB "Kernel32.dll" ALIAS "GetModuleHandleA" _
              (lpModuleName AS ASCIIZ) AS DWORD
      DECLARE FUNCTION PeekMessage LIB "User32.dll" ALIAS "PeekMessageA" _
              (lpMsg AS MSG_type, BYVAL hWnd AS DWORD, BYVAL dwMsgFilterMin AS DWORD, _
              BYVAL dwMsgFilterMax AS DWORD, BYVAL dwRemoveMsg AS DWORD) AS LONG
      DECLARE FUNCTION DispatchMessage LIB "User32.dll" ALIAS "DispatchMessageA" _
              (lpMsg AS MSG_type) AS LONG
    
    #ENDIF
    
    DECLARE FUNCTION ShowWindow LIB "USER32.DLL" ALIAS "ShowWindow" (BYVAL hWnd AS DWORD, _
            BYVAL nCmdShow AS LONG) AS LONG
    DECLARE FUNCTION FillRect LIB "User32.dll" ALIAS "FillRect" (BYVAL hDC AS DWORD, _
            BYVAL lpRect AS DWORD, BYVAL hBrush AS DWORD) AS LONG
    DECLARE FUNCTION GetDC LIB "User32.dll" ALIAS "GetDC" (OPTIONAL BYVAL hWnd AS DWORD) AS DWORD
    DECLARE FUNCTION ReleaseDC LIB "User32.dll" ALIAS "ReleaseDC"(BYVAL hWnd AS DWORD, _
            BYVAL hDC AS DWORD) AS LONG
    DECLARE FUNCTION UpdateWindow LIB "USER32.DLL" ALIAS "UpdateWindow"(BYVAL hWnd AS DWORD) AS LONG
    DECLARE FUNCTION InvalidateRect LIB "USER32.DLL" ALIAS "InvalidateRect" (BYVAL hWnd AS DWORD, _
            BYVAL lpRect AS DWORD, BYVAL bErase AS LONG) AS LONG
    DECLARE FUNCTION GetClientRect LIB "User32.dll" ALIAS "GetClientRect"(BYVAL hwnd AS DWORD, _
            BYVAL lpRect AS DWORD) AS LONG
    DECLARE FUNCTION DestroyWindow LIB "User32.dll" ALIAS "DestroyWindow" _
            (BYVAL hWnd AS DWORD) AS LONG
    DECLARE FUNCTION ClientToScreen LIB "User32.dll" ALIAS "ClientToScreen"(BYVAL hWnd AS DWORD, _
            BYVAL lpPoint AS DWORD) AS LONG
    DECLARE FUNCTION GetWindowRect LIB "User32.dll" ALIAS "GetWindowRect"(BYVAL hWnd AS DWORD, _
            BYVAL lpRect AS DWORD) AS LONG
    DECLARE FUNCTION TranslateMessage LIB "User32.dll" ALIAS "TranslateMessage" _
            (lpMsg AS MSG_type) AS LONG
    
    '/======================================================================================/'
    '                           TRIGMATH DLL IMPORT FUNCTIONS
    '/======================================================================================/'
    
    DECLARE SUB Rot_X LIB "TRIGMATH" ALIAS "Rot_X"(BYVAL Angle AS SINGLE, AryIn() AS SINGLE, _
            AryOut() AS SINGLE)
    DECLARE SUB Rot_Y LIB "TRIGMATH" ALIAS "Rot_Y"(BYVAL Angle AS SINGLE, AryIn() AS SINGLE, _
            AryOut() AS SINGLE)
    DECLARE SUB Rot_Z LIB "TRIGMATH" ALIAS "Rot_Z"(BYVAL Angle AS SINGLE, AryIn() AS SINGLE, _
            AryOut() AS SINGLE)
    DECLARE SUB FindImageCenters LIB "TRIGMATH" ALIAS "FindImageCenters"(AryIn() AS SINGLE, _
            Cx AS SINGLE, Cy AS SINGLE, Cz AS SINGLE)
    
    '/======================================================================================/'
    '                           DLL FUNCTIONS
    '/======================================================================================/'
    DECLARE FUNCTION FN_InitClass ALIAS "Fn_InitClass"(BYVAL ClassStyle AS DWORD, _
            BYVAL CallBackPtr AS DWORD, BYVAL ClsExtra AS DWORD, BYVAL WndExtra AS DWORD, _
            BYVAL AppInst AS DWORD, BYVAL BkgColor AS LONG, _
            BYVAL ClassNamePtr AS STRING) EXPORT AS LONG
    DECLARE FUNCTION FN_InitWindow ALIAS "FN_InitWindow"(BYVAL ExtraStyle AS DWORD, _
            WinClass AS STRING, WinTitle AS STRING, BYVAL DefStyle AS DWORD, BYVAL Xpos AS LONG, _
            BYVAL Ypos AS LONG, BYVAL CtlWide AS LONG, BYVAL CtlHigh AS LONG, _
            BYVAL Owner AS DWORD, BYVAL CtlId AS DWORD, BYVAL AppInst AS DWORD) EXPORT AS LONG
    DECLARE FUNCTION FN_InitPbSpinCtl ALIAS "FN_InitPbSpinCtl"(BYVAL Prnt AS DWORD, _
            BYVAL Xpos AS LONG, BYVAL Ypos AS LONG, _
            BYVAL DispImage AS STRING) THREADSAFE EXPORT AS DWORD
    DECLARE FUNCTION FN_ClosePbSpinCtl ALIAS "FN_ClosePbSpinCtl"() EXPORT AS LONG
    DECLARE FUNCTION FN_IsPbSpinCtlActive ALIAS "FN_IsPbSpinCtlActive"() EXPORT AS LONG
    DECLARE FUNCTION FN_ClosePbSpinCtl ALIAS "FN_ClosePbSpinCtl"() EXPORT AS LONG
    DECLARE FUNCTION FN_DoEvents ALIAS "FN_DoEvents"() EXPORT AS LONG
    DECLARE FUNCTION FN_TrimSpc(BYVAL TxtStr AS STRING) AS STRING
    DECLARE FUNCTION SpinCtl_Cb(BYVAL WinHndl AS DWORD, BYVAL Msg AS LONG, BYVAL wParam AS LONG, _
            BYVAL lParam AS LONG) AS LONG
    DECLARE THREAD FUNCTION Fn_PbSpinCtrlThread(BYVAL Hdr AS DWORD)
    
    '/======================================================================================/'
    '                           DLL SUBS
    '/======================================================================================/'
    
    DECLARE SUB Diamond(AryIn() AS SINGLE, tImage() AS Image_Struct, Axis AS WORD)
    DECLARE SUB Pyrimid(AryIn() AS SINGLE, tImage() AS Image_Struct, Axis AS WORD)
    
    
    
    '/======================================================================================/'
    '                           DLL GLOBALS
    '/======================================================================================/'
    GLOBAL tSpnr AS SpinCtl_Struct
    
    '/======================================================================================/'
    '/======================================================================================/'
    FUNCTION LIBMAIN (BYVAL hInstance   AS LONG, _
                      BYVAL fwdReason   AS LONG, _
                      BYVAL lpvReserved AS LONG) AS LONG
    
        SELECT CASE fwdReason
    
        CASE %DLL_PROCESS_ATTACH
            'Indicates that the DLL is being loaded by another process (a DLL
            'or EXE is loading the DLL).  DLLs can use this opportunity to
            'initialize any instance or global data, such as arrays.
    
            'ghInstance = hInstance
    
            FUNCTION = 1   'success!
    
            'FUNCTION = 0   'failure!  This will prevent the EXE from running.
    
        CASE %DLL_PROCESS_DETACH
            'Indicates that the DLL is being unloaded or detached from the
            'calling application.  DLLs can take this opportunity to clean
            'up all resources for all threads attached and known to the DLL.
    
            FUNCTION = 1   'success!
    
            'FUNCTION = 0   'failure!
    
        CASE %DLL_THREAD_ATTACH
            'Indicates that the DLL is being loaded by a new thread in the
            'calling application.  DLLs can use this opportunity to
            'initialize any thread local storage (TLS).
    
            FUNCTION = 1   'success!
    
            'FUNCTION = 0   'failure!
    
        CASE %DLL_THREAD_DETACH
            'Indicates that the thread is exiting cleanly.  If the DLL has
            'allocated any thread local storage, it should be released.
    
            FUNCTION = 1   'success!
    
            'FUNCTION = 0   'failure!
    
        END SELECT
    
    END FUNCTION
    
    '------------------------------------------------------------------------------
    '------------------------------------------------------------------------------
    
    FUNCTION FN_InitClass ALIAS "Fn_InitClass"(BYVAL ClassStyle AS DWORD, _
             BYVAL CallBackPtr AS DWORD, BYVAL ClsExtra AS DWORD, BYVAL WndExtra AS DWORD, _
             BYVAL AppInst AS DWORD, BYVAL BkgColor AS LONG, _
             BYVAL ClassNamePtr AS STRING) EXPORT AS LONG
    
    LOCAL BrushHndl, _
               Init     AS LONG
    
    LOCAL WinClassz     AS ASCIIZ * 80
    
    LOCAL tClass        AS WNDCLASSEX
    
    WinClassz$ = ClassNamePtr$
    
    tClass.cbSize = SIZEOF(WNDCLASSEX)
    
    Init = GetClassInfoEx(AppInst, WinClassz$, tClass)
    
    IF Init THEN
      FN_InitClass = -Init
      EXIT FUNCTION
    END IF
    
    IF BkgColor = 0 THEN
      BrushHndl = getstockobject(%BLACK_BRUSH)
    ELSEIF BkgColor < 0 THEN
      BrushHndl = getstockobject(%HOLLOW_BRUSH)
    ELSE
      BrushHndl = createsolidbrush(BkgColor)
    END IF
    
    tClass.STYLE         = ClassStyle
    tClass.lpfnWndProc   = CallBackPtr
    tClass.cbClsExtra    = ClsExtra
    tClass.cbWndExtra    = WndExtra
    tClass.hInstance     = AppInst
    tClass.hIcon         = LoadIcon(AppInst, BYVAL %IDI_APPLICATION)
    tClass.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
    tClass.hbrBackground = BrushHndl
    tClass.lpszMenuName  = 0
    tClass.lpszClassName = VARPTR(WinClassz$)
    tClass.hIconSm       = LoadIcon(AppInst, BYVAL %IDI_APPLICATION)
    
    FN_InitClass = RegisterClassEx(tClass)
    END FUNCTION
    
    '------------------------------------------------------------------------------
    '------------------------------------------------------------------------------
    
    FUNCTION FN_InitWindow ALIAS "FN_InitWindow"(BYVAL ExtraStyle AS DWORD, WinClass AS STRING, _
             WinTitle AS STRING, BYVAL DefStyle AS DWORD, BYVAL Xpos AS LONG, BYVAL Ypos AS LONG, _
             BYVAL CtlWide AS LONG, BYVAL CtlHigh AS LONG, BYVAL Owner AS DWORD, _
             BYVAL CtlId AS DWORD, BYVAL AppInst AS DWORD) EXPORT AS LONG
    
    LOCAL WinHndl       AS DWORD
    
    LOCAL WinClassz, _
          WinTitlez     AS ASCIIZ * 80
    
    WinClassz$ = WinClass$
    WinTitlez$ = WinTitle$
    
    WinHndl =  CreateWindowEx(ExtraStyle, _        'Extended style
                              WinClassz$, _        'windows class name
                              WinTitlez$, _        'title of window
                                DefStyle, _        'window style
                                    Xpos, _        'X position on monitor
                                    Ypos, _        'Y position on monitor
                                 Ctlwide, _        'width of window
                                 Ctlhigh, _        'hight of window
                                   Owner, _        'window parent or owner
                                   CtlId, _        'menu ID in resource or control ID
                                 AppInst, _        'window instance or app instance
                                BYVAL 0)          'extra info
    
    FN_InitWindow = WinHndl
    END FUNCTION
    
    '------------------------------------------------------------------------------
    '------------------------------------------------------------------------------
    
    FUNCTION SpinCtl_Cb(BYVAL WinHndl AS DWORD, BYVAL Msg AS LONG, BYVAL wParam AS LONG, _
                      BYVAL lParam AS LONG) AS LONG
    
    LOCAL WinDc AS DWORD
    LOCAL Brush AS DWORD
    LOCAL tRect AS Area_Struct
    
    SELECT CASE MSG
      CASE %WM_CREATE
    
      CASE %WM_ERASEBKGND
    END SELECT
    
    FUNCTION = defwindowproc(WinHndl, Msg, wParam, lParam)
    
    END FUNCTION
    
    '---------------------------------------------------------------------
    '---------------------------------------------------------------------
    
    FUNCTION FN_InitPbSpinCtl ALIAS "FN_InitPbSpinCtl"(BYVAL Prnt AS DWORD, BYVAL Xpos AS LONG, _
             BYVAL Ypos AS LONG, BYVAL DispImage AS STRING) EXPORT AS DWORD
    
    IF tSpnr.Active THEN EXIT FUNCTION
    
    LOCAL ThrdHndl, _
          CtlStyle, _
             GfxId, _
              Init, _
              Inst    AS DWORD
    
    LOCAL tPnt        AS Point_Struct
    LOCAL tClient     AS Area_Struct
    
    GfxId = 100
    
    tSpnr.OwnerHndl = Prnt
    
    getclientrect(Prnt, VARPTR(tClient))
    tPnt.X = tClient.X
    tPnt.Y = tClient.Y
    
    clienttoscreen(Prnt, VARPTR(tPnt))
    
    tPnt.X = tPnt.X + Xpos
    tPnt.Y = tPnt.Y + Ypos
    
    Inst = EXE.INST
    
    Init = FN_InitClass(%CS_HREDRAW OR %CS_VREDRAW OR %CS_OWNDC OR %CS_GLOBALCLASS, _
                                            CODEPTR(SpinCtl_CB), _
                                                              4, _
                                                              4, _
                                                           Inst, _
                                                             -1, _
                                                   "SPIN_BASE")
    
    Init = FN_InitClass(%CS_HREDRAW OR %CS_VREDRAW OR %CS_OWNDC OR %CS_GLOBALCLASS, _
                                            CODEPTR(SpinCtl_CB), _
                                                              4, _
                                                              4, _
                                                           Inst, _
                                                             -1, _ %RGB_ORANGERED
                                                   "SPIN_CTRL")
    
    CtlStyle = %WS_POPUP OR %WS_VISIBLE OR %WS_CLIPCHILDREN' or %ws_caption
    
    tSpnr.BaseHndl = FN_InitWindow(0, _ or %ws_ex_transparent, _
                                      "SPIN_BASE", _
                                           "SPIN", _
                                         CtlStyle, _
                                           tPnt.X, _
                                           tPnt.Y, _
                                               64, _
                                               64, _
                                             Prnt, _
                                                0, _
                                             Inst)
    
    CtlStyle = %WS_CHILD OR %WS_CLIPCHILDREN OR %WS_CLIPSIBLINGS OR %DS_CONTROL OR _
                 %DS_NOFAILCREATE OR %SS_OWNERDRAW OR %SS_NOTIFY OR %WS_VISIBLE' OR %WS_BORDER
                                                                          '%WS_EX_TRANSPARENT
    tSpnr.ChildHndl = FN_InitWindow(%WS_EX_TRANSPARENT, _
                        "SPIN_CTRL", _
                          "SPINNER", _
                           CtlStyle, _
                                  0, _
                                  0, _
                                 64, _
                                 64, _
                     tSpnr.BaseHndl, _
                              GfxId, _
                               Inst)
    
    showwindow(tSpnr.BaseHndl, %SW_SHOW)
    showwindow(tSpnr.ChildHndl, %SW_SHOW)
    
    UpdateWindow(tSpnr.BaseHndl)
    UpdateWindow(tSpnr.ChildHndl)
    
    tSpnr.DispName = DispImage$
    tSpnr.Xpos = Xpos
    tSpnr.Ypos = Ypos
    
    tSpnr.ChildId   = GfxId
    tSpnr.Active = 1
    
    THREAD CREATE Fn_PbSpinCtrlThread(VARPTR(tSpnr)) TO ThrdHndl
    
    FN_InitPbSpinCtl = ThrdHndl
    END FUNCTION
    
    '---------------------------------------------------------------------
    '---------------------------------------------------------------------
    
    THREAD FUNCTION Fn_PbSpinCtrlThread(BYVAL Hdr AS DWORD)
    
    REGISTER I        AS LONG
    REGISTER J        AS LONG
    
    LOCAL Axis          AS WORD
    
    LOCAL OwnerHndl, _
            OwnerDc, _
           BaseHndl, _
          ChildHndl, _
            ChildDc, _
            ChildId, _
             WinBmp, _
              WinDc, _
             MrgBmp, _
              MrgDc, _
            PenHndl, _
           BrshHndl, _
             PrvPen, _
           PrvBrush     AS DWORD
    
    LOCAL Colour, _
            Xpos, _
            Ypos, _
         EdgeClr, _
         FillClr, _
         NumPnts, _
            LstX, _
            LstY, _
          Kstart, _
            Kend, _
               K, _
               L, _
               M        AS LONG
    
    LOCAL Cx, _
          Cy, _
          Cz            AS SINGLE
    
    LOCAL AryOut(), _
          AryIn(), _
          TmpAry()      AS SINGLE
    
    LOCAL WinStr, _
           Merge        AS STRING
    
    LOCAL tPoly()       AS Point_Struct
    
    LOCAL tUpDRect, _
          tWinRect      AS Area_Struct
    
    LOCAL tImg()        AS Image_Struct
    
    LOCAL HdrPtr        AS SpinCtl_Struct POINTER
    
    LOCAL MrgPtr, _
          WinPtr      AS DWORD POINTER
    
    HdrPtr = Hdr
    
    OwnerHndl  = @HdrPtr.OwnerHndl
    BaseHndl   = @HdrPtr.BaseHndl
    ChildHndl  = @HdrPtr.ChildHndl
    ChildId    = @HdrPtr.ChildId
    Xpos       = @HdrPtr.Xpos
    Ypos       = @HdrPtr.Ypos
    WinStr$    = FN_TrimSpc(@HdrPtr.DispName)
    
    OwnerDc = getdc(0) '(OwnerHndl)
    ChildDc = getdc(ChildHndl)
    
    getwindowrect(OwnerHndl, VARPTR(tWinRect))
    
    LstX = tWinRect.X
    LstY = tWinRect.Y
    
    DIM AryIn(1 TO 1, 1 TO 4)
    DIM AryOut(1 TO 1, 1 TO 4)
    DIM TmpAry(1 TO 1, 1 TO 4)
    
    SELECT CASE UCASE$(WinStr$)
      CASE "DIAMOND"
        CALL Diamond(AryIn!(), tImg(), Axis)
      CASE "PYRIMID"
        CALL Pyrimid(AryIn!(), tImg(), Axis)
    END SELECT
    
    NumPnts = tImg(1).TotalPoints
    
    CALL FindImageCenters(AryIn!(), Cx!, Cy!, Cz!)
    
    REDIM TmpAry!(1 TO NumPnts, 1 TO 4)
    
    FOR I = 1 TO NumPnts
      AryIn!(I, 1) = AryIn!(I, 1) - Cx!
      AryIn!(I, 2) = AryIn!(I, 2) - Cy!
      AryIn!(I, 3) = AryIn!(I, 3) - Cz!
    NEXT I
    MAT TmpAry!() = AryIn!()
    
    Colour = %BLACK
    
    GRAPHIC BITMAP NEW 64, 64 TO WinBmp
    GRAPHIC ATTACH WinBmp, 0
    GRAPHIC GET DC TO WinDc
    
    getwindowrect(BaseHndl, VARPTR(tUpDrect))
    
    showwindow(BaseHndl, %SW_HIDE)
    
    bitblt(WinDc, 0, 0, 64, 64, OwnerDc, tUpDrect.X, tUpDrect.Y, %SRCCOPY)
    SLEEP 1
    
    GRAPHIC GET BITS TO WinStr$
    
    showwindow(BaseHndl, %SW_SHOW)
    bitblt(ChildDc, 0, 0, 64, 64, WinDc, 0, 0, %SRCCOPY)
    
    GRAPHIC BITMAP NEW 64, 64 TO MrgBmp
    GRAPHIC ATTACH MrgBmp, 0
    GRAPHIC GET DC TO MrgDc
    
    
    DO
      FN_DoEvents()
    
      IF (ISWIN(BaseHndl) = 0) OR (@HdrPtr.Active = 0) THEN EXIT DO
    
      GRAPHIC ATTACH MrgBmp, 0
    
      FOR I = 0 TO 180
        FN_DoEvents()
        IF (ISWIN(BaseHndl) = 0) OR (@HdrPtr.Active = 0) THEN EXIT DO
    
        IF BIT(Axis, 0) = 1 THEN
          IF (BIT(Axis, 1) = 1) AND (BIT(Axis, 2) = 1) THEN
            CALL Rot_X(I, AryIn!(), AryOut!())
            CALL Rot_Y(I, AryOut!(), AryIn!())
            CALL Rot_Z(I, AryIn!(), AryOut!())
          ELSEIF (BIT(Axis, 1) = 1) AND (BIT(Axis, 2) = 0) THEN
            CALL Rot_X(I, AryIn!(), AryOut!())
            CALL Rot_Y(I, AryOut!(), AryIn!())
            MAT AryOut!() = AryIn!()
          ELSEIF (BIT(Axis, 1) = 0) AND (BIT(Axis, 2) = 1) THEN
            CALL Rot_X(I, AryIn!(), AryOut!())
            CALL Rot_Z(I, AryOut!(), AryIn!())
            MAT AryOut!() = AryIn!()
          ELSE
            CALL Rot_X(I, AryIn!(), AryOut!())
          END IF
        ELSEIF BIT(Axis, 0) = 0 THEN
          IF (BIT(Axis, 1) = 1) AND (BIT(Axis, 2) = 1) THEN
            CALL Rot_Y(I, AryIn!(), AryOut!())
            CALL Rot_Z(I, AryOut!(), AryIn!())
            MAT AryOut!() = AryIn!()
          ELSEIF (BIT(Axis, 1) = 0) AND (BIT(Axis, 2) = 1) THEN
            CALL Rot_Z(I, AryIn!(), AryOut!())
          ELSEIF (BIT(Axis, 1) = 1) AND (BIT(Axis, 2) = 0) THEN
            CALL Rot_Y(I, AryIn!(), AryOut!())
          END IF
        END IF
    
        MAT AryIn!() = TmpAry!()
    
        Kstart = 0
        Kend   = 0
        FOR M = 1 TO UBOUND(tImg)
          Kstart = tImg(M).AryStart
          Kend = Kstart + tImg(M).PointsPerFace - 1
          NumPnts = tImg(M).PointsPerFace
          REDIM tPoly(1 TO NumPnts)
          K = 0
          FOR L = Kstart TO Kend
            K = K + 1
            tPoly(K).X = AryOut!(L, 1) + Cx!
            tPoly(K).Y = AryOut!(L, 2) + Cy!
          NEXT L
    
          PenHndl = createpen(%PS_SOLID, 1, tImg(M).EdgeColor)
          BrshHndl = createsolidbrush(tImg(M).FillColor)
          PrvPen   = selectobject(MrgDc, PenHndl)
          PrvBrush = selectobject(MrgDc, BrshHndl)
    
          POLYGON(MrgDc, VARPTR(tPoly(1)), NumPnts)
    
          selectobject(MrgDc, PrvPen)
          selectobject(MrgDc, PrvBrush)
          deleteobject(PenHndl)
          deleteobject(BrshHndl)
    
        NEXT M
    
        GRAPHIC GET BITS TO Merge$
    
        MrgPtr = STRPTR(Merge$) + 8
        WinPtr = STRPTR(WinStr$) + 8
    
        FOR J = 1 TO 64 * 64
          IF @MrgPtr = Colour THEN @MrgPtr = @WinPtr
          MrgPtr = MrgPtr + 4
          WinPtr = WinPtr + 4
        NEXT J
    
        GRAPHIC SET BITS Merge$
        bitblt(ChildDc, 0, 0, 64, 64, MrgDc, 0, 0, %SRCCOPY)
        GRAPHIC CLEAR 0
    
        IF I MOD 15 = 0 THEN
          getwindowrect(OwnerHndl, VARPTR(tWinRect))
    
          IF (tWinRect.X = LstX) AND (tWinRect.Y = LstY) THEN ITERATE FOR
    
          LstX = tWinRect.X
          LstY = tWinRect.Y
    
          GRAPHIC ATTACH WinBmp, 0
          GRAPHIC CLEAR 0
          getwindowrect(BaseHndl, VARPTR(tUpDrect))
          showwindow(BaseHndl, %SW_HIDE)
          bitblt(WinDc, 0, 0, 64, 64, OwnerDc, tUpDrect.X, tUpDrect.Y, %SRCCOPY)
          showwindow(BaseHndl, %SW_SHOW)
          GRAPHIC GET BITS TO WinStr$
          GRAPHIC DETACH
          GRAPHIC ATTACH MrgBmp, 0
          DIALOG REDRAW OwnerHndl
          FN_DoEvents()
          ITERATE FOR
        END IF
        SLEEP 5
      NEXT I
    LOOP
    
    selectobject(MrgDc, PrvPen)
    selectobject(MrgDc, PrvBrush)
    deleteobject(PenHndl)
    deleteobject(BrshHndl)
    
    GRAPHIC ATTACH WinBmp, 0
    GRAPHIC BITMAP END
    GRAPHIC ATTACH MrgBmp, 0
    GRAPHIC BITMAP END
    '
    END FUNCTION
    
    '---------------------------------------------------------------------
    '---------------------------------------------------------------------
    
    FUNCTION FN_ClosePbSpinCtl ALIAS "FN_ClosePbSpinCtl"() EXPORT AS LONG
      IF tSpnr.Active THEN
        destroywindow(tSpnr.BaseHndl)
        RESET tSpnr.Active
      END IF
    END FUNCTION
    
    '---------------------------------------------------------------------
    '---------------------------------------------------------------------
    
    FUNCTION FN_IsPbSpinCtlActive ALIAS "FN_IsPbSpinCtlActive"() EXPORT AS LONG
    
    FN_IsPbSpinCtlActive = tSpnr.Active
    END FUNCTION
    
    '---------------------------------------------------------------------
    '---------------------------------------------------------------------
    
    FUNCTION FN_TrimSpc(BYVAL TxtStr AS STRING) AS STRING
    
    LOCAL TmpStr  AS STRING
    
    TmpStr$ = RTRIM$(TxtStr$, ANY $NSP)
    
    FN_TrimSpc = TmpStr$
    END FUNCTION
    
    '---------------------------------------------------------------------
    '---------------------------------------------------------------------
    
    SUB Diamond(AryIn() AS SINGLE, tImage() AS Image_Struct, Axis AS WORD)
    
    REDIM AryIn!(1 TO 4, 1 TO 4)
    
    AryIn!(1, 1) = 32
    AryIn!(1, 2) = 0
    AryIn!(1, 3) = 0
    
    AryIn!(2, 1) = 64
    AryIn!(2, 2) = 32
    AryIn!(2, 3) = 0
    
    AryIn!(3, 1) = 32
    AryIn!(3, 2) = 64
    AryIn!(3, 3) = 0
    
    AryIn!(4, 1) = 0
    AryIn!(4, 2) = 32
    AryIn!(4, 3) = 0
    
    
    REDIM tImage(1 TO 1)
    
    tImage(1).TotalPoints = 4
    tImage(1).TotalFaces  = 1
    tImage(1).PointsPerFace = 4
    tImage(1).AryStart = 1
    tImage(1).EdgeColor = %GREEN
    tImage(1).FillColor = %YELLOW
    
    BIT SET Axis, 0
    BIT SET Axis, 1
    BIT SET Axis, 2
    END SUB
    
    '---------------------------------------------------------------------
    '---------------------------------------------------------------------
    
    SUB Pyrimid(AryIn() AS SINGLE, tImage() AS Image_Struct, Axis AS WORD)
    
    REDIM AryIn!(1 TO 16, 1 TO 4)
    'base
    AryIn!(1, 1) = 32
    AryIn!(1, 2) =  0
    AryIn!(1, 3) =  0
    
    AryIn!(2, 1) = 64
    AryIn!(2, 2) = 32
    AryIn!(2, 3) =  0
    
    AryIn!(3, 1) = 32
    AryIn!(3, 2) = 64
    AryIn!(3, 3) =  0
    
    AryIn!(4, 1) =  0
    AryIn!(4, 2) = 32
    AryIn!(4, 3) =  0
    
    'face 1
    AryIn!(5, 1) = 32
    AryIn!(5, 2) = 32
    AryIn!(5, 3) = 32
    
    AryIn!(6, 1) = 32
    AryIn!(6, 2) =  0
    AryIn!(6, 3) =  0
    
    AryIn!(7, 1) = 64
    AryIn!(7, 2) = 32
    AryIn!(7, 3) =  0
    
    'face 2
    AryIn!(8, 1) = 32
    AryIn!(8, 2) = 32
    AryIn!(8, 3) = 32
    
    AryIn!(9, 1) = 64
    AryIn!(9, 2) = 32
    AryIn!(9, 3) =  0
    
    AryIn!(10, 1) = 32
    AryIn!(10, 2) = 64
    AryIn!(10, 3) =  0
    
    'face 3
    AryIn!(11, 1) = 32
    AryIn!(11, 2) = 32
    AryIn!(11, 3) = 32
    
    AryIn!(12, 1) = 32
    AryIn!(12, 2) = 64
    AryIn!(12, 3) =  0
    
    AryIn!(13, 1) =  0
    AryIn!(13, 2) =  32
    AryIn!(13, 3) =  0
    
    'face 4
    AryIn!(14, 1) = 32
    AryIn!(14, 2) = 32
    AryIn!(14, 3) = 32
    
    AryIn!(15, 1) =  0
    AryIn!(15, 2) = 32
    AryIn!(15, 3) =  0
    
    AryIn!(16, 1) = 32
    AryIn!(16, 2) =  0
    AryIn!(16, 3) =  0
    
    REDIM tImage(1 TO 5)
    
    tImage(1).TotalPoints = 16
    tImage(1).TotalFaces  = 5
    tImage(1).PointsPerFace = 4
    tImage(1).AryStart = 1
    tImage(1).EdgeColor = %RGB_DARKRED
    tImage(1).FillColor = %RGB_LIGHTCORAL
    
    RANDOMIZE TIMER
    
    FOR I = 2 TO 5
      tImage(I).PointsPerFace = 3
      tImage(I).AryStart = tImage(I - 1).AryStart + tImage(I - 1).PointsPerFace
      tImage(I).EdgeColor = %RGB_DARKRED
      tImage(I).FillColor = RND(MIN(%RGB_RED, %RGB_LIGHTCORAL), MAX(%RGB_RED, %RGB_LIGHTCORAL))
    NEXT I
    
    BIT SET Axis, 0
    BIT SET Axis, 2
    END SUB
    
    '---------------------------------------------------------------------
    '---------------------------------------------------------------------
    
    FUNCTION FN_DoEvents ALIAS "FN_DoEvents"() EXPORT AS LONG
    
    LOCAL tMsg AS TAGMSG
    
    peekmessage(tMsg, 0, 0, 0, %PM_REMOVE)
    
    translatemessage(tMsg)
    dispatchmessage(tMsg)
    
    END FUNCTION
    SPINNER.ZIP


    Attached Files
    Walt Decker

  • #2
    Here's an update. The zip contains all necessary files. Note that a rather plain bitmap renders better in voxel mode than a complicated one.

    SPINNER.ZIP
    Walt Decker

    Comment

    Working...
    X