[plt-scheme] Another MysterX patch: GetActiveObject functionality

Thanks, it works over here :-)

   F

Matthew Flatt wrote:
> 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