win32forth-cvs

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src/lib
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv7404

Added Files:
	ADO.f AXControl.F FlashControl.F HTMLcontrol.F 
	HtmlDisplayControl.f HtmlDisplayWindow.f PDFControl.F 
Log Message:
Jos: Tom Dixon's COM-libs.

--- NEW FILE: HtmlDisplayControl.f ---
\    File: HtmlDisplayControl.f
\
\  Author: Dirk Busch (dbu)
\   Email: dir...@wi...
\
\ Created: Samstag, Juli 24 2004 - dbu
\ Updated: Samstag, Juli 31 2004 - dbu
\
\ Display HTML pages in a Window.

cr .( Loading Html Display Control...)

anew -HtmlDisplayControl.f

needs HtmlControl.f

INTERNAL
EXTERNAL

\ --------------------------------------------------------------------------------
\ HtmlDisplayControl class
\ --------------------------------------------------------------------------------

:class HtmlDisplayControl  <super HTMLControl DEPRECATED
\ *G This class was completly replaced by the HTMLControl class. \n
\ ** So use the HTMLControl instead.

;Class

: InitHtmlControl ( -- ) \ Init the Html Control, must be called once at startup
        ; DEPRECATED

: ExitHtmlControl ( -- ) \ Deinit the Html Control, must be called once at exit
        ; DEPRECATED

MODULE

--- NEW FILE: HTMLcontrol.F ---
\ $Id: HTMLcontrol.F,v 1.1 2007/05/16 20:29:06 jos_ven Exp $

\ HTML Control
\ Thomas Dixon

\ *D doc\classes\
\ *! HTMLcontrol
\ *T HTMLcontrol -- HTML control
\ *P This class is using the MSHTML ActiveX control
\ ** so you must install the MS Internet Explorer to use it.
\ *S Glossary

anew -HtmlControl.f

needs AXControl

\ Load MSHTML TypeLibrary
1 1 typelib {EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}

\ We Build off the Generic ActiveX Control
:CLASS HTMLControl           <SUPER AXControl
\ *G HTML control class.

  CELL bytes Web        \ pointer to IWebBrowser2 interface
  16 bytes xtra         \ xtra space for api calls

:M Start: ( Parent -- )
\ *G Start the control
        Start: super
        xtra WebBrowser call StringFromCLSID abort" Unable to Get WebBrowser CLSID!"
        xtra @ AXUCreate: self
        Web IWebBrowser2 QueryInterface: self
          abort" Unable to get the IWebBrowser2 Interface!"
        ;M

:M On_Done: ( -- )
        Web @ if
          Web COM IWebBrowser2 Release drop 0 Web ! then ;M

\ Browser Methods
:M GetLocationURL:      ( -- str len )
\ *G Retrieves the URL of the resource that the browser is currently displaying.
        xtra Web COM IWebBrowser2 GetLocationURL drop
        xtra @ dup >r zunicount >ascii r> call SysFreeString drop ;M

:M GetLocationName:     ( -- str len )
\ *G Retrieves the name of the resource that the browser is currently displaying.
        xtra Web COM IWebBrowser2 GetLocationName drop
        xtra @ dup >r zunicount >ascii r> call SysFreeString drop ;M

:M GetType:     ( -- str len )
\ *G Retrieves the type name of the contained document object.
        xtra Web COM IWebBrowser2 GetType drop
        xtra @ dup >r zunicount >ascii r> call SysFreeString drop ;M

:M Busy?:       ( -- flag )
\ *G Retrieves a boolean value that indicates whether the browser is engaged in a
\ ** downloading operation or other activity.
        xtra Web COM IWebBrowser2 GetBusy drop xtra @ 1 and ;M

:M Offline?:    ( -- flag )
\ *G Retrieves a Boolean value indicating whether the browser is currently operating
\ ** in offline mode.
        xtra Web COM IWebBrowser2 GetOffline drop xtra @ 1 and ;M

\ Navigation Functions

:M GoURL:       ( str len -- )
\ *G Navigates to a resource identified by a Uniform Resource
\ ** Locator (URL) or to the file identified by a full path.
        >unicode drop >r
        0 0 0 0 r> Web COM IWebBrowser2 Navigate drop ;M

:M SetURL:      ( zUrl -- )
\ *G Navigates to a resource identified by a Uniform Resource
\ ** Locator (URL) or to the file identified by a full path.
                zcount GoURL: self ;M

:M GoHome:      ( -- )
\ *G Navigates to the current home or start page.
        Web COM IWebBrowser2 GoHome drop ;M

:M GoSearch:    ( -- )
\ *G Navigates to the current search page.
        Web COM IWebBrowser2 GoSearch drop ;M

:M GoForward:   ( -- )
\ *G Navigates forward one item in the history list.
        Web COM IWebBrowser2 GoForward drop ;M

:M GoBack:      ( -- )
\ *G Navigates backward one item in the history list.
        Web COM IWebBrowser2 GoBack drop ;M

:M Refresh:     ( -- )
\ *G Reloads the file that the browser is currently displaying.
        Web COM IWebBrowser2 Refresh drop ;M

:M Stop:        ( -- )
\ *G Cancels any pending navigation or download operation and
\ ** stops any dynamic page elements, such as background sounds
\ ** and animations.
        Web COM IWebBrowser2 Stop drop ;M

;CLASS
\ *G End of HTML control class

\ We don't need the typelibrary anymore, so unload it now.
free-lasttypelib

\ *Z

--- NEW FILE: HtmlDisplayWindow.f ---
\    File: HtmlDisplayWindow.f
\
\  Author: Dirk Busch (dbu)
\   Email: dir...@wi...
\
\ Created: Samstag, Dezember 04 2004 - dbu
\ Updated: Samstag, Dezember 04 2004 - dbu
\
\ Display HTML pages in a Window.

cr .( Loading Html Display Window...)

anew -HtmlDisplayWindow.f

needs HtmlControl.f
needs SendMessage.f
needs Bitmap.f
needs Toolbar.f
needs RebarControl.f

INTERNAL

\ --------------------------------------------------------------------------------
\ Toolbar for the HtmlDisplayWindow
\ --------------------------------------------------------------------------------

load-bitmap HtmlDisplayBitmaps "apps\sciedit\res\toolbar.bmp"

\ Define tool tips (texts that gives a short description of the buttons function)
\ These correspond to bitmap images in the loaded bitmap
:ToolStrings HtmlDisplayToolTips
        ts," Back"
        ts," Forward"
;ToolStrings

\ Define button strings ( text that can optionally be displayed on the button
:ToolStrings HtmlDisplayToolStrings
        ts," Back"
        ts," Forward"
;ToolStrings

\ Define all toolbar buttons in this application.

NextId constant IDM_HTML_BACK
NextId constant IDM_HTML_FORWARD

:ToolBarTable HtmlDisplayTable
\  Bitmap index id                 Initial state    Initial style      tool string index
  22            IDM_HTML_BACK      TBSTATE_ENABLED  TBSTYLE_BUTTON     0 ToolBarButton,
  23            IDM_HTML_FORWARD   TBSTATE_ENABLED  TBSTYLE_BUTTON     1 ToolBarButton,
;ToolBarTable

:Class HtmlDisplayToolbar     <super Win32ToolBar

int hbitmap
72 constant LargeButtonWidth     \ for buttons with text
48 constant LargeButtonHeight
24 constant SmallButtonWidth     \ a little bigger than Windows default
18 constant SmallButtonHeight
30 constant #buttons
int ButtonText?
int FlatToolBar?

:M ClassInit:   ( -- )
                ClassInit: super
                0 to hbitmap
                false to ButtonText?
                true to FlatToolBar?
                ;M

:M Start:       ( parent -- )
                HtmlDisplayTable         IsButtonTable: self
                HtmlDisplayToolTips         IsToolTips: self

                ButtonText?
                if      HtmlDisplayToolStrings
                else    NULL
                then    IsButtonStrings: self

                Start: super

                \ set button size
                ButtonText?
                if      LargeButtonWidth LargeButtonHeight
                else    SmallButtonWidth SmallButtonHeight
                then    word-join 0 TB_SETBUTTONSIZE SendMessage:Self drop

                \ set bitmap size
                16 18 word-join 0 TB_SETBITMAPSIZE SendMessage:Self drop

                HtmlDisplayBitmaps usebitmap   \ create bitmap handle
                map-transparent               \ use system colors for background
                GetDc: self dup>r CreateDIBitmap to hbitmap
                r> ReleaseDc: self
                hbitmap \ do we have a handle?
                if   0 hbitmap #buttons AddBitmaps: self drop
                then
                ;M

:M WindowStyle: ( -- style )
                WindowStyle: super
                [ TBSTYLE_TOOLTIPS TBSTYLE_WRAPABLE or CCS_ADJUSTABLE or nostack1
                CCS_NOPARENTALIGN or CCS_NORESIZE or ] LITERAL or
                FlatToolBar?
                if      TBSTYLE_FLAT  or
                then
                ;M

:M On_Done:     ( -- )
                hbitmap
                if      hbitmap Call DeleteObject drop
                        0 to hbitmap
                then    On_Done: super
                ;M

:M On_ToolBarChange: ( -- f )                   \ User has changed toolbar
                Autosize: self false
                ;M

;Class

\ --------------------------------------------------------------------------------
\ Rebar for the HtmlDisplayWindow
\ --------------------------------------------------------------------------------

:Class HtmlDisplayRebar          <super RebarControl

HtmlDisplayToolbar HtmlToolbar

: add-toolbar   ( -- )
                eraseband-info

\                 New> HtmlDisplayToolbar to HtmlToolbar
                999 SetID: HtmlToolbar
                self Start: HtmlToolbar

                \ Set-up registry key for toolbar customization data...
                s" SOFTWARE\" pad place
                PROGREG count pad +place
                s" Settings" pad +place
                pad +null pad count drop \ Registry sub-key
                z" ToolBar"
                SetRegistryKey: HtmlToolbar

                \ restore any settings
\                false SaveRestore: HtmlToolbar

                [ RBBIM_CHILD RBBIM_CHILDSIZE or RBBIM_STYLE or RBBIM_SIZE or ] LITERAL
                to bfmask
                GetHandle: HtmlToolbar to hwndchild
                0 to cxMinChild
                25 to cyMinChild
                25 to cyChild       \ band height
                200 to cyMaxChild   \ max band height
                1 to cyIntegral
                200 to cx           \ band width
                RBBS_GRIPPERALWAYS   \ RBBS_VARIABLEHEIGHT or
                RBBS_CHILDEDGE or
                to fstyle
                InsertBand: self ;

:M Start:       ( parent -- )
                Start: super
                hwnd
                if   add-toolbar
                then ;M

:M WindowStyle: ( -- style )
                WindowStyle: super
                [ WS_CLIPSIBLINGS WS_CLIPCHILDREN or CCS_NODIVIDER or RBS_VARHEIGHT or RBS_BANDBORDERs or WS_BORDER or RBS_AUTOSIZE or ] literal or
                ;M

:M Close:       ( -- )
                Close: HtmlToolbar
                Close: super ;M

:M Height:      ( -- h )
                GetWindowRect: self
                nip swap - nip ;M

:M Show:        ( f -- )
                if SW_SHOW else SW_HIDE then Show: super ;M

:M Handle_Notify: ( )
                HtmlToolbar
                if   Handle_Notify: HtmlToolbar
                then ;M

:M On_Done:     ( -- )
                On_Done: super ;M

:M ClassInit:   ( -- )
                ClassInit: super
                ;M

;class

\ --------------------------------------------------------------------------------
\ HtmlDisplayWindow class
\ --------------------------------------------------------------------------------

EXTERNAL

:class HtmlDisplayWindow <super Window

HTMLControl      HtmlControl
HtmlDisplayRebar HtmlRebar
int              ShowToolbar?

:M On_Init:     ( -- )
                On_Init: super

                1001 SetId: HtmlControl
                self Start: HtmlControl

                1002 SetId: HtmlRebar
                self Start: HtmlRebar
                ;M

: AdjustWindowSize      { width height win -- }
                SWP_SHOWWINDOW SWP_NOZORDER or SWP_NOMOVE or
                height width
                0 0     \ ignore position
                0       \ ignore z-order
                win Call SetWindowPos drop ;

:M On_Size:     ( -- )
                tempRect.AddrOf GetClientRect: self

                Left: tempRect
                ShowToolbar? if Height: HtmlRebar 2 - else Top: tempRect then
                Right: tempRect
                Bottom: tempRect
                ShowToolbar? if Height: HtmlRebar - 1+ then
                Move: HtmlControl

                ShowToolbar? if Width Height: HtmlRebar GetHandle: HtmlRebar AdjustWindowSize then
                ;M

:M SetURL:      ( zUrl -- )
                SetURL: HtmlControl ;M

:M GoBack:      ( -- )
                GoBack: HtmlControl ;M

:M GoForward:   ( -- )
                GoForward: HtmlControl ;M

:M GoHome:      ( -- )
                GoHome: HtmlControl ;M

:M GoSearch:    ( -- )
                GoSearch: HtmlControl ;M

:M Refresh:     ( -- )
                Refresh: HtmlControl ;M

:M Stop:        ( -- )
                Stop: HtmlControl ;M

:M WM_NOTIFY    ( h m w l -- res )
                HtmlRebar
                if   Handle_Notify: HtmlRebar
                then ;M

:M ClassInit:   ( -- )
                ClassInit: super
                true to ShowToolbar?
                ;M

:M OnWmCommand: ( hwnd msg wparam lparam -- hwnd msg wparam lparam )
                over LOWORD IDM_HTML_BACK    = if GoBack: self exitm then
                over LOWORD IDM_HTML_FORWARD = if GoForward: self exitm then
                OnWmCommand: Super
                ;M

;class

MODULE

cr .( loaded)

--- NEW FILE: AXControl.F ---
\ $Id: AXControl.F,v 1.1 2007/05/16 20:29:06 jos_ven Exp $

\ ActiveX Control Class
\ Thomas Dixon

\ *D doc\classes\
\ *! AXControl
\ *T AXControl -- Base class for ActiveX controls

\ *P AXControl is a class that can be treated like any other control in
\ ** win32forth, except it is enabled to host an activex component. A short
\ ** example of it's usage:

\ *P window win         \n
\ ** start: win         \n
\ ** axcontrol ax       \n
\ ** win start: ax      \n
\ ** s" MSCAL.Calendar" axcreate: ax    \n
\ ** autosize: ax

\ *P The example here hosts a calandar control by it's progid.
\ ** In order to see this work properly, you need to have that activex
\ ** control installed on your machine.  ProgID's may also have some
\ ** version control to them. "MSCAL.Calendar.7" as the progid would
\ ** only host version 7 of the caladar control.
\ *P You may also use the string of the clsid that you want to use instead of
\ ** the progid, if it suits your purposes better.  Ex:
\ *P s" {8E27C92B-1264-101C-8A2F-040224009C02}" axcreate: ax    \n
\ ** autosize: ax
\ *P You may also use a url if you want:                        \n
\ ** s" http://www.google.com" axcreate: ax                     \n
\ ** autosize: ax
\ *P You may also give it html code, if it is proceeded by "MSHTML:"  Ex:  \n
\ ** s" MSHTML:<HTML><BODY>Hello World!</BODY></HTML>" axcreate: ax   \n
\ ** autosize: ax  \n
\ *P Just having the control there is nice, but the REAL trick is to
\ ** communicate with it and exchange data back and forth.  The way that
\ ** this is done is by  getting the control's interface and using it.

\ *S Glossary

anew -AXControl.F

needs fcom
needs childwnd

winlibrary atl.dll


:CLASS AXControl                <SUPER CHILD-WINDOW
\ *G AXControl Base class for ActiveX controls

:M AXUCreate: ( ustr -- )
\ *G calls unicode creation function
        0 0 rot hwnd swap call AtlAxCreateControl abort" Unable to Create ActiveX Control!"
        ;M

:M AXCreate:  ( str len -- )
\ *G Initialize the ActiveX control
        1+ asc>uni over + 0 swap 2 - w!  dup>r
        AXUCreate: self
        r> free drop
        ;M

:M QueryInterface:    ( ppv riid -- flag )
\ *G flag is true on error
        0 >r rp@ hwnd call AtlAxGetControl if r>drop true exitm then
        rp@ COM IUnknown IQueryInterface
        rp@ COM IUnknown IReleaseRef drop r>drop
        ;M

;CLASS
\ *G End of AXControl class

\ *Z

--- NEW FILE: ADO.f ---
\ *D doc\classes\
\ *! ADO
\ *T ADO -- ADO Classes for Database Interfacing
\ *Q Tom Dixon - August 2006
\ ** These classes were developed to make accessing databases easy and convienent
\ ** with win32forth.

needs fcom

2 5 typelib {00000205-0000-0010-8000-00AA006D2EA4} \ inlude ADO type library


create UComma 32 allot  u" ," UComma uniplace           \ Column Delimeter
create Ucrlf  32 allot  crlf$ count >unicode Ucrlf uniplace \ New Record Delimeter
create Unull 32 allot  u" " Unull uniplace     \ Null Character Replacement

\ *S  ADOConnection Class

:class ADOConnection               <SUPER Object
\ *G An ADO connection object controls the access of cursors to the database.
\ ** It is meant to control things such as tranactions, read/write properties
\ ** and error handling.
        CELL bytes Conn
        CELL bytes Errs
        16   bytes xtra
             int   mstr
             int   mstrlen

:M Freemstr: ( -- )
        mstr if mstr free drop 0 to mstr 0 to mstrlen then ;M

:M ~: (  --  )

        Conn @ if Conn COM _Connection Release drop 0 Conn ! then
        Freemstr: self ;M

:M Start: ( -- )
\ *G Initializes the ADO Connection Component.  Most methods will not execute properly
\ ** if this is not called when the object instance is created
        Conn @ 0= if
          Conn _Connection 1 0 Connection call CoCreateInstance
          abort" Unable to Create Connection Object!" then ;M

:M Connect: ( -- )
\ *G Connects to the data source specified by the connection string with the given
\ ** connection properties.
        0 0 0 0 Conn COM _Connection Open drop ;M

:M GetConn: ( -- IConn ) Conn @ ;M

:M Close: ( -- flag )
\ *G Closes the database connection.  The COM component still exists and a new
\ ** connection may be made if desired.
        Conn COM _Connection Close drop
        Freemstr: self ;M

:M BSTR>ASC: ( bstr -- str len )
        dup 0= if drop s" " exitm then
        Freemstr: self
        dup dup bstrlen ?dup if uni>asc else drop s" " then
        2dup to mstrlen to mstr
        rot bstrfree ;M

:M GetErrorCnt: ( -- cnt )
\ *G Return the number of errors in the FIFO error queue
        Errs Conn COM _Connection GetErrors
        abort" Unable to Get Errors!"
        xtra Errs COM Errors GetCount drop xtra @
        Errs COM Errors Release drop ;M

:M GetError: ( cnt -- n )
\ *G Return the error number of the 'cnt' error in the error queue
        Errs Conn COM _Connection GetErrors
        abort" Unable to Get Errors!"
        xtra 0 rot 0 VT_I4
        Errs COM Errors GetItem abort" Unable to get Error!"
        0 >r rp@ xtra COM Error GetNumber drop r>
        xtra COM Error Release drop
        Errs COM Errors Release drop ;M

:M Error>str: ( n -- str len )
\ *G Return the error string of the 'cnt' error in the error queue
        Errs Conn COM _Connection GetErrors
        abort" Unable to Get Errors!"
        xtra 0 rot 0 VT_I4
        Errs COM Errors GetItem abort" Unable to get Error!"
        0 >r rp@ xtra COM Error GetDescription drop
        r> bstr>asc: self
        xtra COM Error Release drop
        Errs COM Errors Release drop ;M

:M ClearErrors: ( -- )
\ *G Clears the FIFO error queue
        Errs Conn COM _Connection GetErrors
        abort" Unable to Get Errors!"
        Errs COM Errors Clear drop
        Errs COM Errors Release drop ;M

:M ERR: ( n -- ) \ thows an error on any problem
\ *G Displays and clears all errors in the queue
        GetErrorCnt: self 0 ?do
          i Error>str: self type cr
        loop
        clearerrors: self ;M

:M Transaction: ( -- )
\ *G Starts a transaction session for this connection.  All changes
\ ** performed on the database will not take effect until they are committed.
\ ** Some databases may not support this functionality.
        xtra Conn COM _Connection BeginTrans drop
        xtra @ drop \ nesting level - don't use right now...
        ;M
:M Commit: ( -- )
\ *G Commit all changes in the current transaction to the database.
        Conn COM _Connection CommitTrans drop ;M

:M RollBack: ( -- )
\ *G Drop all changes in the current transaction - no changes are made for the
\ ** transaction session.
        Conn COM _Connection RollbackTrans drop ;M

:M GetTimeOut: ( -- n )
\ *G Returns the timeout time (in seconds) that queries will give up.
        xtra Conn COM _Connection GetCommandTimeout drop
        xtra @ ;M

:M SetTimeOut: ( n -- )
\ *G Sets the timeout time (in seconds) that queries will give up.
        Conn COM _Connection PutCommandTimeout drop ;M

:M GetConnString: ( -- str len )
\ *G Return the connection string for the data source.  This may not necessarily
\ ** be the same string that was given to the object
        xtra Conn COM _Connection GetConnectionString drop
        xtra @ bstr>asc: self ;M

:M SetConnString: ( str len -- )
\ *G Set the connection string for the data source.  The connection string tells
\ ** the object what drivers to use, where the database is, user name, and password.
        Asc>bstr dup >r Conn COM _Connection PutConnectionString
        abort" Unable to set Connection String!" r> bstrfree ;M

:M GetProvider: ( -- str len )
\ *G Returns the provider for the connection.
        xtra Conn COM _Connection GetProvider drop
        xtra @ bstr>asc: self ;M

:M SetProvider: ( str len -- )
\ *G Sets the provider for the connection.  Can be set through the connection string
\ ** as well.
        Asc>bstr drop dup >r Conn COM _Connection PutProvider
        abort" Unable to set Provider!" r> bstrfree ;M

:M GetMode: ( -- n )
\ *G Returns the connection mode.
        xtra Conn COM _Connection GetMode drop
        xtra @ ;M

:M SetMode: ( n -- )
\ *G Sets the connection mode.  The connection mode indicates whether the database
\ ** is read-only, write-only, sharable, etc...\n
\ ** See the ConnectModeEnum constants below the class descriptions.
        Conn COM _Connection PutMode drop ;M

:M GetState: ( -- n )
\ *G Returns the current state of the connection object.
        xtra Conn COM _Connection GetState drop
        xtra @ ;M

;class




\ *S  ADOCursor Class

:class ADOCursor               <SUPER Object
\ *G An ADO cursor object represents a recordset of data, or data in a table-like
\ ** structure.  Data can be loaded, updated, inserted through this object.
        CELL bytes Rec
        CELL bytes flds
        CELL bytes fld
        16   bytes xtra
             int   CONNptr
             int   mstr
             int   mstrlen

:M Freemstr: ( -- )
        mstr if mstr free drop 0 to mstr 0 to mstrlen then ;M

:M ~: (  --  )
        Rec @ if Rec COM _Recordset Release drop 0 Rec ! then
        Freemstr: self ;M

:M Start: ( -- )
\ *G Initializes the ADO Recordset Component.  Most methods will not execute properly
\ ** if this is not called when the object instance is created
        Rec @ 0= if
          Rec _Recordset 1 0 RecordSet call CoCreateInstance
          abort" Unable to Create Recordset Object!" then ;M

:M BSTR>ASC: ( bstr -- str len )
        dup 0= if drop s" " exitm then
        Freemstr: self
        dup dup bstrlen ?dup if uni>asc else drop s" " then
        2dup to mstrlen to mstr
        rot bstrfree ;M

:M SetConnection: ( ADOConnection -- )
\ *G Sets the connection object for this cursor.  It is required before any query
\ ** is executed.
        to CONNptr ;M

:M GetCacheSize: ( -- n )
\ *G Returns the cache size of the cursor.  The value is the number of records in the
\ ** cache before updates are required.
        xtra rec COM _Recordset GetCacheSize drop xtra @ ;M

:M SetCacheSize: ( n -- )
\ *G Sets the cache size of the cursor.  The default is 1, or updates occur with every
\ ** new record edited.
        rec COM _Recordset PutCacheSize drop ;M

:M GetCursorType: ( -- ctype )
\ *G Returns the cursor type.
        xtra rec COM _Recordset GetCursorType drop xtra @ ;M

:M SetCursorType: ( ctype -- )
\ *G Sets the cursor type.  The cursor type determines what is allowed on the cursor
\ ** data and how data is seen in a multi-client environment.  The possible values are:
\ *L
\ *| adOpenUnspecified | The cursor type is unspecified.  Usually defaults to adOpenForwardOnly |
\ *| adOpenStatic | All movement methods are available.  Changes from other users are not visible |
\ *| adOpenForwardOnly | The cursor can only move forward.  The record count and other navigation methods are invalid.  This should have the best performance of the cursors. |
\ *| adOpenDynamic  | All additions, deletions and changes from other users are visible |
\ *| adOpenKeyset | Like a dynamic cursor, except added records can't be seen and deleted records are inaccessible |
        rec COM _Recordset PutCursorType drop ;M

:M GetLockType: ( -- n )
\ *G Returns the lock type.
        xtra rec COM _Recordset GetLockType drop xtra @ ;M

:M SetLockType: ( n -- )
\ *G Sets the lock type.  The lock type determines how the database is to handle changes
\ ** to the data on a cursor.  The possible values are:
\ *L
\ *| adLockUnspecified | The lock type is unspecified.  Usually defaults to adLockReadOnly |
\ *| adLockReadOnly | The records are read-only. Data cannot be altered |
\ *| adLockPessimistic | Pessamistic locking.  Record(s) are locked at the data source immediately when the alterations begin. |
\ *| adLockOptimistic | Optimistic locking.  Record(s) are locked only when the update method is called |
\ *| adLockBatchOptimistic | Useful for batch updates. |
        rec COM _Recordset PutLockType drop ;M

:M GetMaxRows: ( -- n )
\ *G Returns the maximum number of records to be returned in a query.
        xtra rec COM _Recordset GetMaxRecords drop xtra @ ;M

:M SetMaxRows: ( n -- )
\ *G Sets the maximum number of records to be returned from a query (0 = unlimited)
        rec COM _Recordset PutMaxRecords drop ;M

:M Close: ( -- )
\ *G Closes the cursor.  Another query can be executed on the cursor once it has been closed.
        Rec COM _Recordset Close drop ;M

:M GetState: ( -- n )
\ *G Returns the state of the cursor.  Useful when executing queries asyncronously.
        xtra Rec COM _Recordset GetState drop xtra @ ;M

:M Executing?: ( -- flag )
\ *G Returns true if the query is still executing.
        GetState: self adStateExecuting and ;M

:M Fetching?: ( -- flag )
\ *G Returns true if the rows are still being retrieved
        GetState: self adStateFetching and ;M

:M (Execute): ( str len option -- )
        -rot asc>bstr >r
        GetLockType: self
        GetCursorType: self
        0 CONNptr dup if GetConn: ADOConnection then 0 VT_DISPATCH
        0 r@ 0 VT_BSTR
        Rec COM _RecordSet Open
        r> bstrfree
        if CONNptr dup if err: ADOConnection then
           true abort" Unable to Execute Query!" then ;M


:M Execute: ( str len -- )
\ *G Execute a SQL query on the cursor.  Any returned data will be in the cursor.
        adOptionUnspecified (Execute): self ;M

:M AsyncExecute: ( str len -- )
\ *G Operates the same as the execute method, but is asyncronous.  The cursor's
\ ** state will indicate if the query has finished executing or not.
        adAsyncExecute (Execute): self ;M

:M Requery: ( n -- )
\ *G Rerun the last query.
        rec COM _Recordset Requery drop ;M

:M RecordCount: ( -- n )
\ *G Return the number of records in cursor.  May not work with the adOpenForwardOnly
\ ** cursor type.
        xtra rec COM _Recordset GetRecordCount drop xtra @ ;M

:M Move: ( n -- )
\ *G Move to the record number 'n' of the cursor's data
        >r 0 DISP_E_PARAMNOTFOUND 0 VT_ERROR r>
        rec COM _Recordset Move drop ;M

:M MoveFirst: ( -- )
\ *G Move to the first record of the cursor's data.
        rec COM _Recordset MoveFirst drop ;M

:M MoveNext: ( -- )
\ *G Move to the next record of the cursor's data
        rec COM _Recordset MoveNext drop ;M

:M MovePrevious: ( -- )
\ *G Move to the previous record of the cursor's data
        rec COM _Recordset MovePrevious drop ;M

:M MoveLast: ( -- )
\ *G Move to the last record of the cursor's data
        rec COM _Recordset MoveLast drop ;M

:M EOF: ( -- flag )
\ *G Flag that indicates if the current record position is after the last record.
        xtra rec COM _Recordset GetEOF drop xtra @ ;M

:M BOF: ( -- flag )
\ *G Flag that indicates if the current record position is before the first record.
        xtra rec COM _Recordset GetBOF drop xtra @ ;M

:M FieldCnt: ( -- n )
\ *G Returns the number of columns in the current record.
        flds rec COM _Recordset GetFields abort" Fields error!"
        xtra flds COM Fields GetCount drop xtra @
        flds COM Fields Release drop ;M

:M FieldType: ( field -- DataTypeEnum )
\ *G Returns the data type constant of the given column. Possible data types are:
\ *L
\ *| adEmpty |
\ *| adTinyInt |
\ *| adSmallInt |
\ *| adInteger |
\ *| adBigInt|
\ *| adUnsignedTinyInt  |
\ *| adUnsignedSmallInt |
\ *| adUnsignedInt |
\ *| adUnsignedBigInt |
\ *| adSingle |
\ *| adDouble |
\ *| adCurrency  |
\ *| adDecimal |
\ *| adNumeric  |
\ *| adBoolean  |
\ *| adError  |
\ *| adUserDefined  |
\ *| adVariant  |
\ *| adIDispatch  |
\ *| adIUnknown |
\ *| adGUID |
\ *| adDate  |
\ *| adDBDate  |
\ *| adDBTime  |
\ *| adDBTimeStamp |
\ *| adBSTR |
\ *| adChar  |
\ *| adVarChar  |
\ *| adLongVarChar |
\ *| adWChar |
\ *| adVarWChar |
\ *| adLongVarWChar |
\ *| adBinary |
\ *| adVarBinary  |
\ *| adLongVarBinary |
\ *| adChapter |
\ *| adFileTime |
\ *| adPropVariant |
\ *| adVarNumeric  |
\ *| adArray |
        flds rec COM _Recordset GetFields abort" Fields error!"
        fld 0 rot 0 VT_I4 flds COM Fields GetItem abort" Not a Field!"
        xtra fld COM Field GetType drop xtra @
        flds COM Fields Release drop ;M

:M FieldName: ( field -- str len )
\ *G Returns the column name of the given column number.
        flds rec COM _Recordset GetFields abort" Fields error!"
        fld 0 rot 0 VT_I4 flds COM Fields GetItem abort" Not a Field!"
        xtra fld COM Field GetName drop
        xtra @ bstr>asc: self
        fld COM Field Release drop
        flds COM Fields Release drop ;M

:M FieldSize: ( field -- n )
\ *G Returns the data size of the given column number.
        flds rec COM _Recordset GetFields abort" Fields error!"
        fld 0 rot 0 VT_I4 flds COM Fields GetItem abort" Not a Field!"
        xtra fld COM Field GetActualSize drop xtra @
        fld COM Field Release drop
        flds COM Fields Release drop ;M


:M GetValue: ( field -- )
        xtra 16 0 fill
        flds rec COM _Recordset GetFields abort" Fields error!"
        fld 0 rot 0 VT_I4 flds COM Fields GetItem abort" Not a Field!"
        xtra fld COM Field GetValue drop
        fld COM Field Release drop
        flds COM Fields Release drop ;M

:M GetInt: ( field -- int )
\ *G Returns an integer value of the given column on the current row.
        GetValue: self
        xtra @ VT_NULL = if 0 else xtra 2 cells + @ then ;M

:M GetDouble: ( field -- d )
\ *G Returns the double of the given column on the current row.
        GetValue: self
        xtra @ VT_NULL = if 0 0 else xtra 2 cells + 2@ then ;M

:M GetFloat: ( field -- float )
\ *G Returns the floating point value of the given column on the current row.
        GetValue: self
        xtra @ VT_NULL = if 0e0 else xtra 8 + df@ then ;M

:M GetStr: ( field -- str len )
\ *G Returns the string of the given column on the current row.  May be much longer than 255
        GetValue: self
        xtra @ VT_NULL = if s" " else xtra 2 cells + @ bstr>asc: self then ;M

:M GetTimeStamp: ( field -- float )
\ *G Return the timestamp value of the given column on the current row.  The timestamp value is
\ ** a floating point number that indicates the number of days since Dec 31, 1899.
        GetFloat: self ;M

:M GetDateTime: ( field -- sec min hour day month year )
\ *G Returns the datetime values of the given column on the current row.
        GetValue: self
        xtra @ VT_NULL = if 0 0 0 0 0 0 exitm then
        time-buf xtra 8 + 2@ call VariantTimeToSystemTime drop
        time-buf 12 + w@        \ seconds
        time-buf 10 + w@        \ minutes
        time-buf  8 + w@        \ hours
        time-buf  6 + w@        \ day of month
        time-buf  2 + w@        \ month of year
        time-buf      w@ ;M     \ year

:M isNull?: ( field -- flag )
\ *G Returns true if the given field for the given flag is null
        getValue: self
        xtra @ VT_NULL = ;M


:M SetValue: ( variant field -- ) \ puts xtra variant into Field
        flds rec COM _Recordset GetFields abort" Fields error!"
        fld 0 rot 0 VT_I4 flds COM Fields GetItem abort" Not a Field!"
        fld COM Field PutValue abort" Value Not Set!"
        fld COM Field Release drop
        flds COM Fields Release drop ;M

:M SetInt: ( int field -- )
\ *G Sets the integer value of a given column on the current row.
        >r 0 swap 0 VT_I4 r> SetValue: self ;M

:M SetDouble: ( d field -- )
\ *G Sets the double value of a given column on the current row.
        >r 0 VT_I8 r> SetValue: self ;M

:M SetFloat: ( float field -- )
\ *G Sets the floating point number of a given column on the current row.
        >r fs>ds 0 VT_R8 r> SetValue: self ;M

:M SetNull: ( field -- )
\ *G Sets the field value to null of a given column on the current row.
        >r 0 0 0 VT_NULL r> SetValue: self ;M

:M SetStr: ( str len field -- )
\ *G Sets the string value of a given column on the current row.
        -rot asc>bstr dup >r swap >r
        0 swap 0 VT_BSTR r> SetValue: self
        r> bstrfree ;M

:M SetTimeStamp: ( float field -- )
\ *G Sets the timestamp value of the given column on the current row.  The timestamp value is
\ ** a floating point number that indicates the number of days since Dec 31, 1899.
        SetFloat: self ;M

:M SetDateTime: ( sec min hour day month year field -- )
\ *G Sets the datetime values of the given column on the current row.
        time-buf time-len 0 fill
        >r time-buf      w!  \ year
           time-buf 2  + w!  \ month
           time-buf 6  + w!  \ day
           time-buf 8  + w!  \ hours
           time-buf 10 + w!  \ minutes
           time-buf 12 + w!  \ seconds
        xtra time-buf call SystemTimeToVariantTime
        0= abort" Unable to Convert DateTime!"
        xtra 4 + @ xtra @ 0 VT_DATE
        r> SetValue: self ;M

:M AddRow: ( -- )
\ *G Adds a new record to the end of the recordset and sets this as the current row.  The row
\ ** is not actually created until the update method is called.
        0 DISP_E_PARAMNOTFOUND 0 VT_ERROR
        0 DISP_E_PARAMNOTFOUND 0 VT_ERROR
        rec COM _Recordset AddNew abort" Unable to Add Row!" ;M

:M DeleteRow: ( -- )
\ *G Deletes the current record.
        adAffectCurrent rec COM _Recordset Delete
        abort" Unable to Delete Row!" ;M

:M Update: ( -- )
\ *G Updates the alterations to the data.
        0 DISP_E_PARAMNOTFOUND 0 VT_ERROR
        0 DISP_E_PARAMNOTFOUND 0 VT_ERROR
        rec COM _Recordset Update abort" Update Failed!" ;M


:M (Save): ( str len type -- )
        -rot asc>bstr dup >r 0 swap 0 VT_BSTR
        Rec COM _RecordSet Save abort" Unable to Save!"
        r> bstrfree ;M

:M SaveNative: ( str len -- )
\ *G Saves the cursor's data to a file that is in a unspecified format.
        0 (Save): self ;M

:M SaveXML: ( str len -- )
\ *G Saves the cursor's data as a XML file.
        adPersistXML (Save): self ;M

:M SaveADTG: ( str len -- )
\ *G Saves the cursor's data in the Microsoft Advanced Data TableGram (ADTG) format.
\ ** Requires a filename.
        adPersistADTG (Save): self ;M

:M SaveCSV: ( str len -- )
\ *G Saves the cursor's data to a comma separated value file for easy viewing.
\ ** Cannot be loaded later through the loadfile method.
        xtra 16 0 fill
        xtra UNull cell+ Ucrlf cell+ Ucomma cell+
        -1 adClipString Rec COM _Recordset GetString
        abort" Unable to Convert Records!"
        w/o create-file abort" Unable to Create File!" >r
        xtra @ bstr>asc: self
        r@ write-file drop r> close-file drop ;M

:M LoadFile: ( str len -- )
\ *G Loads a cursor data file that was saved previously.\n
\ ** A connection object is not required to load this data.
        adCmdFile (Execute): self ;M

;class



\ Relavant ADO Constants
\ This may seem unnecessary, but once we unload the type library, the
\ constants will not be accessible, so they are redefined as forth
\ constants

\ ConnectModeEnum
adModeUnknown           CONSTANT adModeUnknown
adModeRead              CONSTANT adModeRead
adModeWrite             CONSTANT adModeWrite
adModeReadWrite         CONSTANT adModeReadWrite
adModeShareDenyRead     CONSTANT adModeShareDenyRead
adModeShareDenyWrite    CONSTANT adModeShareDenyWrite
adModeShareExclusive    CONSTANT adModeShareExclusive
adModeShareDenyNone     CONSTANT adModeShareDenyNone
adModeRecursive         CONSTANT adModeRecursive

\ CursorTypeEnum
adOpenUnspecified       CONSTANT adOpenUnspecified
adOpenForwardOnly       CONSTANT adOpenForwardOnly
adOpenKeyset            CONSTANT adOpenKeyset
adOpenDynamic           CONSTANT adOpenDynamic
adOpenStatic            CONSTANT adOpenStatic

\ LockTypeEnum
adLockUnspecified       CONSTANT adLockUnspecified
adLockReadOnly          CONSTANT adLockReadOnly
adLockPessimistic       CONSTANT adLockPessimistic
adLockOptimistic        CONSTANT adLockOptimistic
adLockBatchOptimistic   CONSTANT adLockBatchOptimistic

\ DataTypeEnum
adEmpty                 CONSTANT adEmpty
adTinyInt               CONSTANT adTinyInt
adSmallInt              CONSTANT adSmallInt
adInteger               CONSTANT adInteger
adBigInt                CONSTANT adBigInt
adUnsignedTinyInt       CONSTANT adUnsignedTinyInt
adUnsignedSmallInt      CONSTANT adUnsignedSmallInt
adUnsignedInt           CONSTANT adUnsignedInt
adUnsignedBigInt        CONSTANT adUnsignedBigInt
adSingle                CONSTANT adSingle
adDouble                CONSTANT adDouble
adCurrency              CONSTANT adCurrency
adDecimal               CONSTANT adDecimal
adNumeric               CONSTANT adNumeric
adBoolean               CONSTANT adBoolean
adError                 CONSTANT adError
adUserDefined           CONSTANT adUserDefined
adVariant               CONSTANT adVariant
adIDispatch             CONSTANT adIDispatch
adIUnknown              CONSTANT adIUnknown
adGUID                  CONSTANT adGUID
adDate                  CONSTANT adDate
adDBDate                CONSTANT adDBDate
adDBTime                CONSTANT adDBTime
adDBTimeStamp           CONSTANT adDBTimeStamp
adBSTR                  CONSTANT adBSTR
adChar                  CONSTANT adChar
adVarChar               CONSTANT adVarChar
adLongVarChar           CONSTANT adLongVarChar
adWChar                 CONSTANT adWChar
adVarWChar              CONSTANT adVarWChar
adLongVarWChar          CONSTANT adLongVarWChar
adBinary                CONSTANT adBinary
adVarBinary             CONSTANT adVarBinary
adLongVarBinary         CONSTANT adLongVarBinary
adChapter               CONSTANT adChapter
adFileTime              CONSTANT adFileTime
adPropVariant           CONSTANT adPropVariant
adVarNumeric            CONSTANT adVarNumeric
adArray                 CONSTANT adArray


\ free the type library
free-lasttypelib

\ *Z

--- NEW FILE: FlashControl.F ---
\ $Id: FlashControl.F,v 1.1 2007/05/16 20:29:06 jos_ven Exp $

\ Shockwave Flash control written in forth
\ Tom Dixon

anew -FlashControl

needs AXControl

\ Load Shockwave TypeLibrary
1 0 typelib {D27CDB6B-AE6D-11CF-96B8-444553540000}

\ We Build off the Generic ActiveX Control
:CLASS FlashControl           <SUPER AXControl
  CELL bytes Flash      \ pointer to IShockwaveFlash interface
  16 bytes xtra         \ xtra space for api calls

  :M Start: ( Parent -- )
        Start: super
        xtra ShockwaveFlash call StringFromCLSID abort" Unable to Get Flash CLSID!"
        xtra @ AXUCreate: self
        Flash IShockwaveFlash QueryInterface: self
          abort" Unable to get the IShockwaveFlash Interface!"
        ;M

  :M On_Done: ( -- )
        Flash @ if
          Flash COM IShockwaveFlash Release drop 0 Flash ! then ;M

  \ ShockWave Methods
  :M PutMovie: ( str len -- f )
        >unicode drop flash COM IShockwaveFlash PutMovie ;M
  :M GetMovie: ( -- str len )
        xtra Flash COM IShockwaveFlash GetMovie drop
        xtra @ dup >r zunicount >ascii r> call SysFreeString drop ;M

  :M Play: ( -- ) Flash COM IShockwaveFlash Play drop ;M
  :M Stop: ( -- ) Flash COM IShockwaveFlash Stop drop ;M
  :M Back: ( -- ) Flash COM IShockwaveFlash Back drop ;M
  :M Forward: ( -- ) Flash COM IShockwaveFlash Forward drop ;M
  :M Rewind: ( -- ) Flash COM IShockwaveFlash Rewind drop ;M
  :M StopPlay: ( -- ) Flash COM IShockwaveFlash StopPlay drop ;M
  :M GotoFrame: ( n -- ) Flash COM IShockwaveFlash GotoFrame drop ;M
  :M CurrentFrame: ( -- n ) xtra Flash COM IShockwaveFlash CurrentFrame drop xtra @ ;M
  :M TotalFrames: ( -- n ) xtra Flash COM IShockwaveFlash GetTotalFrames drop xtra @ ;M
  :M Playing?: ( -- flag ) xtra Flash COM IShockwaveFlash IsPlaying drop xtra @ ;M
  :M Loaded%: ( -- percent ) xtra Flash COM IShockwaveFlash PercentLoaded drop xtra @ ;M
  :M Loop: ( flag -- ) Flash COM IShockwaveFlash PutLoop drop ;M
  :M Loop?: ( -- flag ) xtra Flash COM IShockwaveFlash GetLoop drop xtra @ ;M
  :M Pan: ( n n n -- ) Flash COM IShockwaveFlash Pan drop ;M
  :M Zoom: ( n -- ) Flash COM IShockwaveFlash Zoom drop ;M
  :M SetZoomRect: ( n n n n -- ) Flash COM IShockwaveFlash SetZoomRect drop ;M
  :M BGColor: ( -- color ) xtra Flash COM IShockwaveFlash GetBackgroundColor drop xtra @ ;M
  :M SetBGColor: ( color -- ) Flash COM IShockwaveFlash PutBackgroundColor drop ;M

;CLASS

\ We don't need the typelibrary anymore, so unload it now.
free-lasttypelib

\s
for an example see demos\FlashControlDemo.f

--- NEW FILE: PDFControl.F ---
\ $Id: PDFControl.F,v 1.1 2007/05/16 20:29:06 jos_ven Exp $

\ Acrobat PDF Control
\ Thomas Dixon

anew -PdfControl.f

needs AXControl

\ We Build off the Generic ActiveX Control
:CLASS PDFControl           <SUPER AXControl
  CELL bytes PDF        \ pointer to Dispatch Interface
  16 bytes xtra         \ xtra space for api calls

  :M Start: ( Parent -- )
        Start: super
          \ You can use PDF.PdfCtrl.6 instead of the ugly clsid string, but this
          \ way we aren't dependent on the vertion of adobe acrobat
        s" {CA8A9780-280D-11CF-A24D-444553540000}" AXCreate: self
        PDF IDispatch QueryInterface: self
          abort" Unable to get the Dispatch Interface!"
        ;M

  :M On_Done: ( -- )
        PDF @ if
          PDF COM IDispatch IReleaseref drop 0 PDF ! then ;M

  :M LoadFile: ( str len -- flag ) \ flag is true on error
        >unicode drop VT_BSTR >vt
        PDF displate" LoadFile" ;M

  :M SetPage: ( n -- )
        VT_I4 >vt
        PDF displate" setCurrentPage" drop ;M
  :M gotoFirstPage: ( -- )
        PDF displate" gotoFirstPage" drop ;M
  :M gotoLastPage: ( -- )
        PDF displate" gotoLastPage" drop ;M
  :M gotoNextPage: ( -- )
        PDF displate" gotoNextPage" drop ;M
  :M gotoPreviousPage: ( -- )
        PDF displate" gotoPreviousPage" drop ;M
  :M goForward: ( -- )
        PDF displate" goForwardStack" drop ;M
  :M goBack: ( -- )
        PDF displate" goBackwardStack" drop ;M

  :M Print: ( -- )
        PDF displate" Print" drop ;M
  :M PrintWithDialog: ( -- )
        PDF displate" PrintWithDialog" drop ;M
  :M PrintPages: ( n n -- )
        swap VT_I4 >vt VT_I4 >vt
        PDF displate" PrintPages" drop ;M
  :M PrintPagesFit: ( flag n n -- )
        rot VT_BOOL >vt swap VT_I4 >vt VT_I4 >vt
        PDF displate" PrintPagesFit" drop ;M
  :M PrintAll: ( -- )
        PDF displate" PrintAll" drop ;M
  :M PrintAllFit: ( bool -- )
        VT_BOOL >vt
        PDF displate" PrintAllFit" drop ;M

  :M SetZoom: ( float -- ) \ 100e0 is 100%
        sfs>ds VT_R4 >vt
        PDF displate" SetZoom" drop ;M
  :M SetZoomScroll: ( float float float -- )
        3 0 do sfs>ds VT_R4 loop   3 0 do >vt loop
        PDF displate" SetZoomScroll" drop ;M
  :M SetViewRect: ( float float float float -- )
        4 0 do sfs>ds VT_R4 loop   4 0 do >vt loop
        PDF displate" SetViewRect" drop ;M

  :M SetPageMode: ( str len -- )
        >unicode drop VT_BSTR >vt
        PDF displate" SetPageMode" drop ;M
  :M SetLayoutMode: ( str len -- )
        >unicode drop VT_BSTR >vt
        PDF displate" SetLayoutMode" drop ;M
  :M SetNamedDest: ( str len -- )
        >unicode drop VT_BSTR >vt
        PDF displate" SetNamedDest" drop ;M

  :M SetShowToolbar: ( flag -- )
        VT_BOOL >vt
        PDF displate" SetShowToolbar" drop ;M
  :M SetShowScrollbars: ( flag -- )
        VT_BOOL >vt
        PDF displate" SetShowScrollbars" drop ;M

  :M Aboutbox: ( -- )
        PDF displate" AboutBox" drop ;M

;CLASS

\ I don't think the PDF viewer was ever ment to be used as an embedded control
\ It only supports the dispatch interface and updates (such as resizing) are rather slow

\s
\ Example: see demos/PdfControlDemo.f