COM を学ぶ(11) : HaskellでExcel(ワイド文字列バージョン)

Haskell から COM を呼ぶ場合 HaskellからSJISに変換した後に MultiByteToWideChar、 WideCharToMultiByteを使用していましたが、Haskell はUcs4、COMはUTF16を使っていますので、日本語で使う分には文字コードを変換する必要はありません。
SysAllocString を使って BSTR を作り、COMを操作するバージョンです。
COMについてはRubyの記事ですが、以下が参考になります

• Win32OLE 活用法 【第 1 回】 Win32OLE ことはじめ
• Win32OLE 活用法 【第 2 回】 Excel
• Win32OLE 活用法 【第 3 回】 ADODB
• Win32OLE 活用法 【第 4 回】 Adobe Illustrator
• Win32OLE 活用法 【第 5 回】 Outlook
• Win32OLE 活用法 【第 6 回】 Web 自動巡回
• Win32OLE 活用法 【第 7 回】 ほかの言語での COM

C言語とWindows APIを用いたプログラミングのために多数の技術が提供されています。

• EternalWindows COM / オートメーション

• win32ole.hs

{-# LANGUAGE ForeignFunctionInterface #-}
-- ghc --make win32ole.hs  winole.c -lole32 -loleaut32 -luuid  -o ole
module Main where

import Foreign.Ptr           (Ptr)
import Foreign.C.String      (CWString, newCWString, withCWString, peekCWString)
import Foreign.C.Types       (CLong, CInt)
import Foreign.Marshal.Alloc (free)
import Cinnamon.Ucs          (ucs4ToSjis)
import Control.Applicative   ((<$>))

data IDispatch = IDispatch

main = do
    cOleInitialize 0
    pExl          <- instanceNew        "Excel.Application"
    cVersString   <- readProperty pExl  "Version"
    (("Version:"++) <$> ucs4ToSjis <$> peekCWString cVersString) >>= putStrLn
    cSysFreeString cVersString

    workBooks     <- propertyGet_S pExl "Workbooks"
    cFullFileName <- getFullPathName    "sample2.xls"
    workBooksOpen workBooks cFullFileName
    free cFullFileName

    activeWBook   <- propertyGet_S   pExl        "ActiveWorkbook"
    workSheets    <- propertyGet_S   activeWBook "Worksheets"
    sheet         <- propertyGet_S_N workSheets  "Item"  2    -- 2番目のシート
    cell          <- propertyGet_S_S sheet       "Range" "C1" -- C1 セル取得
    propertyPut_S_S cell "Value" "日本語"                     -- セルに書き込み
    cwString   <- readProperty cell "Value"                   -- セルデータ取得
    (("Version:"++) <$> ucs4ToSjis <$> peekCWString cwString) >>= putStrLn -- => 日本語
    cSysFreeString cwString

    mapM_ method_S       [(activeWBook,"Save"),(workBooks,"Close"),(pExl, "Quit")]
    mapM_ cReleaseObject [cell, sheet, workSheets, activeWBook, workBooks, pExl]
    cOleUninitialize

instanceNew :: String -> IO (Ptr IDispatch)
instanceNew name = withCWString name cInstanceNew

readProperty :: (Ptr IDispatch) -> String -> IO (CWString)
readProperty pDisp name = withCWString name (cReadProperty pDisp)

propertyGet_S :: (Ptr IDispatch) -> String -> IO (Ptr IDispatch)
propertyGet_S pDisp name = withCWString name (cPropertyGet_S pDisp)

getFullPathName :: String -> IO (CWString)
getFullPathName fName =  withCWString fName cgetFullPathName

propertyGet_S_N :: (Ptr IDispatch) -> String -> CLong -> IO (Ptr IDispatch)
propertyGet_S_N pDisp name n = withCWString name $ \x -> cPropertyGet_S_N pDisp x  n

propertyGet_S_S :: (Ptr IDispatch) -> String -> String -> IO (Ptr IDispatch)
propertyGet_S_S pDisp command param = withCWString command (\x ->withCWString param (cPropertyGet_S_S pDisp x))

propertyPut_S_S :: (Ptr IDispatch) -> String -> String -> IO ()
propertyPut_S_S pDisp name value = withCWString name (\x ->withCWString value ( cPropertyPut_S_S pDisp x))

method_S :: ((Ptr IDispatch), String) -> IO ()
method_S (pDisp, name) = withCWString name (cMethod_S pDisp)

workBooksOpen  :: (Ptr IDispatch) -> CWString -> IO ()
workBooksOpen pDisp fileName =  withCWString "Open" (\x -> cMethod_S_S pDisp x fileName)

-- C の関数を呼ぶための定義
foreign import ccall   "InstanceNew"            cInstanceNew       :: CWString -> IO (Ptr IDispatch)
foreign import ccall   "getFullPathName"        cgetFullPathName   :: CWString -> IO CWString
foreign import ccall   "PropertyGet_S"          cPropertyGet_S     :: (Ptr IDispatch) -> CWString -> IO (Ptr IDispatch)
foreign import ccall   "PropertyGet_S_S"        cPropertyGet_S_S   :: (Ptr IDispatch) -> CWString -> CWString -> IO (Ptr IDispatch)
foreign import ccall   "PropertyGet_S_N"        cPropertyGet_S_N   :: (Ptr IDispatch) -> CWString -> CLong -> IO (Ptr IDispatch)
foreign import ccall   "PropertyPut_S_S"        cPropertyPut_S_S   :: (Ptr IDispatch) -> CWString -> CWString -> IO ()
foreign import ccall   "ReadProperty"           cReadProperty      :: (Ptr IDispatch) -> CWString -> IO CWString
foreign import ccall   "Method_S_S"             cMethod_S_S        :: (Ptr IDispatch) -> CWString -> CWString -> IO ()
foreign import ccall   "Method_S"               cMethod_S          :: (Ptr IDispatch) -> CWString -> IO ()
foreign import ccall   "ReleaseObject"          cReleaseObject     :: (Ptr IDispatch) -> IO ()
foreign import ccall   "stdlib.h free"          cfree              :: CWString -> IO ()
foreign import ccall   "stdlib.h free"          cDispatchFree      :: (Ptr IDispatch) -> IO ()
foreign import stdcall "windows.h SysFreeString"  cSysFreeString   :: CWString -> IO ()
foreign import stdcall "ole2.h OleInitialize"     cOleInitialize   :: CInt -> IO ()
foreign import stdcall "ole2.h OleUninitialize"   cOleUninitialize :: IO ()

• 参考：C++ アプリケーションではなく C アプリケーションから OLE オートメーションを使用する方法
• winole.c

#include <stdio.h>
#include <malloc.h>
#include <windows.h>
#include <wchar.h>

// 参考 ruby.h
#define ALLOCA_N(type,n) (type*)alloca(sizeof(type)*(n))


IDispatch *mallocDispatch(){
    return (struct IDispatch *)malloc( sizeof(struct IDispatch) );
}
// http://eternalwindows.jp/
// http://marupeke296.com/IKDADV_CPP_VARIANT.html
// oleauto.h:#define V_ISBYREF(X) (V_VT(X)&VT_BYREF)
// oleauto.h:45:#define V_VT(X) ((X)->vt)
// wtypes.h:121:     VT_BYREF=0x4000,
// oleauto.h:76:#define V_DISPATCHREF(X) V_UNION(X,ppdispVal)
// oleauto.h:75:#define V_DISPATCH(X) V_UNION(X,pdispVal)
// oleauto.h:44:#define V_UNION(X,Y) ((X)->Y)
// IDispatch **ppdispVal;
// IDispatch *pdispVal;
IDispatch *Variant2Dispatch(VARIANT *pVariant){
  if (V_ISBYREF(pVariant))
    return (*V_DISPATCHREF(pVariant));  // pVariant->ppdispVal
  else
    return (V_DISPATCH(pVariant));      // pVariant->pdispVal
}

// 常にインタフェーステーブルへアクセスする。
// Open,Close などのコマンドからテーブルのディスパッチIDを求め実行する。
HRESULT ComInvoke( PVOID *p, wchar_t *ComString ,VARIANTARG *param,int nArgs, USHORT wFlags, VARIANT *result){
    IDispatch   *pDisp;
    DISPID      dispID;
    HRESULT     hr;
    unsigned    short *ucPtr;
    UINT        puArgErr = 0;
    EXCEPINFO   excepinfo;
    // Win32OLE 製作過程の雑記 : invoke メソッドの引数
    // http://homepage1.nifty.com/markey/ruby/win32ole/win32ole03.html#invoke-param
    // DISPPARAMS フィールド
    // http://msdn.microsoft.com/ja-jp/library/x6828bcx%28v=VS.80%29.aspx
    DISPPARAMS  dispParams = { NULL, NULL, 0, 0 };
    dispParams.rgvarg            = param;  // 引数の配列への参照を表します。
    dispParams.rgdispidNamedArgs = NULL;   // 名前付き引数の dispID の配列(未使用)
    dispParams.cArgs             = nArgs;  // 引数の数を表します。
    dispParams.cNamedArgs        = 0;      // 名前付き引数の数 (未使用)
    // 参考:ruby win32ole.c  ole_invoke2 関数
    if (wFlags & DISPATCH_PROPERTYPUT) {
        dispParams.cNamedArgs = 1;
        dispParams.rgdispidNamedArgs    = ALLOCA_N( DISPID, 1 );
        dispParams.rgdispidNamedArgs[0] = DISPID_PROPERTYPUT;
    }

    memset( &excepinfo, 0, sizeof(EXCEPINFO));
    pDisp = (IDispatch   *)p;

    // コマンド文字列からディスパッチID取得
    ucPtr = SysAllocString( ComString );
    hr=pDisp->lpVtbl->GetIDsOfNames((IDispatch  *)pDisp, &IID_NULL, &ucPtr, 1, LOCALE_USER_DEFAULT, (DISPID*)&dispID);
    //wprintf(L"GetIDsOfNames nArgs:%d  %-10s = %04d hr:%08lx\n",  nArgs, ComString, dispID, hr);

    // ここが肝心のInvokeを実行する部分。
    VariantInit(result);
    hr = pDisp->lpVtbl->Invoke(
             pDisp,                    // 参考: Ruby付属の「OLE View」
             dispID,                   // arg1 - I4 dispidMember        [IN]
             &IID_NULL,                // arg2 - GUID riid              [IN]
             LOCALE_SYSTEM_DEFAULT,    // arg3 - UI4 lcid               [IN]
             wFlags,                   // arg4 - UI2 wFlags             [IN]
             &dispParams,              // arg5 - DISPPARAMS pdispparams [IN]
             result,                   // arg6 - VARIANT pvarResult     [OUT]
             &excepinfo,               // arg7 - EXCEPINFO pexcepinfo   [OUT]
             &puArgErr );              // arg8 - UINT puArgErr          [OUT]
     //wprintf(L"Invoke %-10s dispID:%4d hr:%08x puArgErr:%d\n",ComString, dispID, hr,puArgErr);
     SysFreeString(ucPtr);
     return hr;
}

// ProgID("Excel.Application")からCLSID({00024500-0000-0000-C000000000000046})
// を求め、CoCreateInstance APIを呼びます。
IDispatch *InstanceNew(wchar_t *ComName){
    IDispatch  *pDisp;
    BSTR       name;
    CLSID      clsid;
    HRESULT    hr=0;

    pDisp = mallocDispatch();
    name  = SysAllocString( ComName );
    hr    = CLSIDFromProgID(name, &clsid);
    // HRESULTは最上位ビットで OK ,NG を表現します。
    // FAILED は hr が 0 より小さいかどうかチェックするマクロ。
    if(FAILED(hr)) {
        hr = CLSIDFromString(name, &clsid);
    }
    hr = CoCreateInstance(&clsid, NULL, CLSCTX_INPROC_SERVER | CLSCTX_LOCAL_SERVER, &IID_IDispatch, (void **)&pDisp);
    SysFreeString(name);
    return pDisp;
}

wchar_t *Date2String(DATE date){
    wchar_t *buf;
    SYSTEMTIME st;

    VariantTimeToSystemTime(date, &st);
    buf = (wchar_t*)malloc(20 * sizeof(wchar_t));
    //swprintf(buf,L"%04d/%02d/%02d %02d:%02d:%02d",st.wYear,st.wMonth,st.wDay,st.wHour,st.wMinute,st.wSecond);
    return buf;
}
wchar_t *Number2String(long num){
    wchar_t *buf;
    buf = (wchar_t*)malloc(30 * sizeof(wchar_t));
    swprintf(buf,L"%d",num);
    return buf;
}

wchar_t *Double2String(double num){
    wchar_t *buf;
    buf = (wchar_t*)malloc(30 * sizeof(wchar_t));
    swprintf(buf,L"%f",num);
    return buf;
}

wchar_t *Variant2CWString(VARIANT *result){
    switch(V_VT(result)){
        case VT_EMPTY:
            return L"empty";
            break;
        case VT_NULL:
            return L"null";
            break;
        case VT_I2:  // short
            return Number2String((long)V_I2(result));
            break;
        case VT_I4:  // long
            return Number2String((long)V_I4(result));
            break;
        case VT_R4:  // float
            return Double2String(V_R4(result));
            break;
        case VT_R8:  // double
            return Double2String(V_R8(result));
            break;
        case VT_BOOL: //(True -1,False 0)
            return (V_BOOL(result) ? L"True" : L"False");
            break;
        case VT_BSTR:
            return (wchar_t*)(V_BSTR(result));
            break;
        case VT_DATE:
            return Date2String( V_DATE(result));
            break;
    }
}

// PropertyPut_S_S((void **)cell, L"Value",L"ほげ");
void PropertyPut_S_S(PVOID *pDisp, wchar_t *PropertyName, wchar_t *String){
    VARIANT     result;
    VARIANTARG  param[1];
    BSTR        bstr;

    bstr = SysAllocString(String);
    VariantInit(&param[0]);
    param[0].vt = VT_BSTR|VT_BYREF;
    param[0].pbstrVal = &bstr;
    ComInvoke((void **)pDisp, PropertyName, param, 1, DISPATCH_PROPERTYPUT, &result);
    VariantClear(&result);
    VariantClear(&param[0]);
    SysFreeString(bstr);
}

// GetAbsolutePathName メソッドをコールし、パス名を含めたファイル名を取得
wchar_t *GetPathName(IDispatch *fDisp, wchar_t *fileName){
    VARIANT    param, result;
    HRESULT    hr = 0;
    wchar_t *fullPathName;

    VariantInit(&param);
    param.vt      = VT_BSTR;
    param.bstrVal = SysAllocString(fileName);

    hr = ComInvoke((void **)fDisp, L"GetAbsolutePathName", &param, 1, DISPATCH_METHOD, &result);
    fullPathName  = (wchar_t*)malloc((SysStringLen(result.bstrVal)+1) * sizeof(wchar_t));
    wcscpy(fullPathName, result.bstrVal);
    SysFreeString(param.bstrVal);
    VariantClear(&param);
    VariantClear(&result);
    return fullPathName;
}
// Scripting.FileSystemObject を作りパス名を含めたファイル名を取得
// in  : fileName
// out : fullPathName
wchar_t *getFullPathName(wchar_t *fileName){
    return GetPathName(InstanceNew(L"Scripting.FileSystemObject"), fileName);
}

//   workBooks   = PropertyGet_S((void **)pExl, L"Workbooks");
IDispatch *PropertyGet_S( PVOID *parentDisp, wchar_t *ObjName){
    VARIANT    param, result;
    DISPID     dispID;
    HRESULT    hr = 0;

    VariantInit(&param);
    VariantInit(&result);
    param.vt = VT_EMPTY;
    hr = ComInvoke((void **)parentDisp, ObjName, &param, 0,DISPATCH_PROPERTYGET | DISPATCH_METHOD,&result);
    // wprintf(L"CreateNewObject   ObjName:%-14s hr:%08lx\n",ObjName,hr);
    VariantClear(&param);
    return Variant2Dispatch(&result);
}

//  sheet  = PropertyGet_S_N( (void **)workSheets, L"Item", 2); // 2 番目のシート
IDispatch *PropertyGet_S_N(PVOID *pDisp, wchar_t *str, long n){
    VARIANT     result;
    VARIANTARG  param[1];
    HRESULT     hr = 0;

    VariantInit(&param[0]);  param[0].vt = VT_I4;   param[0].lVal = n;
    ComInvoke((void **)pDisp, str, param, 1, DISPATCH_PROPERTYGET , &result);
    VariantClear(&param[0]);
    return Variant2Dispatch(&result);
}

// cell = PropertyGet_S_S((void **)sheet, L"Range", L"C2");
IDispatch *PropertyGet_S_S(PVOID *pDisp, wchar_t *str1, wchar_t *str2){
    VARIANT     result;
    VARIANTARG  param[1];
    BSTR        bstr;
    HRESULT     hr = 0;

    bstr = SysAllocString(str2);

    VariantInit(&param[0]);
    param[0].vt = VT_BSTR|VT_BYREF;
    param[0].pbstrVal = &bstr;
    ComInvoke((void **)pDisp, str1, param, 1, DISPATCH_PROPERTYGET , &result);
    VariantClear(&param[0]);
    SysFreeString(bstr);
    return Variant2Dispatch(&result);
}
// ver = ReadProperty((void **)pExl, L"Version");
wchar_t *ReadProperty(PVOID *pDisp, wchar_t *PropertyName){
    VARIANT    param, result;

    VariantInit(&param);
    param.vt      = VT_EMPTY;
    ComInvoke((void **)pDisp, PropertyName,&param, 0,DISPATCH_PROPERTYGET | DISPATCH_METHOD, &result);
    VariantClear(&param);
    return Variant2CWString(&result);
}


// call Method_S_S((void **)workBooks, "Open", "C:\\example.xls");
void Method_S_S(PVOID *pDisp, wchar_t *str1, wchar_t *str2){
    VARIANT     result;
    VARIANTARG  param[1];
    BSTR        bstr;

    bstr = SysAllocString(str2);
    VariantInit(&param[0]);  param[0].vt = VT_BSTR|VT_BYREF;param[0].pbstrVal = &bstr;
    ComInvoke((void **)pDisp, str1, param, 1, DISPATCH_METHOD, &result);
    SysFreeString(bstr);
    VariantClear(&result);
}


// call Method_S((void **)workBooks, L"Close");
// call Method_S((void **)pExl, L"Quit");
void Method_S(PVOID *pDisp, wchar_t *command){
    VARIANT    param, result;

    VariantInit(&param);
    param.vt      = VT_EMPTY;
    ComInvoke((void **)pDisp, command, &param, 0, DISPATCH_METHOD,&result);
    VariantClear(&param);
    VariantClear(&result);
}

// ReleaseObject((void **)pExl);
void ReleaseObject( PVOID *pDisp ){
    ((IDispatch  *)pDisp)->lpVtbl->Release( (void *)pDisp);
}