[plt-scheme] Another MysterX patch: GetActiveObject functionality

[Filipe Cabecinhas]

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
-------------- next part --------------
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);