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