[Win32forth-cvs] win32forth/src/tools AXConList.F,NONE,1.1 AxConInfo.f,NONE,1.1

[Dirk B. <db...@us...>]

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

Added Files:
	AXConList.F AxConInfo.f 
Log Message:
- Moved the demo code for the new ActiveX controls into seperate files in the Demos-Folder
- Added two new tool's for exploring ActiveX controls
- Added some notes about the new COM and ActiveX support to the release notes.

--- NEW FILE: AxConInfo.f ---
\ $Id: AxConInfo.f,v 1.1 2005/09/18 11:10:31 dbu_de Exp $

\ AxConInfo.f
\ Get informations about an ActiveX control from registry and
\ display them.
\ Written by Dirk Busch

cr .( Loading ActiveX control info tool)

anew -AxConInfo.f

needs fcom

internal

in-system

create org_BaseReg 260 allot
create org_ProgReg 260 allot
0 value org_regBaseKey
0 value org_regAccessMask

: SaveReg       ( -- )
        BaseReg count org_BaseReg place
        ProgReg count org_ProgReg place
        regBaseKey to org_regBaseKey
        regAccessMask to org_regAccessMask
        ;

: RestoreReg    ( -- )
        org_BaseReg count BaseReg place
        org_ProgReg count ProgReg place
        org_regBaseKey to regBaseKey
        org_regAccessMask to regAccessMask
        ;

: tab-type      ( addr len -- )
        tab-size >r 32 to tab-size
        tab type
        r> to tab-size
        ;

: RegGetAxInfoValue     ( addr1 len1 addr2 len2 -- addr3 len3 )
        s" CLSID\" BaseReg place
        2swap BaseReg +place \ guid
        s" \" BaseReg +place
        BaseReg +place \ section
        ProgReg off
        s" "  s" " RegGetString ;

: (.AxInfoValue) ( addr len -- )
        2dup type ." : "
        RegGetAxInfoValue
        tab-type ;

: (.AxInfo)     ( addr len -- )
        cr ." GUID: " 2dup tab-type
        cr 2dup ." ClassName" s" " (.AxInfoValue)
        cr 2dup s" ProgID"  (.AxInfoValue)
        cr 2dup s" TypeLib" (.AxInfoValue)
        cr 2dup s" Version" (.AxInfoValue)
        cr      s" VersionIndependentProgID" (.AxInfoValue)
        cr ;

: AxInitReg     ( -- )
        SaveReg
        HKEY_CLASSES_ROOT to regBaseKey
        KEY_READ          to regAccessMask ;

: AxRestoreReg  ( -- )
        RestoreReg ;

: /get  { str len char \ str1 len1 -- str len str1 len1 } \ search for char in string, return string till char and rest of string after char
        str len char scan  to len1 to str1
        len1 0>
        if   len len1 - to len
             str1 1+ to str1
             len1 1- ?dup if to len1 then
        then str len str1 len1 ;

: guid>version ( addr len -- major minor )
        s" Version" RegGetAxInfoValue ?dup
        if   [char] . /get number? drop d>s >r number? drop d>s r>
        else drop 1 0
        then ;

: guid>typelib ( addr len -- addr len )
        s" TypeLib" RegGetAxInfoValue ;

external

: GetAxVersion  ( "GUID" -- major minor )
        AxInitReg
        parse-word ?dup if guid>version else drop 0 0 then
        RestoreReg ;

: GetAxTypeLib  ( "GUID" -- addr len )
        AxInitReg
        parse-word ?dup if guid>typelib else drop s" " then
        RestoreReg ;

internal

[undefined] (Guid,) [if]
: (Guid,)       ( addr len -- ) \ comments in a guid
        Base @ >r HEX dup 38 <> abort" Invalid Guid Length"
        1 /string  2dup ascii - scan 2dup >r >r nip - hatoi ,
        r> r> ascii - skip 2dup ascii - scan 2dup >r >r nip - hatoi w,
        r> r> ascii - skip 2dup ascii - scan 2dup >r >r nip - hatoi w,
        r> r> ascii - skip 2dup drop 2 0 do dup i 2 * + 2 hatoi c, loop drop
        ascii - scan ascii - skip drop 6 0 do dup i 2 * + 2 hatoi c, loop drop r> base ! ;
[then]

: (guid_typelib) ( major minor addr len -- ) \ load a type library for given GUID into the list
        2>r here typelibhead dup @ , !
        here dup >r 0 , here 0 , 2swap swap here r> 2r> rot >r (Guid,) LoadRegTypeLib
        abort" Error Loading Type Library"
        r> dup cell+ swap UCOM ITypeLib GetTypeComp abort" Error Getting TypeComp" ;

external

: guid_typelib  ( "GUID" -- ) \ load a type library for given GUID into the list
        parse-word ?dup
        if   AxInitReg
             2dup guid>version 2swap guid>typelib (guid_typelib)
             RestoreReg
        else drop abort" GUID missing"
        then ;

: .AxInfo       ( "GUID" -- )
        cr cr ." ActiveX Control info"
        parse-word
        ?dup
        if   AxInitReg
             2dup (.AxInfo)
             2dup guid>version 2swap guid>typelib (guid_typelib)
             cr ." CoClasses:"  tab CoClasses
             cr cr ." Interfaces:" tab Interfaces
             cr cr ." Structures:" tab Structures
             cr cr ." ComConsts:"  tab ComConsts
             AxRestoreReg
        else drop
        then cr ;

module

in-application

cr .( Usage:   .axinfo <guid>)
cr .( Example: .axinfo {0002DF01-0000-0000-C000-000000000046})

--- NEW FILE: AXConList.F ---
\ $Id: AXConList.F,v 1.1 2005/09/18 11:10:31 dbu_de Exp $

\ Dump all installed ActiveX Controls to the console
\ Thomas Dixon

anew -AXConList.f

needs fcom \ include the com library

internal

in-system

\ define some guids
UUID StdComponentCategoriesMgr {0002E005-0000-0000-C000-000000000046}
UUID AXControl {40FC6ED4-2438-11cf-A3DB-080036F12502}

\ I couldn't find a typelibrary for these interfaces, so I must statically
\ define them.  There are only two, so it's not bad.

IUnknown Interface ICatInformation {0002E013-0000-0000-C000-000000000046}
ICatInformation Open-Interface
  3 3  IMethod EnumCategories ( *ppenumCategoryInfo lcid -- hres )
  4 4  IMethod GetCategoryDesc ( *pszDesc lcid rcatid -- hres )
  6 5  IMethod EnumClassesOfCategories ( *ppenumClsid rgcatidReq cReq rgcatidImpl cImp -- hres )
  6 6  IMethod IsClassOfCategories ( rgcatidReq cReq rgcatidImpl n clsid -- hres )
  3 7  IMethod EnumImplCategoriesOfClass ( *ppenumCatid rclsid -- hres )
  3 8  IMethod EnumReqCategoriesOfClass ( *ppenumCatid clsid -- hres )
Close-Interface

IUnknown Interface IEnumGUID {0002E000-0000-0000-C000-000000000046}
IEnumGUID Open-Interface
  4 3  IMethod Next ( *n *rgelt celt -- hres )
  2 4  IMethod Skip ( *celt -- hres )
  1 5  IMethod Reset ( -- hres )
  2 6  IMethod Clone ( *ppenum -- hres )
Close-Interface

\ Make a few interfaces
ICatInformation comiface catinfo
IEnumGUID comiface enumg

create tempguid 16 allot \ temporary guid buffer

external

\ word to list controls
: .axcontrols ( -- ) cr ." Listing all ActiveX controls:" cr
  catinfo ICatInformation 1 0 StdComponentCategoriesMgr CoCreateInstance
    abort" Unable to initialize Control Manager!"
  enumg pad 0 axcontrol 1 catinfo EnumClassesOfCategories drop
  enumg reset drop
  begin 0 tempguid 1 enumg next 0= while

    pad tempguid StringFromCLSID 0=
    if ."   " pad @ zunicount unitype then

    pad 1 tempguid call OleRegGetUserType 0=
    if ."   " pad @ zunicount unitype then

    cr repeat
  enumg IReleaseref drop
  catinfo IReleaseref drop ;


MODULE

.axcontrols

in-application