Программное создание библиотеки типов

CreateIrcClientTypeLibrary.bas

#include "IIrcClient.bi"

Const IrcClientTypeLibName = "BatchedFilesIrcClient"
Const IrcClientTypeLibFileName = "BatchedFilesIrcClient.tlb"
Const IrcClientTypeLibDescription = "Клиентская библиотека для поддержки протокола IRC"
Const IrcClientClassDescription = "Класс для Ircclient"
Const IIrcClientInterfaceName = "IIrcClient"
Const IIrcClientInterfaceDescription = "Интерфейс для поддержки протокола IRC"
Const StdOleLibrary = "stdole32.tlb"

' Функция ShowMessageBox

Const ShowMessageBoxFunctionMemberId = 0
Const ShowMessageBoxFunctionName = "ShowMessageBox"
Const ShowMessageBoxFunctionDescription = "Отображает окошко MessageBox"
Const ParamParamName = "lngParam"
Const ParamResultName = "pResult"

' {522E5895-8BC8-4E78-BDAC-98DD8C108F68}
Dim Shared LIBID_IrcClientLibrary As GUID = Type(&h522e5895, &h8bc8, &h4e78, _
	{&hbd, &hac, &h98, &hdd, &h8c, &h10, &h8f, &h68})

CoInitialize(0)

Dim hr As HRESULT = Any

' Загрузка библиотеки типов stdole32.tlb и получение интерфейсов

Dim pIUnknownTypeInfo As ITypeInfo Ptr = Any
Dim pIDispatchTypeInfo As ITypeInfo Ptr = Any

Scope
	Dim pStdOleTypeLib As ITypeLib Ptr = Any
	hr = LoadTypeLib(@StdOleLibrary, @pStdOleTypeLib)
	
	hr = pStdOleTypeLib->lpVtbl->GetTypeInfoOfGuid(pStdOleTypeLib, @IID_IUnknown, @pIUnknownTypeInfo)
	hr = pStdOleTypeLib->lpVtbl->GetTypeInfoOfGuid(pStdOleTypeLib, @IID_IDispatch, @pIDispatchTypeInfo)
	
	pStdOleTypeLib->lpVtbl->Release(pStdOleTypeLib)
End Scope


' Настройка библиотеки типов

Dim pCreateTypeLib As ICreateTypeLib2 Ptr = Any

Scope
	hr = CreateTypeLib2(SYS_WIN32, @IrcClientTypeLibFileName, @pCreateTypeLib)
	
	hr = pCreateTypeLib->lpVtbl->SetName(pCreateTypeLib, @IrcClientTypeLibName)
	hr = pCreateTypeLib->lpVtbl->SetGuid(pCreateTypeLib, @LIBID_IrcClientLibrary)
	hr = pCreateTypeLib->lpVtbl->SetVersion(pCreateTypeLib, 1, 0)
	hr = pCreateTypeLib->lpVtbl->SetLcid(pCreateTypeLib, 1049) ' русский язык
	hr = pCreateTypeLib->lpVtbl->SetDocString(pCreateTypeLib, @IrcClientTypeLibDescription)
End Scope

' Интерфейс IIrcClient
Dim pIIrcClientTypeInfo As ITypeInfo Ptr = Any

Scope
	Dim pCreateTypeInfoIIrcClient As ICreateTypeInfo Ptr = Any
	
	' Настройка интерфейса IIrcClient
	
	Scope
		hr = pCreateTypeLib->lpVtbl->CreateTypeInfo(pCreateTypeLib, @IIrcClientInterfaceName, TKIND_INTERFACE, @pCreateTypeInfoIIrcClient)
		
		hr = pCreateTypeInfoIIrcClient->lpVtbl->SetGuid(pCreateTypeInfoIIrcClient, @IID_IIrcClient)
		hr = pCreateTypeInfoIIrcClient->lpVtbl->SetDocString(pCreateTypeInfoIIrcClient, @IIrcClientInterfaceDescription)
		hr = pCreateTypeInfoIIrcClient->lpVtbl->SetTypeFlags(pCreateTypeInfoIIrcClient, TYPEFLAG_FDUAL Or TYPEFLAG_FOLEAUTOMATION)
		hr = pCreateTypeInfoIIrcClient->lpVtbl->SetVersion(pCreateTypeInfoIIrcClient, 1, 0)
		
		Dim RefType As HREFTYPE = Any
		hr = pCreateTypeInfoIIrcClient->lpVtbl->AddRefTypeInfo(pCreateTypeInfoIIrcClient, pIDispatchTypeInfo, @RefType)
		hr = pCreateTypeInfoIIrcClient->lpVtbl->AddImplType(pCreateTypeInfoIIrcClient, 0, RefType)
		
	End Scope
	
	' Добавление функций
	
	Dim HresultReturnedValue As ELEMDESC
	With HresultReturnedValue
		.tdesc.vt = VT_HRESULT
		.idldesc.dwReserved = NULL
		.idldesc.wIDLFlags = IDLFLAG_NONE
	End With
	
	Dim CurrentFunctionIndex As Long = 0
	
	' ShowMessageBox
	
	Scope
		
		Const MaxArgumentsLength As SHORT = 2
		Const MaxArgumentsNamesLength As UINT = 3
		Const MaxReturnedScodesLength As SHORT = 1
		
		Dim ArgumentsNames(MaxArgumentsNamesLength - 1) As WString Ptr = Any
		' Название функции
		ArgumentsNames(0) = @ShowMessageBoxFunctionName
		' Название параметров
		ArgumentsNames(1) = @ParamParamName
		ArgumentsNames(2) = @ParamResultName
		
		Dim ReturnedScodes(MaxReturnedScodesLength) As SCODE = Any
		ReturnedScodes(0) = S_OK
		
		Dim Arguments(MaxArgumentsLength - 1) As ELEMDESC
		With Arguments(0)
			.tdesc.vt = VT_I4 ' Long
			.idldesc.dwReserved = NULL
			.idldesc.wIDLFlags = IDLFLAG_FIN ' IDLFLAG_NONE, IDLFLAG_FIN, IDLFLAG_FOUT, IDLFLAG_FLCID, IDLFLAG_FRETVAL
		End With
		
		Dim dd As TYPEDESC
		With dd
			.vt = VT_I4 ' Long
		End With
		With Arguments(1)
			.tdesc.lptdesc = @dd
			.tdesc.vt = VT_PTR ' Long Ptr
			.idldesc.dwReserved = NULL
			.idldesc.wIDLFlags = IDLFLAG_FOUT Or IDLFLAG_FRETVAL
		End With
		
		Dim ShowMessageBoxDefinition As FUNCDESC = Any
		With ShowMessageBoxDefinition
			.memid = ShowMessageBoxFunctionMemberId ' Индекс в виртуальной таблице функций
			.lprgscode = @ReturnedScodes(0) ' Массив возможных возвращаемых значений HRESULT
			.lprgelemdescParam = @Arguments(0)
			.funckind = FUNC_PUREVIRTUAL ' Чисто виртуальная функция
			.invkind = INVOKE_FUNC ' INVOKE_PROPERTYGET, INVOKE_PROPERTYPUT, INVOKE_PROPERTYPUTREF
			.callconv = CC_STDCALL ' Соглашение о вызове
			.cParams = MaxArgumentsLength ' Количество параметров
			.cParamsOpt = 0 ' Количество опциональных параметров
			.oVft = 0 ' Индекс функции в виртуальной таблице, указывается только для FUNC_VIRTUAL
			.cScodes = MaxReturnedScodesLength ' Количество возвращаемых значений
			.elemdescFunc = HresultReturnedValue ' Функция возвращает HRESULT
			.wFuncFlags = 0
		End With
		
		hr = pCreateTypeInfoIIrcClient->lpVtbl->AddFuncDesc(pCreateTypeInfoIIrcClient, CurrentFunctionIndex, @ShowMessageBoxDefinition)
		If FAILED(hr) Then
			Print "Не могу добавить функцию ShowMessageBox в интерфейс IIrcClient", Hex(hr)
		End If
		
		hr = pCreateTypeInfoIIrcClient->lpVtbl->SetFuncAndParamNames(pCreateTypeInfoIIrcClient, CurrentFunctionIndex, @ArgumentsNames(0), MaxArgumentsNamesLength)
		If FAILED(hr) Then
			Print "Не могу добавить имена функций и параметров ShowMessageBox в интерфейс IIrcClient", Hex(hr)
		End If
		
		hr = pCreateTypeInfoIIrcClient->lpVtbl->SetFuncDocString(pCreateTypeInfoIIrcClient, CurrentFunctionIndex, @ShowMessageBoxFunctionDescription)
		If FAILED(hr) Then
			Print "Не могу добавить описание функции ShowMessageBox в интерфейс IIrcClient", Hex(hr)
		End If
	End Scope
	
	CurrentFunctionIndex += 1
	
	hr = pCreateTypeInfoIIrcClient->lpVtbl->QueryInterface(pCreateTypeInfoIIrcClient, @IID_ITypeInfo, @pIIrcClientTypeInfo)
	
	pCreateTypeInfoIIrcClient->lpVtbl->LayOut(pCreateTypeInfoIIrcClient)
	
	pCreateTypeInfoIIrcClient->lpVtbl->Release(pCreateTypeInfoIIrcClient)
End Scope

' Настройка класса IrcClient

Scope
	Dim pCreateTypeInfoIrcClient As ICreateTypeInfo Ptr = Any
	hr = pCreateTypeLib->lpVtbl->CreateTypeInfo(pCreateTypeLib, @"IrcClient", TKIND_COCLASS, @pCreateTypeInfoIrcClient)
	
	hr = pCreateTypeInfoIrcClient->lpVtbl->SetGuid(pCreateTypeInfoIrcClient, @CLSID_IRCCLIENT)
	hr = pCreateTypeInfoIrcClient->lpVtbl->SetDocString(pCreateTypeInfoIrcClient, @IrcClientClassDescription)
	
	Dim RefType As HREFTYPE = Any
	hr = pCreateTypeInfoIrcClient->lpVtbl->AddRefTypeInfo(pCreateTypeInfoIrcClient, pIIrcClientTypeInfo, @RefType)
	hr = pCreateTypeInfoIrcClient->lpVtbl->AddImplType(pCreateTypeInfoIrcClient, 0, RefType)
	
	pCreateTypeInfoIrcClient->lpVtbl->LayOut(pCreateTypeInfoIrcClient)
	
	pCreateTypeInfoIrcClient->lpVtbl->Release(pCreateTypeInfoIrcClient)
End Scope

' Сохранение изменений на диске

hr = pCreateTypeLib->lpVtbl->SaveAllChanges(pCreateTypeLib)
If FAILED(hr) Then
	Print "Не могу сохранить изменения на диск", Hex(hr)
End If

' Завершение
pIIrcClientTypeInfo->lpVtbl->Release(pIIrcClientTypeInfo)
pCreateTypeLib->lpVtbl->Release(pCreateTypeLib)

CoUnInitialize()