Thread: [Win32forth-cvs] win32forth/src/lib AXControl.F,NONE,1.1 FCOM.F,NONE,1.1 FlashControl.F,NONE,1.1 HTM

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 422-6466

Update of /cvsroot/win32forth/win32forth/src/lib
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15255/src/lib

Added Files:
	AXControl.F FCOM.F FlashControl.F HTMLcontrol.F PDFControl.F 
Log Message:
Uploaded Tom's COM support.

--- NEW FILE: AXControl.F ---
\ ActiveX Control Class
\ Thomas Dixon

anew -AXControl.F

needs fcom

winlibrary atl.dll

4 proc AtlAxCreateControl
2 proc AtlAxGetControl

:CLASS AXControl                <SUPER CHILD-WINDOW

  :M AutoSize:    ( -- )
        tempRect.AddrOf GetClientRect: Parent
        0 0 Right: tempRect Bottom: tempRect   \ x,y,h,w
        Move: self
        ;M

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

  :M AXCreate:  ( str len -- ) \ 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 ) \ flag is true on error
        0 >r rp@ hwnd AtlAxGetControl if r> drop true exitm then
        rp@ COM IUnknown IQueryInterface
        rp@ COM IUnknown IReleaseRef drop r> drop
        ;M

;CLASS

\s
window win
start: win
axcontrol ax
win start: ax
s" MSCAL.Calendar.7" axcreate: ax
autosize: ax

--- NEW FILE: FlashControl.F ---
\ Shockwave Flash control written in forth
\ Tom Dixon

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 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
\ Example:

:class Flashwin <super window
  Flashcontrol fcntrl

  :M On_Init: ( -- )
     On_Init: super
     self Start: fcntrl ;M

  :M On_Size: ( h m w -- ) 2drop drop autosize: fcntrl ;M

  \ ShockWave Methods
  :M PutMovie: ( str len -- f ) PutMovie: fcntrl ;M
  :M GetMovie: ( -- str len ) GetMovie: fcntrl ;M
  :M Play: ( -- ) Play: fcntrl ;M
  :M Stop: ( -- ) Stop: fcntrl ;M
  :M Back: ( -- ) Back: fcntrl ;M
  :M Forward: ( -- ) Forward: fcntrl ;M
  :M Rewind: ( -- ) Rewind: fcntrl ;M
  :M StopPlay: ( -- ) StopPlay: fcntrl ;M
  :M GotoFrame: ( n -- ) GotoFrame: fcntrl ;M
  :M CurrentFrame: ( -- n ) CurrentFrame: fcntrl ;M
  :M TotalFrames: ( -- n ) TotalFrames: fcntrl ;M
  :M Playing?: ( -- flag ) Playing?: fcntrl ;M
  :M Loaded%: ( -- percent ) Loaded%: fcntrl ;M
  :M Loop: ( flag -- ) Loop: fcntrl ;M
  :M Loop?: ( -- flag ) Loop?: fcntrl ;M
  :M Pan: ( n n n -- ) Pan: fcntrl ;M
  :M Zoom: ( n -- ) Zoom: fcntrl ;M
  :M SetZoomRect: ( n n n n -- ) SetZoomRect: fcntrl ;M
  :M BGColor: ( -- color ) BGColor: fcntrl ;M
  :M SetBGColor: ( color -- ) SetBGColor: fcntrl ;M

;class

Flashwin fwin
start: fwin
0 setbgcolor: fwin
s" c:\temp\swf\f02[1].swf" putmovie: fwin drop
true loop: fwin

--- NEW FILE: HTMLcontrol.F ---
\ HTML Control
\ Thomas Dixon

needs AXControl

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

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

  :M Start: ( Parent -- )
        Start: super
        xtra WebBrowser 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 GetPath: ( -- str len )
        xtra Web COM IWebBrowser2 GetPath drop
        xtra @ dup >r zunicount >ascii r> call SysFreeString drop  ;M
  :M GetLocationURL: ( -- str len )
        xtra Web COM IWebBrowser2 GetLocationURL drop
        xtra @ dup >r zunicount >ascii r> call SysFreeString drop ;M
  :M GetLocationName: ( -- str len )
        xtra Web COM IWebBrowser2 GetLocationName drop
        xtra @ dup >r zunicount >ascii r> SysFreeString drop ;M
  :M Busy?: ( -- flag ) xtra Web COM IWebBrowser2 GetBusy drop xtra @ 1 and ;M

  \ Navigation Functions
  :M GoHome: ( -- ) Web COM IWebBrowser2 GoHome drop ;M
  :M GoSearch: ( -- ) Web COM IWebBrowser2 GoSearch drop ;M
  :M GoForward: ( -- ) Web COM IWebBrowser2 GoForward drop ;M
  :M GoBack: ( -- ) Web COM IWebBrowser2 GoBack drop ;M
  :M Refresh: ( -- ) Web COM IWebBrowser2 Refresh drop ;M
  :M Stop: ( -- ) Web COM IWebBrowser2 Stop drop ;M
  :M GoURL: ( str len -- ) \ Navigate to the URL
     >unicode drop >r
     0 0 0 0 r> Web COM IWebBrowser2 Navigate drop ;M

;CLASS

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

free-lasttypelib

\s

\ Example:
\ Create a simple browser window

:class Browserwin <super window
  HTMLcontrol html

  :M On_Init: ( -- )
     On_Init: super
     self Start: html ;M

  :M On_Size: ( h m w -- ) 2drop drop autosize: html ;M

  :M GetPath: ( -- str len ) GetPath: html ;M
  :M GetLocationURL: ( -- str len ) GetLocationURL: html ;M
  :M GetLocationName: ( -- str len ) GetLocationName: html ;M
  :M Busy?: ( -- flag ) Busy?: html ;M
  :M GoHome: ( -- ) GoHome: html ;M
  :M GoSearch: ( -- ) GoSearch: html ;M
  :M GoForward: ( -- ) GoForward: html ;M
  :M GoBack: ( -- ) GoBack: html ;M
  :M Refresh: ( -- ) Refresh: html ;M
  :M Stop: ( -- ) Stop: html ;M
  :M GoURL: ( str len -- ) GoURL: html ;M

;class

BrowserWin bwin
start: bwin
\ gohome: bwin
s" www.win32forth.org" GoURL: bwin
\ and you should have a browser window at your home page

--- NEW FILE: PDFControl.F ---
\ Acrobat PDF Control
\ Thomas Dixon

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

\s
\ Example:
\ Create a simple pdf window

:class PDFwin <super window
  PDFControl pdf

  :M On_Init: ( -- )
     On_Init: super
     self Start: pdf ;M

  :M On_Size: ( h m w -- ) 2drop drop autosize: pdf ;M

  :M LoadFile: ( str len -- flag ) LoadFile: pdf ;M
  :M SetPage: ( n -- ) SetPage: pdf ;M
  :M gotoFirstPage: ( -- ) gotoFirstPage: pdf ;M
  :M gotoLastPage: ( -- ) gotoLastPage: pdf ;M
  :M gotoNextPage: ( -- ) gotoNextPage: pdf ;M
  :M gotoPreviousPage: ( -- ) gotoPreviousPage: pdf ;M
  :M goForward: ( -- ) goForward: pdf ;M
  :M goBack: ( -- ) goBack: pdf ;M

  :M Print: ( -- ) Print: pdf ;M
  :M PrintWithDialog: ( -- ) PrintWithDialog: pdf ;M
  :M PrintPages: ( n n -- ) PrintPages: pdf ;M
  :M PrintPagesFit: ( flag n n -- ) PrintPagesFit: pdf ;M
  :M PrintAll: ( -- ) PrintAll: pdf ;M
  :M PrintAllFit: ( bool -- ) PrintAllFit: pdf ;M

  :M SetZoom: ( float -- ) SetZoom: pdf ;M
  :M SetZoomScroll: ( float float float -- ) SetZoomScroll: pdf ;M
  :M SetViewRect: ( float float float float -- ) SetViewRect: pdf ;M

  :M SetPageMode: ( str len -- ) SetPageMode: pdf ;M
  :M SetLayoutMode: ( str len -- ) SetLayoutMode: pdf ;M
  :M SetNamedDest: ( str len -- ) SetNamedDest: pdf ;M

  :M SetShowToolbar: ( flag -- ) SetShowToolbar: pdf ;M
  :M SetShowScrollbars: ( flag -- ) SetShowScrollbars: pdf ;M

  :M Aboutbox: ( -- ) Aboutbox: pdf ;M
;class

pdfwin pwin
start: pwin
s" doc\Forth_Primer.pdf" Prepend<home>\ loadfile: pwin drop

\ This should load a pdf file and display it in a window

\ 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

--- NEW FILE: FCOM.F ---
\ Component Object Module Interface for Win32forth
\ Tom Dixon

anew -FCOM.f

internal
external

winlibrary OLE32.DLL

1 proc CoInitialize
5 proc CoCreateInstance
6 proc MultiByteToWideChar
8 proc WideCharToMultiByte
2 proc CLSIDFromProgID
2 proc StringFromCLSID
2 proc CLSIDFromString

[...1059 lines suppressed...]
\    3 0  IMethod IQueryInterface ( ppv riid -- hres )
\    1 1  IMethod IAddRef ( -- refs )
\    1 2  IMethod IReleaseRef (  -- refs )
\  Close-Interface

 \ you can do the same with structures, but there are better ways to do 
 \ structures.

 \ My primary purpose in writing this was to make interfacing to COM just as
 \ easy as using a dll (if not more so).  I tried to make it fast, which may
 \ have lost some of the readability.  This only supports early-binding.  This
 \ shouldn't be a problem, because nearly every component out there has a "dual"
 \ interface anyway.
))

\ 2 5 typelib {00000205-0000-0010-8000-00AA006D2EA4} 
\ 1 0 typelib {CA8A9783-280D-11CF-A24D-444553540000}

\ IDispatch comiface disp
\ disp IDispatch 1 0 RecordSet CoCreateInstance .

Thread: [Win32forth-cvs] win32forth/src/lib AXControl.F,NONE,1.1 FCOM.F,NONE,1.1 FlashControl.F,NONE,1.1 HTM

win32forth-cvs