SEXP
R_create(SEXP className)
{
DWORD context = CLSCTX_SERVER;
SEXP ans;
CLSID classId;
IID refId = IID_IDispatch;
IUnknown *unknown, *punknown = NULL;
HRESULT hr = R_getCLSIDFromString(className, &classId);
if(FAILED(hr))
COMError(hr);
SCODE sc = CoCreateInstance(classId, punknown, context, refId, (void **) &unknown);
if(FAILED(sc)) {
TCHAR buf[512];
GetScodeString(sc, buf, sizeof(buf)/sizeof(buf[0]));
PROBLEM "Failed to create COM object: %s", buf
ERROR;
}
//Already AddRef in the CoCreateInstance
// so no need to do it now ( unknown->AddRef())
ans = R_createRCOMUnknownObject((void *) unknown, "COMIDispatch");
return(ans);
}
SEXP
R_connect(SEXP className, SEXP raiseError)
{
IUnknown *unknown = NULL;
HRESULT hr;
SEXP ans = R_NilValue;
CLSID classId;
if(R_getCLSIDFromString(className, &classId) == S_OK) {
hr = GetActiveObject(classId, NULL, &unknown);
if(SUCCEEDED(hr)) {
void *ptr;
hr = unknown->QueryInterface(IID_IDispatch, &ptr);
ans = R_createRCOMUnknownObject((void *) ptr, "COMIDispatch");
} else {
if(LOGICAL(raiseError)[0]) {
/* From COMError.cpp - COMError */
TCHAR buf[512];
GetScodeString(hr, buf, sizeof(buf)/sizeof(buf[0]));
PROTECT(ans = mkString(buf));
SET_CLASS(ans, mkString("COMErrorString"));
UNPROTECT(1);
return(ans);
} else
return(R_NilValue);
}
} else {
PROBLEM "Couldn't get clsid from the string"
WARN;
}
return(ans);
}
SEXP
R_connect_hWnd(SEXP className, SEXP excel_hWnd, SEXP raiseError)
{
IUnknown *unknown = NULL;
HRESULT hr;
SEXP ans = R_NilValue;
CLSID classId;
LONG_PTR l_hwnd;
HWND temp_hwdn;
if(R_getCLSIDFromString(className, &classId) == S_OK) {
l_hwnd = (LONG_PTR)INTEGER(excel_hWnd)[0];
temp_hwdn = (HWND)l_hwnd;
hr = AccessibleObjectFromWindow(temp_hwdn, OBJID_NATIVEOM, classId, (void**)&unknown);
if(hr == S_OK) {
void *ptr;
hr = unknown->QueryInterface(IID_IDispatch, &ptr);
ans = R_createRCOMUnknownObject((void *) ptr, "COMIDispatch");
} else {
if(LOGICAL(raiseError)[0]) {
/* From COMError.cpp - COMError */
TCHAR buf[512];
GetScodeString(hr, buf, sizeof(buf)/sizeof(buf[0]));
PROTECT(ans = mkString(buf));
SET_CLASS(ans, mkString("COMErrorString"));
UNPROTECT(1);
return(ans);
} else
return(R_NilValue);
}
} else {
PROBLEM "Couldn't get clsid from the string"
WARN;
}
return(ans);
}
SEXP
R_convertDCOMObjectToR(VARIANT *var)
{
SEXP ans = R_NilValue;
VARTYPE type = V_VT(var);
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("Converting VARIANT to R %d\n", V_VT(var));
#endif
if(V_ISARRAY(var)) {
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("Finishing convertDCOMObjectToR - convert array\n");
#endif
return(convertArrayToR(var));
} else if(V_VT(var) == VT_DISPATCH || (V_ISBYREF(var) && ((V_VT(var) & (~ VT_BYREF)) == VT_DISPATCH)) ) {
IDispatch *ptr;
if(V_ISBYREF(var)) {
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("BYREF and DISPATCH in convertDCOMObjectToR\n");
#endif
IDispatch **tmp = V_DISPATCHREF(var);
if(!tmp)
return(ans);
ptr = *tmp;
} else
ptr = V_DISPATCH(var);
//xxx
if(ptr)
ptr->AddRef();
ans = R_createRCOMUnknownObject((void*) ptr, "COMIDispatch");
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("Finished convertDCOMObjectToR COMIDispatch\n");
#endif
return(ans);
}
if(V_ISBYREF(var)) {
VARTYPE rtype = type & (~ VT_BYREF);
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("ISBYREF() in convertDCOMObjectToR: ref type %d\n", rtype);
#endif
if(rtype == VT_BSTR) {
BSTR *tmp;
const char *ptr = "";
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("BYREF and BSTR convertDCOMObjectToR (scalar string)\n");
#endif
tmp = V_BSTRREF(var);
if(tmp)
ptr = FromBstr(*tmp);
ans = R_scalarString(ptr);
return(ans);
} else if(rtype == VT_BOOL || rtype == VT_I4 || rtype == VT_R8){
return(createVariantRef(var, rtype));
} else {
fprintf(stderr, "Unhandled by-reference conversion type %d\n", V_VT(var));fflush(stderr);
return(R_NilValue);
}
}
switch(type) {
case VT_BOOL:
ans = R_scalarLogical( (Rboolean) (V_BOOL(var) ? TRUE : FALSE));
break;
case VT_UI1:
case VT_UI2:
case VT_UI4:
case VT_UINT:
VariantChangeType(var, var, 0, VT_I4);
ans = R_scalarReal((double) V_I4(var));
break;
case VT_I1:
case VT_I2:
case VT_I4:
case VT_INT:
VariantChangeType(var, var, 0, VT_I4);
ans = R_scalarInteger(V_I4(var));
break;
case VT_R4:
case VT_R8:
case VT_I8:
VariantChangeType(var, var, 0, VT_R8);
ans = R_scalarReal(V_R8(var));
break;
case VT_CY:
case VT_DATE:
case VT_HRESULT:
case VT_DECIMAL:
VariantChangeType(var, var, 0, VT_R8);
ans = numberFromVariant(var, type);
break;
case VT_BSTR:
{
char *ptr = FromBstr(V_BSTR(var));
ans = R_scalarString(ptr);
}
break;
case VT_UNKNOWN:
{
IUnknown *ptr = V_UNKNOWN(var);
//xxx
if(ptr)
ptr->AddRef();
ans = R_createRCOMUnknownObject((void**) ptr, "COMUnknown");
}
break;
case VT_EMPTY:
case VT_NULL:
case VT_VOID:
return(R_NilValue);
break;
/*XXX Need to fill these in */
case VT_RECORD:
case VT_FILETIME:
case VT_BLOB:
case VT_STREAM:
case VT_STORAGE:
case VT_STREAMED_OBJECT:
/* case LPSTR: */
case VT_LPWSTR:
case VT_PTR:
case VT_ERROR:
case VT_VARIANT:
case VT_CARRAY:
case VT_USERDEFINED:
default:
fprintf(stderr, "Unhandled conversion type %d\n", V_VT(var));fflush(stderr);
//XXX this consumes the variant. So the variant clearance in Invoke() does it again!
ans = createRVariantObject(var, V_VT(var));
}
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("Finished convertDCOMObjectToR\n");
#endif
return(ans);
}