トップ > Haskell > COM を学ぶ(7) : HaskellでExcel

COM を学ぶ(7) : HaskellでExcel

Haskell COM C MinGW

HaskellでExcelを読み書きしてみました。

  • Haskell のソースコードは UTF8。UTF8 のソースはコンパイルすると内部コードUCS4に変換されます。Windows は表面はSJISですが、COM を呼ぶときにはBSTRに変換しています。
  • ソースに書かれた文字列を直接Excelに書き込む場合はUCS4からSJISに変換し、CSting に変換してCで書かれたライブラリを呼びます。
  • C で 書かれたライブラリでは文字列は BSTR に変換され COMを呼びます。COMとのデータのやりとりは Variant型 で行なわれます。
  • CString で確保したメモリはGCが行なわれませんので開放する必要があります。
  • Variant型というのはデータの種類を表すメンバ VARTYPE vt と大きな共用体で表現されていいます。
// C:\MinGW\include\oaidl.h
typedef struct tagVARIANT {
  _ANONYMOUS_UNION union {
        struct __tagVARIANT {
        VARTYPE vt;
         //（略）
        _ANONYMOUS_UNION union {
                long lVal;
                LONGLONG llVal;
                unsigned char bVal;
                short iVal;
                float fltVal;
                double dblVal;
                VARIANT_BOOL  boolVal;
                SCODE scode;
                CY cyVal;
                DATE date;
                BSTR bstrVal;
                IUnknown *punkVal;
                LPDISPATCH pdispVal;
                SAFEARRAY *parray;
                unsigned char *pbVal;
               //（略）
                _ANONYMOUS_STRUCT struct {
                        PVOID pvRecord;
                        struct IRecordInfo *pRecInfo;
                } __VARIANT_NAME_4;
        } __VARIANT_NAME_3;
    } __VARIANT_NAME_2;
    DECIMAL decVal;
  } __VARIANT_NAME_1;
} VARIANT,*LPVARIANT;
  • 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      (CString, newCString)
import Foreign.C.Types       (CLong, CInt)
import Foreign.Marshal.Alloc (free)
import Cinnamon.Ucs          (ucs4ToSjis)

data IDispatch = IDispatch

main = do
    cOleInitialize 0
    pExl          <- instanceNew        "Excel.Application"
    cVersString   <- readProperty pExl  "Version" 
    cPrintNewLine cVersString                -- => 9.0
    workBooks     <- propertyGet_S pExl "Workbooks"
    cFullFileName <- getFullPathName    "sample2.xls"
    workBooksOpen workBooks 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"  (ucs4ToSjis "日本語")       -- セルに書き込み
    cSjisString   <- readProperty cell "Value"                -- セルデータ取得
    cPrintNewLine cSjisString                -- => 日本語
    mapM_ method_S       ((activeWBook,"Save"):(workBooks,"Close"):[(pExl, "Quit")])
    mapM_ free           (cVersString:cFullFileName:[cSjisString])
    mapM_ cReleaseObject (cell:sheet:workSheets:activeWBook:workBooks:[pExl])
    cOleUninitialize

-- Haskell 文字列は List なので 0x00 で終端する CString に変換して C の関数を呼んでいる。
cPrintNewLine :: CString -> IO ()
cPrintNewLine cstr = do
    newLine <-newCString "\n"
    outstr  <- cStrcat cstr newLine
    cprintf outstr
    free newLine

instanceNew :: String -> IO (Ptr IDispatch)
instanceNew name = do
    cName  <- newCString name
    pIDisp <- cInstanceNew cName
    free cName
    return pIDisp

readProperty :: (Ptr IDispatch) -> String -> IO (CString)
readProperty pDisp name = do
    cName  <- newCString name
    pIDisp <- cReadProperty pDisp cName
    free cName
    return pIDisp

propertyGet_S :: (Ptr IDispatch) -> String -> IO (Ptr IDispatch)
propertyGet_S pDisp name = do
    cName  <- newCString  name
    cString <- cPropertyGet_S pDisp cName
    free cName
    return cString

getFullPathName :: String -> IO (CString)
getFullPathName fName = do
    cFName  <- newCString  fName
    cString <- cgetFullPathName cFName
    free   cFName
    return cString

propertyGet_S_N :: (Ptr IDispatch) -> String -> CLong -> IO (Ptr IDispatch)
propertyGet_S_N pDisp name n = do 
    cstring <- newCString name
    pIDisp  <- cPropertyGet_S_N pDisp cstring  n
    free cstring
    return pIDisp

propertyGet_S_S :: (Ptr IDispatch) -> String -> String -> IO (Ptr IDispatch)
propertyGet_S_S pDisp command param = do 
    cCommand <- newCString command
    cParam   <- newCString param
    pIDisp   <- cPropertyGet_S_S pDisp cCommand cParam
    mapM_ free (cCommand:[cParam])
    return pIDisp

propertyPut_S_S :: (Ptr IDispatch) -> String -> String -> IO ()
propertyPut_S_S pDisp name value = do 
    cName  <- newCString     name
    cValue <- newCString value
    cPropertyPut_S_S pDisp cName  cValue
    free cName
    free cValue

method_S :: ((Ptr IDispatch), String) -> IO ()
method_S (pDisp, name) = do
    cName <- newCString name
    cMethod_S pDisp cName
    free cName

workBooksOpen  :: (Ptr IDispatch) -> CString -> IO ()
workBooksOpen pDisp fileName = do
    cstringOpen  <- newCString "Open"
    cMethod_S_S pDisp cstringOpen fileName
    free cstringOpen

-- C の関数を呼ぶための定義
foreign import ccall   "InstanceNew"            cInstanceNew       :: CString -> IO (Ptr IDispatch)
foreign import ccall   "getFullPathName"        cgetFullPathName   :: CString -> IO CString
foreign import ccall   "PropertyGet_S"          cPropertyGet_S     :: (Ptr IDispatch) -> CString -> IO (Ptr IDispatch)
foreign import ccall   "PropertyGet_S_S"        cPropertyGet_S_S   :: (Ptr IDispatch) -> CString -> CString
                                                                        -> IO (Ptr IDispatch)
foreign import ccall   "PropertyGet_S_N"        cPropertyGet_S_N   :: (Ptr IDispatch) -> CString -> CLong
                                                                        -> IO (Ptr IDispatch)
foreign import ccall   "PropertyPut_S_S"        cPropertyPut_S_S   :: (Ptr IDispatch) -> CString -> CString -> IO ()
foreign import ccall   "ReadProperty"           cReadProperty      :: (Ptr IDispatch) -> CString -> IO CString
foreign import ccall   "Method_S_S"             cMethod_S_S        :: (Ptr IDispatch) -> CString -> CString -> IO ()
foreign import ccall   "Method_S"               cMethod_S          :: (Ptr IDispatch) -> CString -> IO ()
foreign import ccall   "ReleaseObject"          cReleaseObject     :: (Ptr IDispatch) -> IO ()
foreign import ccall   "stdlib.h free"          cfree              :: CString -> IO ()
foreign import ccall   "stdlib.h free"          cDispatchFree      :: (Ptr IDispatch) -> IO ()
foreign import ccall   "stdio.h  printf"        cprintf            :: CString -> IO ()
foreign import ccall   "string.h strcat"        cStrcat            :: CString -> CString ->  IO (CString)
foreign import stdcall "ole2.h OleInitialize"   cOleInitialize     :: CInt -> IO ()
foreign import stdcall "ole2.h OleUninitialize" cOleUninitialize   :: IO ()
  • winole.c
#include <stdio.h>
#include <malloc.h>
#include <windows.h>

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

void messageBox (char* str, char* t, unsigned long x)
{
 MessageBox ( NULL, str, t, x);
 return;
}

IDispatch *mallocDispatch(){
    return (struct IDispatch *)malloc( sizeof(struct IDispatch) );
}

// COM は内部でBSTRを使用しています。
BSTR BSTRfromCstring(char* cstring ){
    int    cstringlen, out_size;
    BSTR   wstr;
    cstringlen = strlen(cstring);
    out_size   = MultiByteToWideChar(CP_ACP, 0, cstring, cstringlen, NULL, 0);
    wstr       = SysAllocStringLen(NULL, out_size);
    MultiByteToWideChar(CP_ACP, 0, cstring, cstringlen, wstr, out_size);
    return wstr;
}

char* CSTRfromBSTR(BSTR bstr){
    int    out_size;
    char   *cstring;
    out_size = WideCharToMultiByte(CP_ACP, 0, (OLECHAR*)bstr, -1, NULL, 0, NULL, NULL);
    cstring  = (char*)malloc((out_size+1) * sizeof(char));
    WideCharToMultiByte(CP_ACP, 0, (OLECHAR*)bstr, -1, cstring, out_size, NULL, NULL);
    return cstring;
}

IDispatch *Variant2Dispatch(VARIANT *pVariant){
    IDispatch *pDispatch;

    if (V_ISBYREF(pVariant))
        pDispatch = *V_DISPATCHREF(pVariant);
    else
        pDispatch = V_DISPATCH(pVariant);

    return pDispatch;
}
// 常にインタフェーステーブルへアクセスする。
// Open,Close などのコマンドからテーブルのディスパッチIDを求め実行する。
HRESULT ComInvoke( PVOID *p, char *ComString ,VARIANTARG *param, int nArgs, USHORT wFlags, VARIANT *result){
    IDispatch   *pDisp;
    DISPID      dispID;
    HRESULT     hr;
    unsigned    short *ucPtr; 
    UINT        puArgErr = 0;
    EXCEPINFO   excepinfo;

    // http://msdn.microsoft.com/ja-jp/library/x6828bcx%28v=VS.80%29.aspx
    // Win32OLE 製作過程の雑記 : invoke メソッドの引数
    // http://homepage1.nifty.com/markey/ruby/win32ole/win32ole03.html#invoke-param
    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 = BSTRfromCstring( ComString );
    hr=pDisp->lpVtbl->GetIDsOfNames((IDispatch  *)pDisp, &IID_NULL, &ucPtr, 1, LOCALE_USER_DEFAULT, (DISPID*)&dispID);
    //printf("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]
     // printf("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(char *ComName){
    IDispatch  *pDisp;
    BSTR       name;
    CLSID      clsid;
    HRESULT    hr=0;

    pDisp = mallocDispatch();
    name  = BSTRfromCstring( 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;
}

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

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

char *Double2String(double num){
    char *buf;
    buf = (char*)malloc(30 * sizeof(char));
    sprintf(buf,"%f",num);
    return buf;
}

char *Variant2String(VARIANT *result){
    switch(V_VT(result)){
        case VT_EMPTY:
            return "empty";
            break;
        case VT_NULL:
            return "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) ? "True" : "False");
            break;
        case VT_BSTR:
            return CSTRfromBSTR(V_BSTR(result));
            break;
        case VT_DATE:
            return Date2String( V_DATE(result));
            break;
    }
}

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

    bstr = BSTRfromCstring(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 メソッドをコールし、パス名を含めたファイル名を取得
char *GetPathName(IDispatch *fDisp, char *fileName){
    VARIANT    param, result;
    HRESULT    hr = 0;
    char *fullPathName;

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

    hr = ComInvoke((void **)fDisp, "GetAbsolutePathName", &param, 1, DISPATCH_METHOD, &result);
    fullPathName  = CSTRfromBSTR(result.bstrVal);
    SysFreeString(param.bstrVal);
    VariantClear(&param);
    VariantClear(&result);
    return fullPathName;
}
// Scripting.FileSystemObject を作りパス名を含めたファイル名を取得
// in  : fileName
// out : fullPathName
char *getFullPathName(char *fileName){
    IDispatch  *fileSystemObj;

    fileSystemObj = InstanceNew("Scripting.FileSystemObject");
    return GetPathName(fileSystemObj, fileName);
}

//   workBooks   = PropertyGet_S((void **)pExl,       "Workbooks");
IDispatch *PropertyGet_S( PVOID *parentDisp, char *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);
    // printf("CreateNewObject   ObjName:%-14s hr:%08lx\n",ObjName,hr);
    VariantClear(&param);
    return Variant2Dispatch(&result);
}

//  sheet  = PropertyGet_S_N( (void **)workSheets, "Item", 2); // 2 番目のシート
IDispatch *PropertyGet_S_N(PVOID *pDisp, char *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, "Range", "C2");
IDispatch *PropertyGet_S_S(PVOID *pDisp, char *str1, char *str2){
    VARIANT     result;
    VARIANTARG  param[1];
    BSTR        bstr;
    HRESULT     hr = 0;

    bstr = BSTRfromCstring(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, "Version");
char *ReadProperty(PVOID *pDisp, char *PropertyName){
    VARIANT    param, result;

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


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

    bstr = BSTRfromCstring(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, "Close");
// call Method_S((void **)pExl, "Quit");
void Method_S(PVOID *pDisp, char *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);
}