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_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_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);
}
////////////////////////////////////////////////////////////////////////
//
// Client Side Errors - translate a COM failure to a Python exception
//
////////////////////////////////////////////////////////////////////////
PyObject *PyCom_BuildPyException(HRESULT errorhr, IUnknown *pUnk /* = NULL */, REFIID iid /* = IID_NULL */)
{
PyObject *obEI = NULL;
TCHAR scodeStringBuf[512];
GetScodeString(errorhr, scodeStringBuf, sizeof(scodeStringBuf)/sizeof(scodeStringBuf[0]));
#ifndef MS_WINCE // WINCE doesnt appear to have GetErrorInfo() - compiled, but doesnt link!
if (pUnk != NULL) {
assert(iid != IID_NULL); // If you pass an IUnknown, you should pass the specific IID.
// See if it supports error info.
ISupportErrorInfo *pSEI;
HRESULT hr;
Py_BEGIN_ALLOW_THREADS
hr = pUnk->QueryInterface(IID_ISupportErrorInfo, (void **)&pSEI);
if (SUCCEEDED(hr)) {
hr = pSEI->InterfaceSupportsErrorInfo(iid);
pSEI->Release(); // Finished with this object
}
Py_END_ALLOW_THREADS
if (SUCCEEDED(hr)) {
IErrorInfo *pEI;
Py_BEGIN_ALLOW_THREADS
hr=GetErrorInfo(0, &pEI);
Py_END_ALLOW_THREADS
if (hr==S_OK) {
obEI = PyCom_PyObjectFromIErrorInfo(pEI, errorhr);
PYCOM_RELEASE(pEI);
}
}
}
void
COMError(HRESULT hr)
{
TCHAR buf[512];
GetScodeString(hr, buf, sizeof(buf)/sizeof(buf[0]));
/*
PROBLEM buf
ERROR;
*/
SEXP e;
PROTECT(e = allocVector(LANGSXP, 3));
SETCAR(e, Rf_install("COMStop"));
SETCAR(CDR(e), mkString(buf));
SETCAR(CDR(CDR(e)), ScalarInteger(hr));
Rf_eval(e, R_GlobalEnv);
UNPROTECT(1); /* Won't come back to here. */
}
SEXP
getArray(SAFEARRAY *arr, int dimNo, int numDims, long *indices)
{
long lb, ub, n, i;
HRESULT status;
SEXP ans;
int rtype = -1;
status = SafeArrayGetLBound(arr, dimNo, &lb);
if(FAILED(status)) {
TCHAR buf[512];
GetScodeString(status, buf, sizeof(buf)/sizeof(buf[0]));
PROBLEM "Can't get lower bound of array: %s", buf
ERROR;
}
status = SafeArrayGetUBound(arr, dimNo, &ub);
if(FAILED(status)) {
TCHAR buf[512];
GetScodeString(status, buf, sizeof(buf)/sizeof(buf[0]));
PROBLEM "Can't get upper bound of array: %s", buf
ERROR;
}
n = ub-lb+1;
PROTECT(ans = NEW_LIST(n));
for(i = 0; i < n; i++) {
SEXP el;
indices[dimNo - 1] = lb + i;
if(dimNo == 1) {
VARIANT variant;
VariantInit(&variant);
status = SafeArrayGetElement(arr, indices, &variant);
if(FAILED(status)) {
TCHAR buf[512];
GetScodeString(status, buf, sizeof(buf)/sizeof(buf[0]));
PROBLEM "Can't get element %d of array %s", (int) indices[dimNo-1], buf
ERROR;
}
el = R_convertDCOMObjectToR(&variant);
} else {
el = getArray(arr, dimNo - 1, numDims, indices);
}
if(i == 0)
rtype = TYPEOF(el);
else if(rtype != -1 ){
if(TYPEOF(el) != rtype)
rtype = -1;
}
SET_VECTOR_ELT(ans, i, el);
}
if(numDims == 1 && rtype != -1) {
switch(rtype) {
case INTSXP:
case LGLSXP:
case REALSXP:
case STRSXP:
ans = UnList(ans);
break;
}
}
UNPROTECT(1);
return(ans);
}
