[plt-scheme] Another MysterX patch: GetActiveObject functionality

I've applied this patch and also added documentation in SVN. I didn't
try running or compiling anything (other than docs), so let me know if
it's not ok.

Thanks for the patch!
Matthew

At Mon, 19 Jan 2009 15:39:31 +0000, Filipe Cabecinhas wrote:
> Hi all,
> 
> I've made a small MysterX patch to add GetActiveObject functionality. 
> With this patch, if you want to get hold of an Excel.Application object 
> (for example), you don't have to go to the trouble to create one of 
> those objects if Excel is running (and it will take a small fraction of 
> the time).
> 
> I'm using MysterX to automate AutoCAD through MzScheme and AutoCAD takes 
> around 1 minute (or more) to start using cci/coclass. For what I'm 
> doing, I can just take the running AutoCAD application, and that (with 
> GetActiveObject) will take only 0.5 seconds ;-)
> 
> This patch adds two functions:
> com-get-active-object-from-coclass
> and its short name: cgao/coclass
> I can live without the short name, I just thought about abbreviating it 
> like cci/coclass.
> 
> Regards,
> 
>    F
> Index: collects/mysterx/mysterx.ss
> ===================================================================
> --- collects/mysterx/mysterx.ss	(revision 13203)
> +++ collects/mysterx/mysterx.ss	(working copy)
> @@ -54,6 +54,8 @@
>      cci/coclass
>      cocreate-instance-from-progid
>      cci/progid
> +    com-get-active-object-from-coclass
> +    gao/coclass
>      coclass
>      progid
>      set-coclass!
> @@ -111,6 +113,8 @@
>    (define cci/coclass cocreate-instance-from-coclass)
>    (define cocreate-instance-from-progid mxprims:cocreate-instance-from-progid)
>    (define cci/progid cocreate-instance-from-progid)
> +  (define com-get-active-object-from-coclass mxprims:com-get-active-object-
> from-coclass)
> +  (define gao/coclass com-get-active-object-from-coclass)
>    (define coclass mxprims:coclass)
>    (define progid mxprims:progid)
>    (define set-coclass! mxprims:set-coclass!)
> Index: collects/mysterx/private/mxmain.ss
> ===================================================================
> --- collects/mysterx/private/mxmain.ss	(revision 13203)
> +++ collects/mysterx/private/mxmain.ss	(working copy)
> @@ -39,6 +39,7 @@
>     progid->html
>     cocreate-instance-from-coclass
>     cocreate-instance-from-progid
> +   com-get-active-object-from-coclass
>     coclass
>     progid
>     set-coclass!
> @@ -324,6 +325,7 @@
>    (define progid->html #f)
>    (define cocreate-instance-from-coclass #f)
>    (define cocreate-instance-from-progid #f)
> +  (define com-get-active-object-from-coclass #f)
>    (define coclass #f)
>    (define progid #f)
>    (define set-coclass! #f)
> Index: src/mysterx/mysterx.cxx
> ===================================================================
> --- src/mysterx/mysterx.cxx	(revision 13203)
> +++ src/mysterx/mysterx.cxx	(working copy)
> @@ -151,6 +151,7 @@
>    { mx_com_release_object,"com-release-object",1,1 },
>    { mx_com_add_ref,"com-add-ref",1,1 },
>    { mx_com_ref_count,"com-ref-count",1,1 },
> +  { mx_com_get_active_object_from_coclass,"com-get-active-object-from-
> coclass",1,1 },
>  
>    // browsers
>  
> @@ -901,6 +902,64 @@
>                                 location, machine);
>  }
>  
> +Scheme_Object *do_get_active_object(CLSID clsId, LPCTSTR name)
> +{
> +  HRESULT hr;
> +  IUnknown *pUnk;
> +  IDispatch *pIDispatch;
> +  MX_COM_Object *com_object;
> +
> +  hr = GetActiveObject(clsId, NULL, &pUnk);
> +
> +  if (hr != ERROR_SUCCESS) {
> +    char errBuff[2048];
> +    sprintf(errBuff,
> +            "com-get-active-object-from-coclass: "
> +            "Unable to get instance of %s",
> +            name);
> +    codedComError(errBuff, hr);
> +  }
> +
> +  hr = pUnk->QueryInterface(IID_IDispatch, (void **)&pIDispatch);
> +
> +  if (hr != ERROR_SUCCESS) {
> +    char errBuff[2048];
> +    sprintf(errBuff,
> +            "com-get-active-object-from-coclass: "
> +            "Unable to get instance of %s",
> +            name);
> +    codedComError(errBuff, hr);
> +  }
> +
> +  com_object = (MX_COM_Object *)scheme_malloc_tagged(sizeof(MX_COM_Object));
> +
> +  com_object->so.type = mx_com_object_type;
> +  com_object->pIDispatch = pIDispatch;
> +  com_object->pITypeInfo = NULL;
> +  com_object->clsId = clsId;
> +  com_object->pEventTypeInfo = NULL;
> +  com_object->pIConnectionPoint = NULL;
> +  com_object->pISink = NULL;
> +  com_object->connectionCookie = (DWORD)0;
> +  com_object->released = FALSE;
> +  com_object->types = NULL;
> +
> +  mx_register_com_object((Scheme_Object *)com_object, pIDispatch);
> +
> +  return (Scheme_Object *)com_object;
> +}
> +
> +Scheme_Object *mx_com_get_active_object_from_coclass(int argc, Scheme_Object 
> **argv)
> +{
> +  LPCTSTR coclass;
> +
> +  GUARANTEE_STRSYM("com-get-active-object-from-coclass", 0);
> +
> +  coclass = schemeToText(argv[0]);
> +
> +  return do_get_active_object(getCLSIDFromCoClass(coclass), coclass);
> +}
> +
>  Scheme_Object *mx_set_coclass(int argc, Scheme_Object **argv)
>  {
>    CLSID clsId;
> @@ -4211,7 +4270,8 @@
>    retval = retvalVariantToSchemeObject(&retvalVa);
>  
>    // all pointers are 32 bits, choose arbitrary one
> -  if (retvalVa.vt != VT_VOID)
> +  if (retvalVa.vt != VT_VOID &&
> +      retvalVa.vt != VT_HRESULT)
>      free(retvalVa.pullVal);
>  
>    return retval;
> Index: src/mysterx/mysterx.h
> ===================================================================
> --- src/mysterx/mysterx.h	(revision 13203)
> +++ src/mysterx/mysterx.h	(working copy)
> @@ -343,6 +343,7 @@
>  MX_PRIM_DECL(mx_com_event_type);
>  MX_PRIM_DECL(mx_cocreate_instance_from_coclass);
>  MX_PRIM_DECL(mx_cocreate_instance_from_progid);
> +MX_PRIM_DECL(mx_com_get_active_object_from_coclass);
>  MX_PRIM_DECL(mx_coclass);
>  MX_PRIM_DECL(mx_progid);
>  MX_PRIM_DECL(mx_set_coclass);
> _________________________________________________
>   For list-related administrative tasks:
>   http://list.cs.brown.edu/mailman/listinfo/plt-scheme