なんとなく核心にせまりつつはあると思うのですが
今回はファイルがオープンできません。BSTR(wideChar?)型でのファイル名を求められているとは
思うので用意をしたのですが、相変わらずファイルを開けません。
苦労しているせいで色々勉強になります(笑
OLEViewerなるものも初めて知りました。
お陰でclassの中は大丈夫だと思っています・・・たぶん
何かお気付きあれば返信ください・・・
コード:
#strict
'MODI
' ここからプログラムが実行されます。
'宣言
TypeDef HRESULT = Long
TypeDef CLSID = GUID 'Globally Unique Identifiers
TypeDef IID = GUID
TypeDef PITEMIDLIST = VoidPtr
TypeDef PCITEMIDLIST = VoidPtr
TypeDef WCHAR = Word
TypeDef BSTR = *WCHAR
TypeDef VARIANT_BOOL = Integer
Const VARIANT_TRUE = -1
Const VARIANT_FALSE = 0
TypeDef BOOL = Long
Declare Function CLSIDFromProgID Lib "OLE32" (pszProgID As *WCHAR, ByRef clsid As CLSID) As HRESULT
Declare Function CLSIDFromString Lib "OLE32" (String As *WCHAR, ByRef clsid As CLSID) As HRESULT
Declare Function SysAllocString Lib "OleAut32" ( ByVal psz As BytePtr ) As BSTR
Declare Function SysAllocStringByteLen Lib "OleAut32" ( ByVal psz As BytePtr, ByVal len As DWord) As WordPtr
Declare Function SysStringByteLen Lib "oleaut32" ( bstr As BSTR ) As BSTR
Declare Function SysFreeString Lib "OleAut32" ( ByVal pbstr As WordPtr) As Long
class VARIANT
public
vt as Word 'タグ
wReserved1 as Word 'パディング用
wReserved2 as Word
wReserved3 as Word
Value as DWord '値
Value2 as DWord
end class
Const E_UNEXPECTED = &h8000FFFF As HRESULT
Const FACILITY_WIN32 = 7
Dim CLSID_MODI = [
&h40942A6C,
&h1520,
&h4132,
[&hBD,&hF8,&hBD,&hC1,&hF7,&h1F,&h54,&h7B]
] As GUID
Dim IID_IDocument = [
&hD4073843,
&hA58A,
&h469A,
[&hA8,&hE2,&hCF,&hF3,&hFF,&h77,&hEE,&h4E]
] As GUID
'---------------------------------------------------------------------------------
'メイン
' COMのインスタンス
Dim hr As HRESULT
hr = CoInitialize(0) 'COM初期化
If hr <> S_OK Then
MessageBoxStr(0, GetErrorStr(hr As DWord), "初期化に失敗", MB_ICONERROR)
End
End If
Dim pIDocument As *IDocument
hr = CoCreateInstance(CLSID_MODI, 0, CLSCTX_ALL, IID_IDocument , VarPtr(pIDocument))
Select case hr
case S_OK
msgbox 0,"S_OK"+ex"\r\n\r\n処理は正常に終了し、指定されたオブジェクトは正常に作成されました。","#"
case REGDB_E_CLASSNOTREG
msgbox 0,"REGDB_E_CLASSNOTREG"+ex"\r\n\r\n指定されたクラスは、レジストリに登録されていなかったため、処理が失敗しました。"+_
"CLSIDがレジストリに登録されていても、要求されたCLSCTXに合致しなければ、この値が返されます。","#"
case CLASS_E_NOAGGREGATION
msgbox 0,"CLASS_E_NOAGGREGATION"+ex"\r\n\r\n指定されたクラスは集約をサポートしていないため、処理が失敗しました。","#"
case E_NOINTERFACE
msgbox 0,"E_NOINTERFACE"+ex"\r\n\r\n指定されたクラスは、要求されたインターフェースを実装していないため、処理が失敗しました。"+_
"もう1つの可能性は、オブジェクトを集約した場合に制御側 IUnknownが、オブジェクトの要求する"+_
"インターフェースを実装していない場合にも、この値を返すことがあります。E_POINTER特にppv にNULLを指定した場合に"+_
"この値が返されることがあります。","#"
case E_INVALIDARG
msgbox 0,"E_INVALIDARG"+ex"\r\n\r\n集約するために制御側 IUnknownを指定しているにも関わらず、オブジェクトに要求するインターフェースに、"+_
"IUnknown以外を指定した場合に、この値が返却されることがあります。E_OUTOFMEMORYメモリを割り当てることが"+_
"出来なかったために、処理が失敗しました。","#"
case else
msgbox 0,"イレギュラ","error"
end select
if hr<>S_OK then
' COM開放
CoUninitialize()
end
end if
dim name as BSTR
dim buf as BytePtr
buf = StrByteptr("F:\ActiveBasic\ocr.tif")
name = String_BSTR( buf , lstrlen(buf) )
free( buf )
'if SUCCEEDED( pIDocument->Create( name.getPtr() ) ) then 'ファイルのロード
if SUCCEEDED( pIDocument->Create( name+sizeof(DWord) ) ) then 'ファイルのロード
msgbox 0,"Step 150 ok","Create"
if SUCCEEDED(pIDocument->OCR(17, FALSE, FALSE,)) then 'OCR実行
msgbox 0,"Step 155 ok","OCR"
'doc.OCR(MODI.MiLANGUAGES.miLANG_JAPANESE, false, false) '日本語指定
Dim IImages as *IImages
IImages = pIDocument->Images()
Dim count as Long
count = IImages->GetCount()
msgbox 0,ex"pIDocument.Count "+Str$(count),"count"
if SUCCEEDED(pIDocument->Close(0)) then 'Close
msgbox 0,"Step 170 ok","Close"
else
msgbox 0,"Step 170 False","Close"
end if
if SUCCEEDED(pIDocument->Release()) then 'Release
msgbox 0,"Step 176 ok","Release"
else
msgbox 0,"Step 176 False","Release"
end if
else
msgbox 0,"Step 155 False","OCR"
end if
else
msgbox 0,ex"Step 150 False\r\n"+MakeStr(GetErrorStr(HRESULT_FROM_WIN32(GetLastError()))),"Create"
' MessageBoxStr(0, GetErrorStr(hr As DWord), "ショートカット作成に失敗", MB_ICONERROR)
end if
WStringfree( name )
' COM開放
CoUninitialize()
msgbox 0,"fin","#"
end
Function StrByteptr( str as String ) as BytePtr
'StringデータをByteptrで返答する
Dim data as BytePtr
Dim l as DWord
l = len(str)
data = calloc( l +1 )
lstrcpy( data , StrPtr(str) )
StrByteptr = data
end Function
Function SUCCEEDED(hResult as HRESULT) as BOOL
SUCCEEDED = (hResult >= 0)
endFunction
Function FAILED(hResult as HRESULT) as BOOL
FAILED = (hResult < 0)
endFunction
Function MessageBoxStr(hwnd As HWND, strText As String, pszCaption As BytePtr, uType As DWord) As Long
MessageBox(hwnd, StrPtr(strText), pszCaption, uType)
End Function
Function GetErrorStr(dwMessageId As DWord) As String
Dim pszMsg As BytePtr
FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER Or FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, _
NULL, _
dwMessageId, _
LANG_USER_DEFAULT, _
VarPtr(pszMsg), _
0, _
NULL)
If Not pszMsg = NULL Then
GetErrorStr = pszMsg
LocalFree(pszMsg)
End If
End Function
Class IDispatch
Public
'IUnknown
Virtual Function QueryInterface(
ByRef riid As GUID, ppvObj As DWordPtr) As HRESULT
Virtual Function AddRef() As HRESULT
Virtual Function Release() As HRESULT
'IDispatch
Virtual Function GetTypeInfoCount(pCount As *DWord) As HRESULT 'インターフェースの数取得
Virtual Function GetTypeInfo( 'オブジェクトの型情報を取得します。インターフェイスの型情報の取得に使用できます。
iTInfo As DWord,
lcid As DWord,
ppTInfo As VoidPtr) As HRESULT
Virtual Function GetIDsOfNames( '一連の名前を対応する一連のディスパッチ識別子に割り当てます。
riid As *GUID,
rgszNames As VoidPtr,
cNames As DWord,
lcid As DWord,
rgDispId As *Long) As HRESULT
Virtual Function Invoke( 'オブジェクトによって公開されるメソッドとプロパティへのアクセスを提供します。ディスパッチ関数 DispInvoke は、Invoke の標準的な実装を提供します。
dispIdMember As Long,
riid As *GUID,
lcid As DWord,
wFlags As Word,
pDispParams As VoidPtr,
pVarResult As VoidPtr,
pExcepInfo As VoidPtr,
puArgErr As *DWord) As HRESULT
End Class
Class IDocument
Inherits IDispatch
Public
Virtual Function Save() As HRESULT
Virtual Function Close(_
SaveChanges as Long _ /*ドキュメントが未保存の場合*/
) As HRESULT /*閉じる前に保存するかどうか*/
Virtual Function SaveAs(_
FileName as String,_ 'ファイル名
FileFormat as DWord,_ 'フォーマット
CompLevel as DWord_ '圧縮レベル
) As HRESULT
Virtual Function Images() as *IImages
Virtual Function Create(_
FileOpen as BSTR _ /* ファイル名 */
) As HRESULT
Virtual Function OCR(_
LangId as Long,_ /* ドキュメントの言語 9 英語、17 日本語*/
OCROrientImage as Long ,_ /* ドキュメントの回転を補正させるかどうか*/
OCRStraightenImage as Long_ /* ドキュメントの歪みを補正させるかどうか*/
) As HRESULT
Virtual Function PrintOut(_ '指定されたプリンターまたはファイルに作業中の文書を印刷します。
From as Long,_ '差出人
To as Long,_ '宛先
Copies as Long,_ 'コピー
PrinterName as String,_ 'プリンター名
PrintToFileName as String,_ 'PrintToFileName
PrintAnnotation as Long,_ 'PrintAnnotation (Boolean)
FitMode as Long_ 'FitMode MiPRINT_FITMODES ( miPRINT_ACTUALSIZE or miPRINT_PAGE )
) As HRESULT
End Class
' IImages wrapper class
class IImages
Inherits IDispatch
public
Virtual Function GetCount() as Long
' Virtual Function Add(Page as *IDispatch , BeforePage as *IDispatch ) as HRESULT
' Virtual Function _NewEnum() as *IUnkown
' Virtual Function Item(Index as Long) as *IDispatch
' Virtual Function Remove(Page as *IDispatch) As HRESULT
End Class
sub WStringfree(p as BSTR)
if p <> NULL then
SysFreeString(p)
endif
endsub
Function String_BSTR(pString As BytePtr, length As Long ) As BSTR
Dim sizeWChar As Long
sizeWChar = MultiByteToWideChar(CP_ACP, 0, pString, length , 0, 0)
If sizeWChar = 0 Then
MessageBoxStr(0, GetErrorStr(sizeWChar As DWord), "error 482", MB_ICONERROR)
String_BSTR = 0
Exit Function
End If
Dim pwString As *WCHAR
sizeWChar++
' バッファを確保
pwString = SysAllocStringByteLen( NULL, sizeof(DWord) + sizeof(WCHAR)*sizeWChar )
If pwString = 0 Then
MessageBoxStr(0, GetErrorStr(sizeWChar As DWord), "error 497", MB_ICONERROR)
String_BSTR = 0
Exit Function
End If
' 文字列の長さ格納(単位はバイトで、終端文字は含まれない)
SetDWord(pwString , sizeof(WCHAR)*(sizeWChar-1))
' 文字列先頭を指すようにポインタ移動
'pwString = pwString + sizeof(DWord)
sizeWChar = MultiByteToWideChar(CP_ACP, 0, pString , length + 1, pwString + sizeof(DWord) , sizeWChar)
If sizeWChar = 0 Then
MessageBoxStr(0, GetErrorStr(sizeWChar As DWord), "error 503", MB_ICONERROR)
String_BSTR = 0
Exit Function
End If
String_BSTR = pwString
End Function
Function HRESULT_FROM_WIN32(x As DWord) As HRESULT
If (x As HRESULT) <= 0 Then
HRESULT_FROM_WIN32 = x As HRESULT
Else
HRESULT_FROM_WIN32 = (LOWORD(x) Or (FACILITY_WIN32 << 16) Or &h80000000) As HRESULT
End If
End Function