LangMF 9.0: Создание COM Automation объекта без регистрации библиотеки

' Без гарантий! Используете на свой страх и риск.
'------------------------------------------------------------------------------------------
' Скрипт предназначен для создания Automation объектов без регистрации библиотеки в реестре.
'
' Аргументы функции GetObjectFromDLL:
' sPath    Путь к COM библиотеке, строка.
' sCLSID   Идентификатор класса CLSID, строка вида "{xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx}".
' sUUID    Идентификатор интерфейса IID, строка вида "{xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx}".
'
'
' Потребуется установленный LangMF 9.0 (http://langmf.ru/ftp/archive/LangMF_9.0.exe)
' OC WinXP
'------------------------------------------------------------------------------------------
Public Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Long, pclsid As Guid) As Long
'------------------------------------------------------------------------------------------
<#Module=DispNoRegCall>

'------------------------------------------------------------------------------------------
' Создание Automation объектов и работа с ними
'------------------------------------------------------------------------------------------
Sub Load(cmdstr)

	Dim oAU3, oWshExtra
	Dim sFile

	' WshExtra.FileChooser
	'-----------------------------------------------------------------------------------
	Set oWshExtra = GetObjectFromDLL("G:\WshExtra.dll", _
					"{D199C0CE-78E8-4DE2-B863-CCDC022A2FCA}", _
					"{1FBCEB53-17E7-438F-926E-643ABC236A51}")
					
	MsgBox "Созданный тип [" & TypeName(oWshExtra) & "].", vbSystemModal + vbInformation, "Reply"
		oWshExtra.Title = "Открытие файла..."
		oWshExtra.Filter = "Все файлы|*.*|"
		sFile = oWshExtra.Browse("C:\") 
		If Len(sFile)<>0 Then MsgBox "Выбранный файл: " & sFile, vbSystemModal + vbInformation, "Reply"

	' AutoItX3.Control
	'-----------------------------------------------------------------------------------
	Set oAU3 = GetObjectFromDLL(	"G:\AutoItX3.dll", _
					"{1A671297-FA74-4422-80FA-6C5D8CE4DE04}", _
					"{3D54C6B8-D283-40E0-8FAB-C97F05947EE8}")
					
	MsgBox "Созданный тип [" & TypeName(oAU3) & "].", vbSystemModal + vbInformation, "Reply"	
	oAU3.ToolTip vbCRLF & "Создание Automation объекта без регистрации библиотеки..." & vbCRLF, 100, 100
	oAU3.Sleep(4000)
	'-----------------------------------------------------------------------------------
	EndMF
End Sub

'------------------------------------------------------------------------------------------
' Создать Automation объект из незарегистрированной в реестре библиотеки
'------------------------------------------------------------------------------------------
Function GetObjectFromDLL(sPath, sCLSID, sUUID)

	Const S_OK = 0
	Const CreateInstanceID = 3
	Const GetTypeInfoOfGuidID = 6
	Const QueryInterfaceID = 0
	Const REGKIND_NONE = 2
	Const REGKIND_DEFAULT = 0
	'-----------------------------------------------------------------------------------
	Dim hRes
	Dim pvarRes
	Dim pCLSID, pIClassFactory, pIDispatch, pIUnknown, pUUID
	Dim p1, p2, p3, p4, p5, p6
	Dim objX

	'-----------------------------------------------------------------------------------
	Const sIID_IClassFactory = "{00000001-0000-0000-C000-000000000046}"
	Const sIID_IDispatch = "{00020400-0000-0000-C000-000000000046}"
	Const sIID_IUnknown = "{00000000-0000-0000-C000-000000000046}"

	'-----------------------------------------------------------------------------------
	Sys.DynAPI.CallFunction "OLE32.DLL", "CoInitialize", 0

	' Подготовить память для GUID и возвращаемого результата
	'-----------------------------------------------------------------------------------
	Sys.DynAPI.CurBuf = 0
	Sys.DynAPI.ReBuf(16)
	pCLSID = Sys.DynAPI.PtrBuf(0)

	Sys.DynAPI.CurBuf = 1
	Sys.DynAPI.ReBuf(16)
	pIClassFactory = Sys.DynAPI.PtrBuf(1)

	Sys.DynAPI.CurBuf = 2
	Sys.DynAPI.ReBuf(16)
	pIDispatch = Sys.DynAPI.PtrBuf(2)

	Sys.DynAPI.CurBuf = 3
	Sys.DynAPI.ReBuf(16)
	pIUnknown = Sys.DynAPI.PtrBuf(3)

	Sys.DynAPI.CurBuf = 4
	Sys.DynAPI.ReBuf(16)
	pUUID = Sys.DynAPI.PtrBuf(4)

	Sys.DynAPI.CurBuf = 5
	Sys.DynAPI.ReBuf(4)
	pvarRes = Sys.DynAPI.PtrBuf(5)

	' Преобразовать строковые идентификаторы в GUID
	'-----------------------------------------------------------------------------------
	Call CLSIDFromString(Sys.StrPtr(sCLSID), pCLSID)
	Call CLSIDFromString(Sys.StrPtr(sIID_IClassFactory), pIClassFactory)
	Call CLSIDFromString(Sys.StrPtr(sIID_IDispatch), pIDispatch)
	Call CLSIDFromString(Sys.StrPtr(sIID_IUnknown), pIUnknown)
	Call CLSIDFromString(Sys.StrPtr(sUUID), pUUID)

	
	'===============================================
	' Получить фабрику классов IClassFactory
	'-----------------------------------------------------------------------------------
	hRes = Sys.DynAPI.CallFunction(sPath, "DllGetClassObject", pCLSID, pIClassFactory, pvarRes)
		If hRes <> S_OK Then ErrMsg(hRes): Set GetObjectFromDLL = Nothing: Exit Function
		p1 = RetPtr()
		

	' Вернуть указатель на IDispatch путем вызова CreateInstance из фабрики IClassFactory
	'-----------------------------------------------------------------------------------
	hRes = Sys.DynApi.CallInterface(p1, CreateInstanceID, 3, 0, pIDispatch, pvarRes)
		If hRes <> S_OK Then ErrMsg(hRes): Set GetObjectFromDLL = Nothing: Exit Function
		p2 = RetPtr()
	
	' Если здесь попробовать восстановить объект по указателю [Set GetObjectFromDLL = Sys.ObjFromPtr(p2)],
	' то такая схема работать не будет, т.к TypeLib не зарегистрирована, будет получен "пустой"
	' объект, без свойств и методов. Нужно подключить библиотеку типов и загрузить указатель
	' на TypeInfo для заданного интерфейса UUID.
	
	'===============================================
	' Загрузить встроенную библиотеку типов
	'-----------------------------------------------------------------------------------
	hRes = Sys.DynAPI.CallFunction("OLEAUT32.DLL", "LoadTypeLibEx", Sys.StrConv(sPath,vbUnicode), REGKIND_NONE, pvarRes)
		If hRes <> S_OK Then ErrMsg(hRes): Set GetObjectFromDLL = Nothing: Exit Function
		p3 = RetPtr()

	' Получить указатель на TypeInfo для заданного интерфейса UUID
	'-----------------------------------------------------------------------------------
	hRes = Sys.DynApi.CallInterface(p3, GetTypeInfoOfGuidID, 2, pUUID, pvarRes)
		If hRes <> S_OK Then ErrMsg(hRes): Set GetObjectFromDLL = Nothing: Exit Function
		p4 = RetPtr()

	' Получить IUnknown заданного интерфейса на основе TypeInfo 
	'-----------------------------------------------------------------------------------
	hRes = Sys.DynAPI.CallFunction("OLEAUT32.DLL", "CreateStdDispatch", 0, p2, p4, pvarRes)
		If hRes <> S_OK Then ErrMsg(hRes): Set GetObjectFromDLL = Nothing: Exit Function
		p5 = RetPtr()

	' Получить IDispatch заданного интерфейса
	'-----------------------------------------------------------------------------------
	hRes = Sys.DynApi.CallInterface(p5, QueryInterfaceID, 2, pIDispatch, pvarRes)
		If hRes <> S_OK Then ErrMsg(hRes): Set GetObjectFromDLL = Nothing: Exit Function
		p6 = RetPtr()

	'===============================================
	' Восстановить и вернуть объект
	'-----------------------------------------------------------------------------------
	Set GetObjectFromDLL = Sys.ObjFromPtr(p6)
	If Not IsObject(GetObjectFromDLL) Then ErrMsg("Не удалось получить объект."): Set GetObjectFromDLL = Nothing: Exit Function
		
	
	'-----------------------------------------------------------------------------------
	Sys.DynAPI.CallFunction "OLE32.DLL", "CoUninitialize"

End Function

' Извлечение значения из указателя
'------------------------------------------------------------------------------------------
Function RetPtr()
	Dim buf()
	Sys.DynAPI.GetBuf buf, 5
	RetPtr = Sys.Conv.Byte4Long (buf(3),buf(2),buf(1),buf(0))	
End Function

' Сообщение об ошибке
'------------------------------------------------------------------------------------------
Sub ErrMsg(vMsg)
	Sys.DynAPI.CallFunction "OLE32.DLL", "CoUninitialize"
	Sys.Sleep(100)
	MsgBox "Произошла ошибка: " & CStr(vMsg), vbSystemModal + vbExclamation, "Error Reply"
End Sub
'------------------------------------------------------------------------------------------
<#Module>