小さいMDBですが、10000回連続読み込みでもOKでした。
XP では正常に動作するが、VISTAではSEGV になった。
XP ではmalloc して LSICD の値を保持しているので ((IDispatch *)pDisp)->lpVtbl->Release( (void *)pDisp) で開放したあと free(pDisp) していたが、VISTA では free(pDisp)の瞬間にSEGV と判明。
free(pDisp)は重複していたのだけれども、XPではSEGVにならなかったのだ。
{-# LANGUAGE CPP #-} -- ghc --make Wxmdb.hs winole.c -lole32 -loleaut32 -luuid -o ole module Main where import Win32ole (Vmaterial(..), VariantFunc(..), HaskellDt(..),OLEobj, VARIANTobj, getProperty, variantToBool, getObject, variantToInteger, c_OleInitialize, createInstance, c_OleUninitialize, variantToString, toVARIANTobj, toVariantLS, c_VariantTypeCode, variantToDateTime, c_VariantToDouble, variantType, c_VariantToLong, callMethod, c_processMessage, c_ReleaseObject) import Foreign.C.String (CString, CWString, newCString, newCWString, peekCString, withCWString) import Foreign.C.Types (CLong, CInt) import Foreign.Ptr (Ptr, castPtr) import Foreign.Marshal.Alloc (free) import System.IO.Unsafe (unsafePerformIO) -- /C/HaskellPlatform/com mdbconn = "DRIVER={Microsoft Access Driver (*.mdb)};Dbq=C:\\HaskellPlatform\\com\\sample1.mdb ;" -- sql = "SELECT * FROM earthquake WHERE NumOfDeaths=37;" sql = "SELECT * FROM earthquake;" rep 0 = putStrLn "Done." rep n = do db <- dbRead mdbconn sql mapM_ (\[HString name,HDateTime d, HDouble n, HInteger deaths, HString b] -> putStrLn $ concat[ take 20 (name ++ (repeat ' ')), show d," ",show n ," ", reverse $ take 7 ((reverse (show deaths)) ++ (repeat ' '))," ", show b]) db putStrLn (show n) rep (n-1) main = rep 1 -- 関東大震災 1923-09-01 00:00:00 UTC 7.9 142807 True -- 北海道東方沖地震 1994-10-04 00:00:00 UTC 8.1 0 False -- 阪神淡路大震災 1995-01-17 00:00:00 UTC 7.2 6418 True -- 新潟県中越地震 2004-10-23 00:00:00 UTC 6.8 37 True dbRead conStr sqlStr = do c_OleInitialize 0 conn <- createInstance "ADODB.Connection" dbOpen conn conStr rs <- executSQL conn sqlStr fields <- getFieldsObject rs fName <- getFiledsName rs fields print =<< mapM variantToString fName -- => ["Name","Day","Magnitude","NumOfDeaths","DeadOrAlive"] vAllDT <- readDB rs fields fName print =<< vListToVnameList (head vAllDT) -- => ["string","datetime","double","long","bool"] ret <- convToHaskellType vAllDT dbClose conn fields rs fName c_OleUninitialize return ret dbOpen :: OLEobj -> String -> IO() dbOpen conn str = do variantSTR <- toVARIANTobj (VString str) withCWString "Open" (\x -> callMethod conn x [variantSTR]) free variantSTR executSQL :: OLEobj -> String -> IO OLEobj executSQL conn sql = do variant <- toVariantLS [VString sql] [] objRs <- withCWString "Execute" (\x -> getObject conn x variant) mapM_ free variant return objRs cwsFields = unsafePerformIO $ newCWString "Fields" getFieldsObject :: OLEobj -> IO OLEobj getFieldsObject rs = getObject rs cwsFields [] dbClose :: OLEobj -> OLEobj -> OLEobj -> [VARIANTobj] -> IO () dbClose conn rs fields fName = do withCWString "Close" (\x-> callMethod conn x []) mapM_ c_ReleaseObject [fields, rs, conn] mapM_ free fName convToHaskellType :: [[VARIANTobj]] -> IO [[HaskellDt]] convToHaskellType [] = return [] convToHaskellType vAllDT = do fArray <- variantToVfunc (head vAllDT) [] vArrayToHarray fArray vAllDT vArrayToHarray :: [VariantFunc] -> [[VARIANTobj]] -> IO [[HaskellDt]] vArrayToHarray fArray vArray = mapM (\x-> applyFunc fArray x []) vArray applyFunc :: [VariantFunc] -> [VARIANTobj] -> [HaskellDt] -> IO [HaskellDt] applyFunc (func:funcs) (dt:dts) acc = case func of (FString toString) -> do str <- toString dt free dt applyFunc funcs dts ((HString str):acc) (FLong toInteger) -> do int <- toInteger dt free dt applyFunc funcs dts ((HInteger int):acc) (FDateTime toDateTime) -> do dtime <- toDateTime dt free dt applyFunc funcs dts ((HDateTime dtime):acc) (FBool toBool) -> do bool <- toBool dt free dt applyFunc funcs dts ((HBool bool):acc) (FDouble toDouble) -> do double <- toDouble dt free dt applyFunc funcs dts ((HDouble double):acc) (FNull toNull) -> do null <- toNull dt free dt applyFunc funcs dts ((HString null):acc) applyFunc [] _ acc = return (reverse acc) #define VT_EMPTY 0 #define VT_NULL 1 #define VT_I2 2 #define VT_I4 3 #define VT_R4 4 #define VT_R8 5 #define VT_DATE 7 #define VT_BSTR 8 #define VT_BOOL 0x0b #define VT_ARRAY 0x2000 #define VT_VARIANT 0x0c variantToVfunc :: [VARIANTobj] -> [VariantFunc]-> IO [VariantFunc] variantToVfunc [] acc = return (reverse acc) variantToVfunc (x:xs) acc = do iTypeCD <- c_VariantTypeCode x case iTypeCD of VT_BSTR -> variantToVfunc xs ((FString variantToString) :acc) VT_I4 -> variantToVfunc xs ((FLong variantToInteger):acc) VT_DATE -> variantToVfunc xs ((FDateTime variantToDateTime):acc) VT_BOOL -> variantToVfunc xs ((FBool variantToBool):acc) VT_R8 -> variantToVfunc xs ((FDouble c_VariantToDouble):acc) _ -> variantToVfunc xs ((FNull variantType):acc) vListToVnameList :: [VARIANTobj] -> IO [String] vListToVnameList vList = mapM variantType vList -- Filed 名取得 getFiledsName :: OLEobj -> OLEobj -> IO [VARIANTobj] getFiledsName rs fields = do vCount <- getProperty fields cwsCount [] fCount <- c_VariantToLong vCount free vCount readFiledName rs cwsName (fCount -1) [] where cwsCount = unsafePerformIO $ newCWString "Count" cwsName = unsafePerformIO $ newCWString "Name" readFiledName :: OLEobj -> CWString -> CLong -> [VARIANTobj] -> IO [VARIANTobj] readFiledName _ _ (-1) out = do return out readFiledName rs name count out = do vList <- toVariantLS [VLong count] [] field <- getObject rs cwsFields vList vColName <- getProperty field name [] c_ReleaseObject field readFiledName rs name (count-1) (vColName:out) cwsValue = unsafePerformIO $ newCWString "Value" cwsItem = unsafePerformIO $ newCWString "Item" readDB :: OLEobj -> OLEobj -> [VARIANTobj]-> IO [[VARIANTobj]] readDB rs fields nameList = readDB_ rs fields nameList [] readDB_ :: OLEobj -> OLEobj -> [VARIANTobj] -> [[VARIANTobj]] -> IO [[VARIANTobj]] readDB_ rs fields nameList acc = do eofBof <- isEOForBOF rs case eofBof of False -> do line <- readLine fields nameList callMethod rs cwsMoveNext [] readDB_ rs fields nameList (line:acc) True -> return (reverse acc) where cwsMoveNext = unsafePerformIO $ newCWString "MoveNext" isEOForBOF :: OLEobj -> IO Bool isEOForBOF rs = do vEOF <- getProperty rs eof [] vBOF <- getProperty rs bof [] bEOF <- variantToBool vEOF bBOF <- variantToBool vBOF mapM_ free [vEOF, vBOF] return $ bEOF || bBOF where eof = unsafePerformIO $ newCWString "EOF" bof = unsafePerformIO $ newCWString "BOF" readLine :: OLEobj -> [VARIANTobj] -> IO [VARIANTobj] readLine fields fieldsNames = mapM readField fieldsNames where readField field = do obj <- getObject fields cwsItem [field] vData <- getProperty obj cwsValue [] c_processMessage c_ReleaseObject obj return vData
Win32ole.hs
{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE CPP #-} -- ghc --make win32ole.hs winole.c -lole32 -loleaut32 -luuid -o ole module Win32ole ( Vmaterial(..), HaskellDt(..), VariantFunc(..), Obj(..), OLEobj, BSTRobj, VARIANTobj, VARGobj, SYSTime, stringToBSTR, toVariantLS, toVARIANTobj, tupleDateToVariant, bSTRToString, boolToVariant, callMethod , createInstance, destroyOBJ, invoke, getFullPathName, getObject, getProperty, putProperty, methodTuple , setWxVariantARG, stringToBSTRvariant, variantType , c_VariantTypeCode, variantToString, variantToInteger, c_VariantToLong, variant2Str, variantToDateTime, variantToDate, variantToTime, variantToBool, c_VariantToDouble, c_DoubleToVariant, c_CStringToBSTR, c_BSTRtoCString, c_variantToBSTR, c_longToVariant, c_VariantToSystemTime, c_SystemTimeToVariant, c_setSYSTEMTIME, c_getVsysTime, c_getVsysDate, c_getVariantType, c_BSTRToVariant, c_Variant2bool, c_bool2Variant, c_createVARIANTARG, c_setVARIANTARG, c_freeBSTR, c_invoke, c_createInstance, c_variantToString, c_Variant2Dispatch, c_processMessage, c_ReleaseObject, c_OleInitialize, c_OleUninitialize ) where import Foreign.Ptr (Ptr) import Foreign.C.String (CString, CWString, newCString, newCWString , withCString, withCWString, peekCString) import Foreign.C.Types (CLong, CInt, CUInt,CShort, CUShort) import Foreign.Marshal.Alloc (free) import Cinnamon.Ucs (ucs4ToSjis) import Data.Bits ((.|.)) import Data.DateTime (DateTime, toGregorian, fromGregorian, toGregorian', fromGregorian', fromSqlString, toSqlString) data IDispatch = IDispatch data BSTR = BSTR data VARIANT = VARIANT data VARIANTARG = VARIANTARG data SYSTEMTIME = SYSTEMTIME type OLEobj = (Ptr IDispatch) type BSTRobj = (Ptr BSTR) type VARIANTobj = (Ptr VARIANT) type VARGobj = (Ptr VARIANTARG) type SYSTime = (Ptr SYSTEMTIME) data Obj = O OLEobj | CW CWString | B BSTRobj | V VARIANTobj | VA VARGobj type TupleDate = (Integer, Int, Int) #define DISPATCH_METHOD 1 #define DISPATCH_PROPERTYGET 2 #define DISPATCH_PROPERTYPUT 4 #define DISPATCH_PROPERTYPUTREF 8 data Vmaterial = VLong CLong | VString String | VDouble Double | VDate (Integer, Int, Int) | VBool Bool | VList [Vmaterial] deriving (Show) data HaskellDt = HInteger Integer | HString String | HBool Bool | HDouble Double | HDateTime DateTime deriving (Show,Eq) data VariantFunc = FLong (VARIANTobj -> IO Integer) | FString (VARIANTobj -> IO String) | FDateTime (VARIANTobj -> IO DateTime) | FBool (VARIANTobj -> IO Bool) | FDouble (VARIANTobj -> IO Double) | FNull (VARIANTobj -> IO String) toVARIANTobj :: Vmaterial -> IO VARIANTobj toVARIANTobj (VLong value) = c_longToVariant value toVARIANTobj (VString value) = stringToBSTRvariant value toVARIANTobj (VDouble value) = c_DoubleToVariant value toVARIANTobj (VDate value) = tupleDateToVariant value toVARIANTobj (VBool value) = boolToVariant value tupleDateToVariant :: TupleDate -> IO VARIANTobj tupleDateToVariant (year, month, day) = do sysTime <- c_setSYSTEMTIME (fromIntegral year) (fromIntegral month) (fromIntegral day) 0 0 0 variant <- c_SystemTimeToVariant sysTime free sysTime return variant toVariantLS :: [Vmaterial] -> [VARIANTobj] -> IO [VARIANTobj] toVariantLS (x:xs) acc = do variant <- toVARIANTobj x toVariantLS xs (variant:acc) toVariantLS [] acc = return (reverse acc) destroyOBJ :: Obj -> IO() destroyOBJ (O obj) = c_ReleaseObject obj destroyOBJ (CW str) = free str destroyOBJ (B bstr) = c_freeBSTR bstr destroyOBJ (V variant) = free variant destroyOBJ (VA varg) = free varg -- String stringToBSTR :: String -> IO BSTRobj stringToBSTR string = withCString string c_CStringToBSTR bSTRToString :: BSTRobj -> IO String bSTRToString string = do cstring <- c_BSTRtoCString string string <- peekCString cstring free cstring return string stringToBSTRvariant :: String -> IO VARIANTobj stringToBSTRvariant string = do bstr <- withCString string c_CStringToBSTR variant <- c_BSTRToVariant bstr free bstr return variant -- Variant variantType :: VARIANTobj -> IO String variantType variant = variant2Str variant c_getVariantType variantToString :: VARIANTobj -> IO String variantToString variant = variant2Str variant c_variantToString variant2Str :: VARIANTobj -> (VARIANTobj -> IO CString) -> IO String variant2Str variant func = do cstring <- func variant string <- peekCString cstring free cstring return string variantToDateTime :: VARIANTobj -> IO DateTime variantToDateTime variant = do sysTime <- c_VariantToSystemTime variant clongDate <- c_getVsysDate sysTime clongTime <- c_getVsysTime sysTime free sysTime let numDate = fromIntegral clongDate let numTime = fromIntegral clongTime return $ fromGregorian (numDate `div` 10000) -- year (fromInteger (numDate `div` 100 `rem` 100)) -- month (fromInteger (numDate `rem` 100)) -- day (numTime `div` 10000) -- hour (numTime `div` 100 `rem` 100) -- minute (numTime `rem` 100) -- second variantToDate :: VARIANTobj -> IO DateTime variantToDate variant = do sysTime <- c_VariantToSystemTime variant clongDate <- c_getVsysDate sysTime free sysTime let numDate = fromIntegral clongDate return $ fromGregorian (numDate `div` 10000) -- year (fromInteger (numDate `div` 100 `rem` 100)) -- month (fromInteger (numDate `rem` 100)) -- day 0 0 0 variantToTime :: VARIANTobj -> IO DateTime variantToTime variant = do sysTime <- c_VariantToSystemTime variant clongTime <- c_getVsysTime sysTime free sysTime let numTime = fromIntegral clongTime return $ fromGregorian 0 0 0 (numTime `div` 10000) -- hour (numTime `div` 100 `rem` 100) -- minute (numTime `rem` 100) -- second variantToBool :: VARIANTobj -> IO Bool variantToBool variant = do cInt <- c_Variant2bool variant if cInt==0 then return False else return True boolToVariant :: Bool -> IO VARIANTobj boolToVariant bool = case bool of True -> c_bool2Variant ((-1)::CShort) _ -> c_bool2Variant ( 0::CShort) variantToInteger :: VARIANTobj -> IO Integer variantToInteger variant = do clong <- c_VariantToLong variant return $ fromIntegral clong -- VARIANTARG setWxVariantARG :: [VARIANTobj] -> IO VARGobj setWxVariantARG variants = do vARGS <- c_createVARIANTARG vArgSize return =<< setWxVariantARG' vARGS 0 variants where vArgSize :: (Num a) => a vArgSize = fromIntegral $ length variants setWxVariantARG' :: VARGobj -> CInt -> [VARIANTobj] -> IO VARGobj setWxVariantARG' vARGS _ [] = return vARGS setWxVariantARG' vARGS n (x:xs) = do retVARGS <- c_setVARIANTARG vARGS n x setWxVariantARG' retVARGS (n+1) xs -- Automation createInstance :: String -> IO OLEobj createInstance name = withCString name c_createInstance invoke :: OLEobj -> CWString -> [VARIANTobj] -> CUShort -> IO VARIANTobj invoke obj cwCom vArgs invokeType = do vaParam <- setWxVariantARG vArgs variant <- c_invoke obj cwCom (fromIntegral $ length vArgs) vaParam invokeType mapM_ destroyOBJ [VA vaParam] return variant getProperty :: OLEobj -> CWString -> [VARIANTobj] -> IO VARIANTobj getProperty obj name vArgs = invoke obj name vArgs DISPATCH_PROPERTYGET putProperty :: OLEobj -> CWString -> [Vmaterial] -> IO () putProperty obj name vMaterial = do vArgs <- toVariantLS vMaterial [] variant <- invoke obj name vArgs DISPATCH_PROPERTYPUT free variant getObject :: OLEobj -> CWString -> [VARIANTobj] -> IO OLEobj getObject obj name vArgs = do variant <- invoke obj name vArgs DISPATCH_PROPERTYGET obj <- c_Variant2Dispatch variant free variant return obj -- GetAbsolutePathName メソッドをコールし、パス名を含めたファイル名を取得 getFullPathName :: String -> IO VARIANTobj getFullPathName fileName = do obj <- createInstance "Scripting.FileSystemObject" cwstring <- newCWString "GetAbsolutePathName" vFname <- stringToBSTRvariant fileName variant <- invoke obj cwstring [vFname] DISPATCH_METHOD mapM_ destroyOBJ [O obj, V vFname] return variant callMethod :: OLEobj -> CWString -> [VARIANTobj] -> IO () callMethod obj name vArgs = do variant <- invoke obj name vArgs DISPATCH_METHOD free variant methodTuple :: (OLEobj, String) -> IO () methodTuple (obj, method) = withCWString method (\x-> callMethod obj x []) -- C の関数を呼ぶための定義 foreign import ccall unsafe "processMessage" c_processMessage :: IO () foreign import ccall unsafe "CStringToBSTR" c_CStringToBSTR :: CString -> IO BSTRobj foreign import ccall unsafe "BSTRtoCString" c_BSTRtoCString :: BSTRobj -> IO CString foreign import ccall unsafe "variantToBSTR" c_variantToBSTR :: VARIANTobj -> IO BSTRobj foreign import ccall unsafe "varantToLong" c_VariantToLong :: VARIANTobj -> IO CLong foreign import ccall unsafe "longToVariant" c_longToVariant :: CLong -> IO VARIANTobj foreign import ccall unsafe "Variant2double" c_VariantToDouble :: VARIANTobj -> IO Double foreign import ccall unsafe "Double2Variant" c_DoubleToVariant :: Double -> IO VARIANTobj foreign import ccall unsafe "Variant2SystemTime" c_VariantToSystemTime :: VARIANTobj -> IO SYSTime foreign import ccall unsafe "SystemTime2Variant" c_SystemTimeToVariant :: SYSTime -> IO VARIANTobj foreign import ccall unsafe "setSYSTEMTIME" c_setSYSTEMTIME :: CUInt -> CUInt -> CUInt -> CUInt -> CUInt -> CUInt -> IO SYSTime foreign import ccall unsafe "getVsysTime" c_getVsysTime :: SYSTime -> IO CLong foreign import ccall unsafe "getVsysDate" c_getVsysDate :: SYSTime -> IO CLong foreign import ccall unsafe "BSTRToVariant" c_BSTRToVariant :: BSTRobj -> IO VARIANTobj foreign import ccall unsafe "Variant2bool" c_Variant2bool :: VARIANTobj -> IO CShort foreign import ccall unsafe "bool2Variant" c_bool2Variant :: CShort -> IO VARIANTobj -- VARIANTARG foreign import ccall unsafe "createVARIANTARG" c_createVARIANTARG :: CInt -> IO VARGobj foreign import ccall unsafe "setVARIANTARG" c_setVARIANTARG :: VARGobj -> CInt -> VARIANTobj -> IO VARGobj foreign import ccall unsafe "invoke" c_invoke :: OLEobj -> CWString -> CInt -> VARGobj -> CUShort -> IO VARIANTobj foreign import ccall unsafe "createInstance" c_createInstance :: CString -> IO OLEobj foreign import ccall unsafe "getVariantType" c_getVariantType :: VARIANTobj -> IO CString foreign import ccall unsafe "VariantTypeCode" c_VariantTypeCode :: VARIANTobj -> IO CInt foreign import ccall unsafe "variantToString" c_variantToString :: VARIANTobj -> IO CString foreign import ccall unsafe "Variant2Dispatch" c_Variant2Dispatch :: VARIANTobj -> IO OLEobj foreign import ccall unsafe "ReleaseObject" c_ReleaseObject :: OLEobj -> IO () foreign import stdcall "ole2.h OleInitialize" c_OleInitialize :: CInt -> IO () foreign import stdcall "ole2.h OleUninitialize" c_OleUninitialize :: IO () foreign import stdcall "oleauto.h SysFreeString" c_freeBSTR :: BSTRobj -> IO () foreign import stdcall "oleauto.h SafeArrayGetElemsize" c_SafeArrayGetElemsize :: VARIANTobj -> IO CUInt
- 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; } void processMessage(){ MSG msg; if (PeekMessage (&msg,NULL, WM_PAINT, WM_PAINT,PM_NOREMOVE)) { TranslateMessage(&msg); DispatchMessage(&msg); } } IDispatch *mallocDispatch(){ return (struct IDispatch *)malloc( sizeof(struct IDispatch) ); } // COM は内部でBSTRを使用しています。 BSTR CStringToBSTR(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* BSTRtoCString(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を求め実行する。 VARIANT* invoke( PVOID *p, BSTR com, int nArgs, VARIANTARG *param, USHORT wFlags){ VARIANT *result; IDispatch *pDisp; DISPID dispID; HRESULT hr; 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取得 hr=pDisp->lpVtbl->GetIDsOfNames((IDispatch *)pDisp, &IID_NULL, &com, 1, LOCALE_USER_DEFAULT, (DISPID*)&dispID); // printf("GetIDsOfNames nArgs:%d %-10S = %04d hr:%08lx\n", nArgs , com, dispID, hr); result = (VARIANT*)malloc( sizeof (*result)); 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:%-20S dispID:%6d hr:%08x puArgErr:%d\n", com, dispID, hr,puArgErr); return result; } // ProgID("Excel.Application")からCLSID({00024500-0000-0000-C000000000000046}) // を求め、CoCreateInstance APIを呼びます。 IDispatch* createInstance(char *ComName){ IDispatch *pDisp; BSTR name; CLSID clsid; HRESULT hr=0; pDisp = mallocDispatch(); name = CStringToBSTR( 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; } /* // winbase.h typedef struct _SYSTEMTIME { WORD wYear; WORD wMonth; // 1 月は 1 です。 WORD wDayOfWeek; // 日曜が 0 WORD wDay; WORD wHour; WORD wMinute; WORD wSecond; WORD wMilliseconds; } SYSTEMTIME; */ SYSTEMTIME* Variant2SystemTime(VARIANT *result){ SYSTEMTIME *st; st = (SYSTEMTIME*)malloc(sizeof(*st)); VariantTimeToSystemTime(V_DATE(result), st); return st; } VARIANT* SystemTime2Variant(SYSTEMTIME* st){ DATE *date; VARIANT *variant; date = (DATE*)malloc(sizeof(*date)); variant = (VARIANT*)malloc(sizeof(*variant)); SystemTimeToVariantTime(st, date); VariantInit(variant); V_VT(variant) = VT_DATE; V_DATE(variant) = *date; return variant; } SYSTEMTIME *setSYSTEMTIME(WORD year, WORD month, WORD day, WORD hour, WORD minute, WORD second){ SYSTEMTIME *st; st = (SYSTEMTIME*)malloc(sizeof(*st)); st->wYear = year; st->wMonth = month; st->wDay = day; st->wHour = hour; st->wMinute = minute; st->wSecond = second; return st; } long getVsysTime(SYSTEMTIME *st){ return (long)st->wHour * 10000 + st->wMinute * 100 + st->wSecond; } long getVsysDate(SYSTEMTIME *st){ return (long)st->wYear * 10000 + st->wMonth * 100 + st->wDay; } long varantToLong(VARIANT *result){ return V_I4(result);} double Variant2double(VARIANT *result){ return V_R8(result);} VARIANT* Double2Variant(double value){ VARIANT *variant; variant = (VARIANT*)malloc(sizeof(*variant)); VariantInit(variant); V_VT(variant) = VT_R8; V_R8(variant) = value; return variant; } int Variant2bool(VARIANT *result){ return V_BOOL(result); } VARIANT* bool2Variant(int value){ VARIANT *variant; variant = (VARIANT*)malloc(sizeof(*variant)); VariantInit(variant); variant->vt = VT_BOOL; variant->boolVal = value; return variant; } /********** enum VARENUM { VT_EMPTY,VT_NULL,VT_I2,VT_I4,VT_R4,VT_R8, VT_CY,VT_DATE,VT_BSTR,VT_DISPATCH, VT_ERROR,VT_BOOL,VT_VARIANT,VT_UNKNOWN,VT_DECIMAL, VT_I1=16,VT_UI1,VT_UI2,VT_UI4,VT_I8, VT_UI8,VT_INT,VT_UINT,VT_VOID,VT_HRESULT,VT_PTR,VT_SAFEARRAY,VT_CARRAY,VT_USERDEFINED, VT_LPSTR,VT_LPWSTR, VT_RECORD =36,VT_INT_PTR=37,VT_UINT_PTR=38, VT_FILETIME=64,VT_BLOB,VT_STREAM,VT_STORAGE,VT_STREAMED_OBJECT, VT_STORED_OBJECT,VT_BLOB_OBJECT,VT_CF,VT_CLSID, VT_BSTR_BLOB=0xfff, VT_VECTOR =0x1000, VT_ARRAY =0x2000, VT_BYREF =0x4000, VT_RESERVED =0x8000, VT_ILLEGAL = 0xffff, VT_ILLEGALMASKED=0xfff, VT_TYPEMASK =0xfff }; **********/ int VariantTypeCode(VARIANT *result){ return V_VT(result); } char *getVariantType(VARIANT *result){ // printf("V_VT(result):%x\n",V_VT(result)); switch(V_VT(result)){ case VT_EMPTY: return "empty"; break; case VT_NULL: return "null"; break; case VT_I2: return "short"; break; case VT_I4: return "long"; break; case VT_R4: return "float"; break; case VT_R8: return "double"; break; case VT_BOOL: return "bool"; break; case VT_BSTR: return "string"; break; case VT_DATE: return "datetime"; break; case (VT_ARRAY|VT_VARIANT): return "array"; break; default : return "error"; // SafeArrayGetElemsize(tagSAFEARRAY * psa)プロパティ } } char* variantToString(VARIANT *result){ BSTRtoCString(V_BSTR(result));} BSTR variantToBSTR(VARIANT *result){ return V_BSTR(result);} VARIANT* BSTRToVariant(BSTR bstr){ VARIANT* dt; dt = (VARIANT*)malloc( sizeof (*dt)); VariantInit(dt); V_VT(dt) =VT_BSTR; // dt->vt = VT_BSTR; V_BSTR(dt) = bstr; // dt->bstrVal = bstr; return dt; } VARIANT* longToVariant(long n){ VARIANT* dt; dt = (VARIANT*)malloc( sizeof (*dt)); VariantInit(dt); V_VT(dt) = VT_I4; // dt->vt = VT_I4 dt->lVal = n; return dt; } VARIANTARG* createVARIANTARG(int n){ VARIANTARG *dt; dt = (VARIANT*)malloc( (sizeof (*dt)) * n); return dt; } VARIANTARG* setVARIANTARG(VARIANTARG* array, int n, VARIANT* dt){ *(array + n) = *dt; return array; } // ReleaseObject((void **)pExl); void ReleaseObject( PVOID *pDisp ){ ((IDispatch *)pDisp)->lpVtbl->Release( (void *)pDisp); }
