Code: Alles auswählen
; Description: ExportCOM-Definition (Work as IncludeFile and as RES-File)
; Author: GPI
; Date: 2017-05-14
; PB-Version: 5.60
; OS: Windows
; English-Forum:
; French-Forum:
; German-Forum: http://www.purebasic.fr/german/viewtopic.php?f=8&t=30144
; -----------------------------------------------------------------------------
; Compile this file with /RESIDENT for create a RES file
; OR use it as IncludeFile (UseModul Class)
;
; Changelog 1.2
; CHANGE: New_IDispatch(*obj) - when you want to create a Dispatch, use this routine.
;
; Changelog 1.1
; - Bugfix
;http://www.codeguru.com/cpp/com-tech/activex/tutorials/article.php/c5567/Step-by-Step-COM-Tutorial.htm
;https://msdn.microsoft.com/en-us/library/cc237842.aspx
;https://msdn.microsoft.com/en-us/library/windows/desktop/ms688707(v=vs.85).aspx
;<Program>.<Component>.<Version>,
;dispid .w
;lcid .l
;{ Warper for IncludeFile
CompilerIf #PB_Compiler_IsMainFile=#False
CompilerIf Not Defined(BaseClass,#PB_Structure)
XIncludeFile "class.pbi"
CompilerEndIf
CompilerIf Defined(DoLogClass,#PB_Constant)
CompilerIf #DoLogClass
DeclareModule ExportCom
#LogClass=#True
CompilerIf #False:EndDeclareModule:CompilerEndIf;Correction of the Indention
CompilerElse
DeclareModule ExportCom
#LogClass=#False
CompilerIf #False:EndDeclareModule:CompilerEndIf;Correction of the Indention
CompilerEndIf
CompilerElse
DeclareModule ExportCom
#LogClass=#False
CompilerIf #False:EndDeclareModule:CompilerEndIf;Correction of the Indention
CompilerEndIf
EnableExplicit
CompilerIf Defined(Class,#PB_Module)
UseModule Class
CompilerEndIf
CompilerIf #False:EndDeclareModule:CompilerEndIf;Correction of the Indention
CompilerEndIf
;}
#ExportCom_Version=$0102
;{ Macros
Macro ReturnString(string)
SysAllocString_(string)
EndMacro
Macro BStr(string)
SysAllocString_(string)
EndMacro
Macro FreeBStr(string)
SysFreeString_(string)
EndMacro
Macro _p_BStr
i
EndMacro
Macro _p_DISPATCH
i
EndMacro
Macro LogClass(type,text,class=0)
CompilerIf #LogClass
__LogClass(type,text,#PB_Compiler_Procedure,class)
CompilerEndIf
EndMacro
Macro Method_QueryInterface(class,parentClass,classiid)
Procedure class#_QueryInterface(*self._iunknown,*riid.iid,*out_Object.integer)
;LogClass(#logclass_info,"Test for "+GetStringFromGuid(*riid),*self)
Protected count
If *out_Object=0 Or *riid=0
LogClass(#LogClass_Error,"No Pointer",*self)
ProcedureReturn #E_POINTER
EndIf
If CompareMemory(*riid, classiid, SizeOf(iid))
count=ReferenceObject(*self)
LogClass(#LogClass_Info,"OK ("+count+")",*self)
*out_Object\i=*self
ProcedureReturn #S_OK
EndIf
CompilerIf Defined(parentClass#_QueryInterface,#PB_Procedure)
ProcedureReturn parentClass#_QueryInterface(*self,*riid,*out_Object)
CompilerElseIf Defined(parentclass#_GetVTable__,#PB_Procedure)
ProcedureReturn CallFunctionFast(PeekI(parentclass#_GetVTable__()+OffsetOf(iunknown\QueryInterface())),*self,*riid,*out_Object)
CompilerElse
CompilerIf #LogClass
Protected a$
a$=GetStringFromGuid(*riid)
If a$="342D1EA0-AE25-11D1-89C5-006008C3FBFC"
a$="IClassFactoryEx"
ElseIf a$="FC4801A3-2BA9-11CF-A229-00AA003D7352"
a$="IObjectWithSite"
ElseIf a$="A6EF9860-C720-11D0-9337-00A0C90DCAA9"
a$="IDispatchEx"
EndIf
LogClass(#LogClass_error,"Interface not supported: "+a$,*self)
CompilerEndIf
ProcedureReturn #E_NOINTERFACE
CompilerEndIf
EndProcedure:AsMethod(class,QueryInterface)
EndMacro
Macro Dispatch_PropertyGet(class,property)
CompilerSelect TypeOf(_#class\property)
CompilerCase #PB_Byte
Procedure.b class#_PROPERTYGET_#property(*self._#class):ProcedureReturn *self\property:EndProcedure
CompilerCase #PB_Ascii
Procedure.a class#_PROPERTYGET_#property(*self._#class):ProcedureReturn *self\property:EndProcedure
CompilerCase #PB_Word
Procedure.w class#_PROPERTYGET_#property(*self._#class):ProcedureReturn *self\property:EndProcedure
CompilerCase #PB_Unicode
Procedure.u class#_PROPERTYGET_#property(*self._#class):ProcedureReturn *self\property:EndProcedure
CompilerCase #PB_Long
Procedure.l class#_PROPERTYGET_#property(*self._#class):ProcedureReturn *self\property:EndProcedure
CompilerCase #PB_Quad
Procedure.q class#_PROPERTYGET_#property(*self._#class):ProcedureReturn *self\property:EndProcedure
CompilerCase #PB_Float
Procedure.f class#_PROPERTYGET_#property(*self._#class):ProcedureReturn *self\property:EndProcedure
CompilerCase #PB_Double
Procedure.d class#_PROPERTYGET_#property(*self._#class):ProcedureReturn *self\property:EndProcedure
CompilerCase #PB_String
Procedure.i class#_PROPERTYGET_#property(*self._#class):ProcedureReturn ReturnString(*self\property):EndProcedure
CompilerEndSelect
AsMethod(class,PROPERTYGET_#property)
EndMacro
Macro Dispatch_PropertyPut(class,property)
CompilerSelect TypeOf(_#class\property)
CompilerCase #PB_Byte
Procedure class#_PROPERTYPUT_#property(*self._#class,value.b):*self\property=value:EndProcedure
CompilerCase #PB_Ascii
Procedure class#_PROPERTYPUT_#property(*self._#class,value.a):*self\property=value:EndProcedure
CompilerCase #PB_Word
Procedure class#_PROPERTYPUT_#property(*self._#class,value.w):*self\property=value:EndProcedure
CompilerCase #PB_Unicode
Procedure class#_PROPERTYPUT_#property(*self._#class,value.u):*self\property=value:EndProcedure
CompilerCase #PB_Long
Procedure class#_PROPERTYPUT_#property(*self._#class,value.l):*self\property=value:EndProcedure
CompilerCase #PB_Quad
Procedure class#_PROPERTYPUT_#property(*self._#class,value.q):*self\property=value:EndProcedure
CompilerCase #PB_Float
Procedure class#_PROPERTYPUT_#property(*self._#class,value.f):*self\property=value:EndProcedure
CompilerCase #PB_Double
Procedure class#_PROPERTYPUT_#property(*self._#class,value.d):*self\property=value:EndProcedure
CompilerCase #PB_String
Procedure class#_PROPERTYPUT_#property(*self._#class,value.s):*self\property=value:EndProcedure
CompilerEndSelect
AsMethod(class,PROPERTYPUT_#property)
EndMacro
Macro __ExportCounter
MacroExpandedCount
EndMacro
Macro ExportCom()
ProcedureDLL AttachThread(Instance)
;LogClass(#LogClass_Info,"Attach Thread "+Hex(Instance))
EndProcedure
ProcedureDLL DetachThread(Instance)
;LogClass(#LogClass_Info,"Detach Thread "+Hex(Instance))
EndProcedure
ProcedureDLL AttachProcess(Instance)
Protected a$,nb,*cc.__ComClass
Protected *nVT.__Class_nVT
CompilerIf Defined(InitDll,#PB_Procedure)
InitDll()
CompilerEndIf
LogClass(#LogClass_Info,"------- DLL load -------");+Hex(Instance))
Global Dim __ComClass.__ComClass(PeekI(?label))
EndMacro
Macro ExportClass(class,pid,ciid,desc,InterfacedataString)
*cc=__ComClass(__ExportCounter-1)
*cc\ProgramID= pid
*cc\CLSID= ciid
*cc\Description= desc
GetGuidFromString(*cc\CLSID,*cc\iid)
*cc\vt=class#_GetVTable__()
If *cc\vt
*nvt=*cc\VT-SizeOf(__Class_nVT)
*nvt\exportclass=*cc
a$=PeekS(*nvt\classname);PeekS(PeekI(*cc\vt-SizeOf(__Class_nVT)+OffsetOf(__Class_nVT\ClassName)))
Else
a$=""
EndIf
*cc\interfacedata=__Create_InterfaceData(*cc\vt, InterfacedataString)
If *cc\interfacedata
If CreateDispTypeInfo_(*cc\interfacedata,#LOCALE_SYSTEM_DEFAULT,@ *cc\typeinfo)=#S_OK
LogClass(#LogClass_Info,"ITypeInfo created for "+a$)
Else
LogClass(#LogClass_Error,"Can't create ITypeInfo for "+a$)
EndIf
Else
LogClass(#LogClass_Error,"Can't create InterfaceData for "+a$)
EndIf
EndMacro
Macro EndExportCom()
DataSection
label:
Data.i __ExportCounter-2
EndDataSection
EndProcedure
ProcedureDLL DetachProcess(Instance) ;-DetachProcess
Protected a$
LogClass(#LogClass_Info,"------- DLL unload -------");+Hex(Instance))
Protected i
For i=0 To ArraySize(__ComClass())
If __ComClass(i)\ClassFactory
__ComClass(i)\ClassFactory\Release()
__ComClass(i)\ClassFactory=0
EndIf
If __ComClass(i)\vt
a$=PeekS(PeekI(__ComClass(i)\vt-SizeOf(__Class_nVT)+OffsetOf(__Class_nVT\ClassName)))
Else
a$=""
EndIf
If __ComClass(i)\typeinfo
__ComClass(i)\typeinfo\Release()
__ComClass(i)\typeinfo=0
EndIf
LogClass(#LogClass_Info,"Free TypeInfo for "+a$)
If __ComClass(i)\interfacedata
__Free_InterfaceData(__ComClass(i)\interfacedata)
__ComClass(i)\interfacedata=0
EndIf
Next
CompilerIf Defined(ExitDll,#PB_Procedure)
ExitDll()
CompilerEndIf
LogClass(#LogClass_HR,"")
LogClass("","")
EndProcedure
ProcedureDLL DllGetClassObject(*rclsid,*riid,*out_object.integer);- DllGetClassObject
Protected i,hres
If *out_object=0 Or *rclsid=0 Or *riid=0
LogClass(#LogClass_error,"pointer is zero")
ProcedureReturn #E_INVALIDARG
EndIf
*out_object\i=0
hres= #CLASS_E_CLASSNOTAVAILABLE
If CompareMemory(*riid,?IID_IClassFactory,SizeOf(iid))
For i=0 To ArraySize(__ComClass())
If __ComClass(i)\clsid<>"" And __ComClass(i)\programid<>"" And __ComClass(i)\Description<>"" And
CompareMemory(*rclsid,__ComClass(i)\iid,SizeOf(iid))
If __ComClass(I)\ClassFactory=0
__ComClass(I)\ClassFactory=IClassFactory(__ComClass(i)\vt)
EndIf
If __ComClass(I)\ClassFactory
__ComClass(i)\ClassFactory\AddRef()
*out_object\i=__ComClass(I)\ClassFactory
CompilerIf #logclass
Protected a$=GetClassIdName(__ComClass(i)\vt)
CompilerEndIf
hres=#S_OK
EndIf
Break
EndIf
Next
CompilerIf #LogClass
If hres=#S_OK
LogClass(#LogClass_Info,"New IClassFactory@"+Hex(*out_object\i)+" with "+a$)
Else
LogClass(#LogClass_Error,"Class not available "+GetStringFromGuid(*rclsid))
EndIf
Else
LogClass(#LogClass_Error,"Only support for IClassFactory "+GetStringFromGuid(*riid))
CompilerEndIf
EndIf
ProcedureReturn hres
EndProcedure
ProcedureDLL DllCanUnloadNow();- DllCanUnloadNow
Protected i
Protected *nVT.__Class_nVT
Protected hres=#S_OK
Protected count=0
CompilerIf #logclass
Protected a$
a$=" Lock:"+IClassFactory_LockCount+
" IDispatch:"+CountObject(IDispatch)+
" IClassFactory:"+CountObject(IClassFactory)
CompilerEndIf
count=IClassFactory_LockCount
count+ CountObject(IDispatch)
count+ CountObject(IClassFactory)
For i=0 To ArraySize(__ComClass())
*nVT=__ComClass(I)\vt-SizeOf(__Class_nVT)
count+ *nvt\count
If __ComClass(i)\ClassFactory
count- 1
EndIf
CompilerIf #LogClass
a$+" "+ PeekS(*nvt\ClassName) +":"+ *nVT\Count
CompilerEndIf
Next
If count<>0
hres=#S_FALSE
EndIf
CompilerIf #LogClass
a$="Count:"+count+" "+a$
If hres=#S_OK
LogClass(#LogClass_Info,"ok "+a$)
Else
LogClass(#LogClass_Info,"False "+a$)
EndIf
CompilerEndIf
ProcedureReturn hres
EndProcedure
ProcedureDLL DllUnregisterServer();-DllUnregisterServer
Protected a$,i,hres=#S_OK
For i=0 To ArraySize(__ComClass())
If __ComClass(i)\clsid<>"" And __ComClass(i)\ProgramID<>"" And __ComClass(i)\Description<>""
a$="{"+ __ComClass(i)\CLSID +"}"
If RegDeleteKey_(#HKEY_CLASSES_ROOT, "CLSID\" + a$ + "\ProgId") <> #ERROR_SUCCESS : hres=#E_UNEXPECTED :EndIf
If RegDeleteKey_(#HKEY_CLASSES_ROOT, "CLSID\" + a$ + "\InprocServer32") <> #ERROR_SUCCESS : hres=#E_UNEXPECTED :EndIf
If RegDeleteKey_(#HKEY_CLASSES_ROOT, "CLSID\" + a$) <> #ERROR_SUCCESS : hres=#E_UNEXPECTED :EndIf
If RegDeleteKey_(#HKEY_CLASSES_ROOT, __ComClass(i)\ProgramID + "\CLSID") <> #ERROR_SUCCESS : hres=#E_UNEXPECTED :EndIf
If RegDeleteKey_(#HKEY_CLASSES_ROOT, __ComClass(i)\ProgramID) <> #ERROR_SUCCESS : hres=#E_UNEXPECTED :EndIf
LogClass(#LogClass_info,"Unregister "+ __ComClass(i)\ProgramID+" "+ a$)
EndIf
Next
CompilerIf #LogClass
If hres=#ERROR_SUCCESS
LogClass(#LogClass_Info,"OK")
Else
LogClass(#LogClass_Error,"Can't delete RegKeys")
EndIf
CompilerEndIf
ProcedureReturn hres
EndProcedure
Procedure Regkey__(key.s,value.s);-RegKey__
Protected hres=#S_OK,hKey.i
If RegCreateKeyEx_(#HKEY_CLASSES_ROOT, key, 0, 0, #REG_OPTION_NON_VOLATILE, #KEY_ALL_ACCESS, 0, @hKey, 0)=#ERROR_SUCCESS
If RegSetValueEx_(hKey, "", 0, #REG_SZ, value, StringByteLength(value) + 2)<>#ERROR_SUCCESS
hres=#E_UNEXPECTED
EndIf
If RegCloseKey_(hKey)<>#ERROR_SUCCESS
hres=#E_UNEXPECTED
EndIf
Else
hres=#E_UNEXPECTED
EndIf
ProcedureReturn hres
EndProcedure
ProcedureDLL DllRegisterServer();-DllRegisterServer
Protected DLL_Name.s
Protected i.i,hres=#S_OK
Protected a$
DLL_Name = ProgramFilename()
For i=0 To ArraySize(__ComClass())
If __ComClass(i)\clsid<>"" And __ComClass(i)\ProgramID<>"" And __ComClass(i)\Description<>"" And __ComClass(i)\iid
a$="{"+ __ComClass(i)\CLSID +"}"
If Not(regkey__(__ComClass(i)\ProgramID ,__ComClass(i)\Description) =#S_OK And
regkey__(__ComClass(i)\ProgramID+"\CLSID",a$) =#S_OK And
regkey__("CLSID\"+a$ ,__ComClass(i)\Description) =#S_OK And
regkey__("CLSID\"+a$+"\InprocServer32" ,DLL_Name) =#S_OK And
Regkey__("CLSID\"+a$+"\ProgId" ,__ComClass(i)\ProgramID ) =#S_OK)
hres=#E_UNEXPECTED
Break
EndIf
LogClass(#LogClass_info,"Register "+ __ComClass(i)\ProgramID+" "+ a$)
EndIf
Next
If hres<>#ERROR_SUCCESS
DllUnregisterServer()
CompilerIf #LogClass
LogClass(#LogClass_Error,"Can't create RegKeys")
Else
LogClass(#LogClass_Info,"OK")
CompilerEndIf
EndIf
ProcedureReturn hres
EndProcedure
CompilerIf #PB_Compiler_ExecutableFormat<>#PB_Compiler_DLL ;Or #PB_Compiler_Debugger
AttachProcess(0)
CompilerEndIf
EndMacro
;}
;{ Constants
#DISPID_UNKNOWN=-1
#DISPID_VALUE=0
#DISPID_PROPERTYPUT=-3
Enumeration CALLCONV
#CC_FASTCALL = 0
#CC_CDECL = 1
#CC_MSCPASCAL = ( #CC_CDECL + 1 )
#CC_PASCAL = #CC_MSCPASCAL
#CC_MACPASCAL = ( #CC_PASCAL + 1 )
#CC_STDCALL = ( #CC_MACPASCAL + 1 )
#CC_FPFASTCALL = ( #CC_STDCALL + 1 )
#CC_SYSCALL = ( #CC_FPFASTCALL + 1 )
#CC_MPWCDECL = ( #CC_SYSCALL + 1 )
#CC_MPWPASCAL = ( #CC_MPWCDECL + 1 )
#CC_MAX = ( #CC_MPWPASCAL + 1 )
EndEnumeration
#VT_PBByte=#VT_I1
#VT_PBAscii=#VT_UI1
#VT_PBWord=#VT_I2
#VT_PBUnicode=#VT_UI2
#VT_PBLong=#VT_I4
#VT_PBQuad=#VT_I8
#VT_PBFloat=#VT_R4
#VT_PBDouble=#VT_R8
#VT_PBString=#VT_BSTR
CompilerIf #PB_Compiler_Processor=#PB_Processor_x64
#VT_PBInteger=#VT_I8
CompilerElse
#VT_PBInteger=#VT_I4
CompilerEndIf
;}
;{ Structures
Structure __ComClass
ProgramID.s
CLSID.s
Description.s
iid.iid
*vt
*interfacedata
*typeinfo.ITypeinfo
*ClassFactory.IClassFactory
EndStructure
Structure __pbvariant
vt.w
wReserved1.w
wReserved2.w
wReserved3.w
StructureUnion
Ascii.a
Byte.b
Word.w
Unicode.u
Long.l
Quad.q
Float.f
Double.d
*String
Integer.i
*Pointer
EndStructureUnion
EndStructure
Structure PBVariant
StructureUnion
vt.w
PB.__pbvariant
Variant.variant
EndStructureUnion
EndStructure
Structure INTERFACEDATA Align #PB_Structure_AlignC
*pmethdata
cMembers.l
EndStructure
Structure MethodData Align #PB_Structure_AlignC
*szName;OLECHAR
*ppdata;PARAMDATA
dispid.l;
iMeth.l ;
cc.l ;CALLCONV
cArgs.l ;
wFlags.w;
vtReturn.u;VARTYPE
EndStructure
Structure PARAMDATA Align #PB_Structure_AlignC
*szName;OLECHAR
vt.u ;VARTYPE
EndStructure
;}
Macro InitExportCom(DoLogFile=#False)
CompilerIf Not Defined(ExportCom,#PB_Module)
DeclareModule ExportCom
CompilerIf Defined(Class,#PB_Module)
UseModule Class
CompilerEndIf
EnableExplicit
CompilerEndIf
CompilerIf #CLASS_Version<$0104
CompilerError "Outdated Class.pbi"
CompilerEndIf
CompilerIf Not Defined(LogClass,#PB_Constant)
#LogClass=DoLogFile
CompilerEndIf
CompilerIf #LogClass
Global LogClass_FileName.s
Declare __LogClass(Type.s,Text.s,Proc.s,*class.BaseClass=0)
#LogClass_Error="ERROR"
#LogClass_Info="INFO"
#LogClass_Warning="WARNING"
#LogClass_HR="-"
#LogClass_FormatDate="%dd.%mm.%yyyy %hh:%ii:%ss"
CompilerEndIf
CompilerIf #PB_Compiler_Processor=#PB_Processor_x86
#__Create_Interfacedata_CC=#CC_STDCALL
CompilerElse
#__Create_Interfacedata_CC=#CC_FASTCALL
CompilerEndIf
DataSection
IID_ITypeInfo: ;00020401-0000-0000-C000-000000000046
Data.l $00020401
Data.w $0000,$0000
Data.b $C0,$00,$00,$00,$00,$00,$00,$46
IID_IUnknown: ; {00000000-0000-0000-C000-000000000046}
Data.l $00000000
Data.w $0000,$0000
Data.b $C0,$00,$00,$00,$00,$00,$00,$46
IID_IDispatch: ; {00020400-0000-0000-C000-000000000046}
Data.l $00020400
Data.w $0000,$0000
Data.b $C0,$00,$00,$00,$00,$00,$00,$46
IID_IClassFactory: ; 00000001-0000-0000-C000-000000000046
Data.l $00000001
Data.w $0000,$0000
Data.b $C0,$00,$00,$00,$00,$00,$00,$46
EndDataSection
Declare.s GetStringFromGuid(*guid.guid)
Declare GetGuidFromString(guid$,*out.guid)
CompilerIf #LogClass
Declare __LogClass(Type.s,Text.s,Proc.s,*class.BaseClass=0)
CompilerEndIf
Declare __Create_InterfaceData(*VT,inter.s,cc=#__Create_Interfacedata_CC)
Declare __Free_InterfaceData(*data.INTERFACEDATA)
Structure _IUnknown Extends _BaseClass
EndStructure
DeclareClass(IUnknown)
Structure _IDispatch Extends _IUnknown
*TypeInfo.iTypeInfo
*obj.BaseClass
EndStructure
ThreadSafe_DeclareClass(IDispatch,IUnknown)
Structure _IClassFactory Extends _IUnknown
*vt
*iid
EndStructure
Global IClassFactory_LockCount.i
threadsafe_DeclareClass(IClassFactory,IUnknown,(*VT))
DeclareClassHelper__()
Declare IUnknown_QueryInterface(class,parentClass,classiid)
Declare IDispatch_QueryInterface(class,parentClass,classiid)
Declare IClassFactory_QueryInterface(class,parentClass,classiid)
Declare New_IDispatch(*obj.BaseClass=0)
EndDeclareModule
Module ExportCom
CompilerIf Not Defined(class,#PB_Module)
DefineClassHelper__()
CompilerEndIf
Procedure.s GetStringFromGuid(*guid.guid);-ExportCom::GetStringFormGuid
Protected guidstr.s
If *guid
guidstr=RSet(Hex(*guid\Data1,#PB_Long),8,"0")+"-"+
RSet(Hex(*guid\data2,#PB_Word),4,"0")+"-"+
RSet(Hex(*guid\Data3,#PB_Word),4,"0")+"-"+
RSet(Hex(*guid\data4[0],#PB_Byte),2,"0")+RSet(Hex(*guid\data4[1],#PB_Byte),2,"0")+"-"+
RSet(Hex(*guid\data4[2],#PB_Byte),2,"0")+RSet(Hex(*guid\data4[3],#PB_Byte),2,"0")+
RSet(Hex(*guid\data4[4],#PB_Byte),2,"0")+RSet(Hex(*guid\data4[5],#PB_Byte),2,"0")+
RSet(Hex(*guid\data4[6],#PB_Byte),2,"0")+RSet(Hex(*guid\data4[7],#PB_Byte),2,"0")
EndIf
ProcedureReturn guidstr
EndProcedure
Procedure GetGuidFromString(guid$,*out.guid);ExportCom::GetGuidFromString
If *out And Len(guid$)=36
If Mid(guid$,9,1)="-" And Mid(guid$,14,1)="-" And Mid(guid$,19,1)="-" And Mid(guid$,24,1)="-"
*out\Data1=Val("$"+Mid(guid$,1,8))
*out\data2=Val("$"+Mid(guid$,10,4))
*out\data3=Val("$"+Mid(guid$,15,4))
*out\Data4[0]=Val("$"+Mid(guid$,20,2))
*out\Data4[1]=Val("$"+Mid(guid$,22,2))
*out\Data4[2]=Val("$"+Mid(guid$,25,2))
*out\Data4[3]=Val("$"+Mid(guid$,27,2))
*out\Data4[4]=Val("$"+Mid(guid$,29,2))
*out\Data4[5]=Val("$"+Mid(guid$,31,2))
*out\Data4[6]=Val("$"+Mid(guid$,33,2))
*out\Data4[7]=Val("$"+Mid(guid$,35,2))
ProcedureReturn #True
EndIf
EndIf
ProcedureReturn #False
EndProcedure
CompilerIf #LogClass
Procedure.s __LSet(str.s,l)
If Len(str)<l
str=LSet(str,l)
EndIf
ProcedureReturn str
EndProcedure
Procedure __LogClass(Type.s,Text.s,Proc.s,*class.BaseClass=0);-ExportCom::__LogClass
Static mutex,out
Protected class$,info$
If type="" And text="" And *class=0
If out
CloseFile(out)
out=0
EndIf
ProcedureReturn #True
EndIf
If mutex=0
mutex=CreateMutex()
EndIf
LockMutex(mutex)
If *class<>0
class$=GetObjectClassName(*class)+"@"+Hex(*class)
Else
class$="-@-"
EndIf
If type=#LogClass_HR
info$=""
Else
info$="["+FormatDate(#LogClass_FormatDate,Date())+~"]"+
__LSet("["+type+~"]",9)+
__LSet("["+class$+~"]",30)+
__LSet("["+proc+~"]",30)+
text
EndIf
Debug info$
CompilerIf #PB_Compiler_Debugger=0
If LogClass_FileName=""
LogClass_FileName=ProgramFilename()
LogClass_FileName=Left(LogClass_FileName,Len(LogClass_FileName)-Len(GetExtensionPart(LogClass_FileName)))+"log"
EndIf
If out=0
out= OpenFile(#PB_Any,LogClass_FileName,#PB_File_Append|#PB_File_SharedRead |#PB_File_SharedWrite|#PB_File_NoBuffering)
EndIf
If out
WriteStringN(out,info$)
FlushFileBuffers(out)
EndIf
CompilerEndIf
UnlockMutex(mutex)
EndProcedure
CompilerEndIf
Procedure __VariantType(Type);-ExportCom::__VariantType
Protected ret
Select Type
Case 'B','b':ret=#VT_PBByte
Case 'A','a':ret=#VT_PBAscii
Case 'W','w':ret=#VT_PBWord
Case 'U','u':ret=#VT_PBUnicode
Case 'L','l':ret=#VT_PBLong
Case 'Q','q':ret=#VT_PBQuad
Case 'F','f':ret=#VT_PBFloat
Case 'D','d':ret=#VT_PBDouble
Case 'S','s':ret=#VT_PBString
Case 'I','i':ret=#VT_PBInteger
Default:Ret=#VT_PBInteger
Debug "Illegal __VariantType "+Type+" "+Chr(Type)
EndSelect
ProcedureReturn ret
EndProcedure
Procedure __Create_InterfaceData(*VT,inter.s,cc=#__Create_Interfacedata_CC);-ExportCom::__Create_InterfaceData
Protected MethodCount,i
Protected line.s, Method.s, MethodType.s, Para.s, Flag.w, Offset.l,vt_type.w
Protected *data.INTERFACEDATA,*MD.MethodData
Protected ParaCount,pi,MaxParaCount
Protected *para,*PA.PARAMDATA,*ParaCurrent
Protected ParaName.s,ParaType.s
Protected id,idCount
NewMap ids()
inter=UCase(ReplaceString(inter," ",""))
MethodCount=CountString(inter,")")
For i=1 To MethodCount
line.s=StringField(inter.s,i,")")
Para=StringField(line,2,"(")
If Para<>""
MaxParaCount+CountString(para,",")+1
EndIf
Next
*Data=AllocateMemory(SizeOf(INTERFACEDATA) + SizeOf(MethodData) * MethodCount + SizeOf(PARAMDATA)*MaxParaCount)
;logclass(#LogClass_info,"Size:"+Str(SizeOf(INTERFACEDATA) + SizeOf(MethodData) * MethodCount + SizeOf(PARAMDATA)*MaxParaCount))
If *Data
*MD=*data+SizeOf(INTERFACEDATA)
*ParaCurrent=*MD+ SizeOf(MethodData) * MethodCount
*data\cMembers=MethodCount
*data\pmethdata=*MD
For i=1 To MethodCount
line.s=StringField(inter.s,i,")")
Method=StringField(StringField(line,1,"("),1,"=")
MethodType=StringField(Method,2,"."):If MethodType="": MethodType="i" :EndIf
Method=StringField(Method,1,".")
Offset=Class_GetIndex__(*vt,method)
Select MethodType
Case "_P_BSTR": vt_type=#VT_PBString
Case "_P_DISPATCH":vt_type=#VT_DISPATCH
Default:vt_type=__VariantType(Asc(MethodType))
EndSelect
If Left(method,12)="PROPERTYGET_"
method=Mid(Method,13)
Flag=#DISPATCH_PROPERTYGET
ElseIf Left(method,12)="PROPERTYPUT_"
method=Mid(Method,13)
Flag=#DISPATCH_PROPERTYPUT
vt_type=#VT_NULL
ElseIf Left(method,7)="METHOD_"
method=Mid(method,8)
Flag=#DISPATCH_METHOD
Else
Flag=#DISPATCH_METHOD
EndIf
If ids(method)=0
idCount+1
ids()=idCount
EndIf
id=ids()
;LogClass(#LogClass_Info,""+id+" Method:"+Method+" type:"+MethodType+" "+vt_type+" Flag:"+flag+" offset:"+offset)
Para=StringField(line,2,"(")
If Para=""
;LogClass(#LogClass_Info," NO PARAMETER")
ParaCount=0
*para=0
Else
ParaCount=CountString(para,",")+1
*para=*ParaCurrent
;LogClass(#LogClass_Info, " PARA")
*PA=*para
For pi=1 To ParaCount
ParaName=StringField(StringField(Para,pi,","),1,"=")
ParaType=Trim(StringField(ParaName,2,".")):If ParaType="": ParaType="i" :EndIf
ParaName=Trim(StringField(ParaName,1,"."))
If Left(ParaName,1)="*"
ParaName=Mid(ParaName,2)
ParaType="*"
EndIf
;LogClass(#LogClass_Info," "+ParaName+" "+ParaType)
*pa\szName=BSTR(ParaName)
*pa\vt=__VariantType(Asc(ParaType))
*pa+SizeOf(PARAMDATA)
Next
;LogClass(#LogClass_Info," ENDPARA")
*ParaCurrent=*pa
EndIf
*MD\szName=BSTR(Method)
*MD\ppdata=*para
*MD\dispid=id
*MD\iMeth=Offset
*MD\cc=cc
*MD\cArgs=ParaCount
*MD\wFlags=flag
*MD\vtReturn=vt_type
*MD + SizeOf(MethodData)
CompilerIf #LogClass
If offset<0
LogClass(#LogClass_error,"Method not found:"+method+" "+para)
EndIf
CompilerEndIf
Next
EndIf
;logclass(#logclass_info,"last:"+Str(*ParaCurrent-*data))
;LogClass(#LogClass_Info,"OK @"+Hex(*data))
ProcedureReturn *data
EndProcedure
Procedure __Free_InterfaceData(*data.INTERFACEDATA);-ExportCom::__Free_InterfaceData
Protected i,pi
Protected *MD.MethodData
Protected *pa.PARAMDATA
;LogClass(#LogClass_Info,"Free @"+Hex(*data))
If *data
*md=*data\pmethdata
For I=1 To *data\cMembers
If *md\szName
FreeBStr(*md\szName)
EndIf
*pa=*md\ppdata
For PI=1 To *md\cArgs
If *pa\szName
FreeBStr(*pa\szName)
EndIf
*pa+SizeOf(PARAMDATA)
Next
*md+SizeOf(MethodData)
Next
FreeMemory(*data)
EndIf
EndProcedure
;{ ExportCom::IUnknown
Procedure IUnknown_AddRef(*self._IUnknown)
Protected ref=ReferenceObject(*self)
LogClass(#LogClass_Info,"Count: "+ref,*self)
ProcedureReturn ref
EndProcedure:AsMethod(IUnknown,Addref)
Procedure IUnknown_Release(*self._IUnknown)
Protected Result
LogClass(#LogClass_Info,"Count: "+Str(CountReferenceObject(*self)-1),*self)
result=FreeObject(*self)
ProcedureReturn result
EndProcedure:AsMethod(IUnknown,Release)
Method_QueryInterface(IUnknown,BaseClass,?IID_IUnknown)
DefineClass(IUnknown,BaseClass)
;}
;{ ExportCom::IDispatch
Procedure New_IDispatch(*obj.BaseClass=0)
Protected *typeinfo.ITypeInfo
Protected *cc.__ComClass
Protected *nVT.__Class_nVT
Protected *this.IUnknown
Protected *self._iDispatch
If IsClassObject(iDispatch,*obj)
*self=*obj
Else
*self=iDispatch()
If *self=0
ProcedureReturn 0
EndIf
EndIf
If IsObject(*obj)=#False
LogClass(#LogClass_Error,"Object is not valid")
FreeObject(*self)
ProcedureReturn 0
EndIf
*nvt=PeekI(*obj)-SizeOf(__Class_nVT)
*cc=*nvt\ExportClass
If *cc
*typeinfo=*cc\typeinfo
EndIf
If *typeinfo<>0 And *typeinfo\QueryInterface(?IID_ITypeInfo,@ *self\TypeInfo)=#S_OK
If IsClassObject(IUnknown,*obj)
*this=*obj
*this\AddRef()
Else
ReferenceObject(*obj)
EndIf
*self\obj=*obj
LogClass(#LogClass_Info,"Embedded object "+GetObjectClassName(*obj)+"@"+Hex(*obj),*self)
ProcedureReturn *self
Else
LogClass(#LogClass_Error,"ITypeInfo is not valid")
FreeObject(*self)
ProcedureReturn 0
EndIf
EndProcedure
Procedure IDispatch___Destructor(*self._IDispatch)
Protected *this.IUnknown
If *self<>*self\obj
If IsClassObject(IUnknown,*self\obj)
*this=*self\obj
*this\Release()
Else
FreeObject(*self\obj)
EndIf
EndIf
*self\TypeInfo\Release()
*self\obj=0
*self\TypeInfo=0
LogClass(#LogClass_Info,"Free",*self)
EndProcedure
Procedure IDispatch___CopyConstructor(*self._IDispatch,*org)
Protected *this.IUnknown
LogClass(#LogClass_Info,"Copy from "+Hex(*org),*self)
If IsClassObject(IUnknown,*self\obj)
*this=*self\obj
*this\AddRef()
Else
ReferenceObject(*self\obj)
EndIf
*self\TypeInfo\AddRef()
ProcedureReturn #True
EndProcedure
Method_QueryInterface(IDispatch,IUnknown,?IID_IDispatch)
Procedure IDispatch_GetTypeInfoCount(*self._IDispatch,*out_long.long)
If *out_long=0
LogClass(#LogClass_Error,"No Pointer",*self)
ProcedureReturn #E_POINTER
EndIf
*out_long\l=1
LogClass(#LogClass_Info,"Return:"+*out_long\l,*self)
ProcedureReturn #S_OK
EndProcedure: AsMethod(IDispatch,GetTypeInfoCount)
Procedure IDispatch_GetTypeInfo(*self._IDispatch,iTInfo.l,lcid.l,*out_ITypeInfo.integer)
Protected count
If *out_ITypeInfo=0
LogClass(#LogClass_Error,"No Pointer",*self)
ProcedureReturn #E_POINTER
EndIf
If iTInfo<>0
LogClass(#LogClass_Error,"Bad Index "+iTInfo,*self)
ProcedureReturn #DISP_E_BADINDEX
EndIf
*out_ITypeInfo\i=*self\TypeInfo
count=*self\TypeInfo\AddRef()
LogClass(#LogClass_Info,"TypeInfo Count:"+Str(count),*self)
ProcedureReturn #NOERROR
EndProcedure: AsMethod(IDispatch,GetTypeInfo)
Procedure IDispatch_Invoke(*self._IDispatch,dispIdMember.w,*riid,lcid.l,wFlags.w,*pDispParams.DISPPARAMS,*pVarResult.PBVariant,*pExcepInfo,*puArgErr)
Protected result
;logclass(#logclass_info,""+dispIdMember+" "+*pDispParams\cArgs+" "+*pDispParams\cNamedArgs+" "+wFlags+" "+*pExcepInfo+" "+*puArgErr)
LockObject(*self)
;result=DispInvoke_(*self\obj,*self\TypeInfo,dispIdMember,wFlags,*pDispParams,*pVarResult,*pExcepInfo,*puArgErr)
result=*self\typeinfo\Invoke(*self\obj,dispIdMember,wFlags,*pDispParams,*pVarResult,*pExcepInfo,*puArgErr)
UnlockObject(*self)
CompilerIf #LogClass
If result=-2147352560 ;$80020010
logclass(#LogClass_Error,"Invalid callee - missing (*self)?",*self)
EndIf
Protected a$,res.s
If *pVarResult And result=#S_OK
Select *pVarResult\vt
Case #VT_PBAscii:a$=StrU(*pVarResult\PB\Ascii)+"a"
Case #VT_PBByte:a$=Str(*pVarResult\PB\Byte)+"b"
Case #VT_PBDouble:a$=StrD(*pVarResult\PB\Double)+"d"
Case #VT_PBFloat:a$=StrF(*pVarResult\PB\Float)+"f"
Case #VT_PBInteger:a$=Str(*pVarResult\PB\Integer)+"i"
Case #VT_PBLong:a$=Str(*pVarResult\PB\Long)+"l"
Case #VT_PBQuad:a$=Str(*pVarResult\PB\Quad)+"q"
Case #VT_PBString:
If *pVarResult\pb\string
a$=Chr(34)+PeekS(*pVarResult\PB\String,20)+Chr(34)
Else
a$="NULL$"
EndIf
Case #VT_PBUnicode:a$=StrU(*pVarResult\PB\Unicode)+"u"
Case #VT_PBWord:a$=Str(*pVarResult\PB\Word)+"w"
Case #VT_DISPATCH:a$="IDispatch"
Default
a$="<unknown>"
EndSelect
Else
a$="<none>"
EndIf
a$="Result:"+a$
If wFlags&#DISPATCH_METHOD
a$="METHOD "+a$
ElseIf wFlags&#DISPATCH_PROPERTYGET
a$="GET "+a$
ElseIf wFlags&#DISPATCH_PROPERTYPUT
a$="PUT "+a$
EndIf
Select result
Case #S_OK:res="S_OK"
Case #DISP_E_BADPARAMCOUNT:res="Bad parameter count"
Case #DISP_E_BADVARTYPE:res="Bad Variant type in DISPPARAMS"
Case #DISP_E_EXCEPTION:res="Application needs to raise an exception"
Case #DISP_E_MEMBERNOTFOUND:res="Member not found"
Case #DISP_E_NONAMEDARGS:res="Named arguments are not supported"
Case #DISP_E_OVERFLOW:res="Overflow in DISPPARAMS"
Case #DISP_E_PARAMNOTFOUND:res="Parameter ID not found"
Case #DISP_E_TYPEMISMATCH:res="Parameter type mismatch"
Case #DISP_E_PARAMNOTOPTIONAL:res="Missing Parameter"
Default :res= "Unknown ("+result+")"
EndSelect
If result=#S_OK
LogClass(#LogClass_Info,"ID:"+dispIdMember+" "+a$+" "+res,*self)
Else
LogClass(#LogClass_Error,"ID:"+dispIdMember+" "+a$+" "+res,*self)
EndIf
CompilerEndIf
ProcedureReturn result
EndProcedure:AsMethod(IDispatch,Invoke)
Procedure IDispatch_GetIDsOfNames(*self._IDispatch,*riid,*rgszNames,cNames.l,lcid.l,*rgDispId)
Protected result
result=DispGetIDsOfNames_(*self\TypeInfo, *rgszNames, cNames,*rgDispId)
CompilerIf #LogClass
Protected a$
If *rgszNames And PeekI(*rgszNames)
a$="Name:"+PeekS(PeekI(*rgszNames))
EndIf
If *rgDispId
a$+" ID:"+PeekW(*rgDispId)
EndIf
If result=#S_OK
LogClass(#LogClass_Info,a$+" S_OK",*self)
Else
If result=#E_OUTOFMEMORY
a$+" Out of memory"
ElseIf result=#DISP_E_UNKNOWNNAME
a$+" Unknown name"
Else
a$+" Unknown ("+result+")"
EndIf
LogClass(#LogClass_Error,a$,*self)
EndIf
CompilerEndIf
ProcedureReturn result
EndProcedure:AsMethod(IDispatch,GetIDsOfNames)
DefineClass(IDispatch,IUnknown)
;}
;{ ExportCom::IClassFactory
Method_QueryInterface(IClassFactory,IUnknown,?IID_IClassFactory)
Procedure IClassFactory___Constructor(*self._IClassFactory,*vt)
If *vt=0
LogClass(#LogClass_Info,"Missing parameter",*self)
ProcedureReturn #False
EndIf
*self\vt=*vt
LogClass(#LogClass_info,"New ClassFactory for Class "+GetClassIDName(*vt),*self)
ProcedureReturn #True
EndProcedure
Procedure IClassFactory___Destructor(*self._IClassFactory)
LogClass(#LogClass_Info,"Free ClassFactory for Class "+GetClassIDName(*self\vt),*self)
EndProcedure
Procedure IClassFactory_LockServer(*self._IClassFactory,Bool.i)
LockObject(*self)
If bool=0
If IClassFactory_LockCount>0
IClassFactory_LockCount-1
EndIf
Else
IClassFactory_LockCount+1
EndIf
UnlockObject(*self)
LogClass(#LogClass_Info,"Count:"+ IClassFactory_LockCount+" (Class "+GetClassIDName(*self\vt)+")",*self)
ProcedureReturn #S_OK
EndProcedure:AsMethod(IClassFactory,LockServer)
Procedure IClassFactory_CreateInstance(*self._IClassFactory,*pUnkOuter,*riid,*out_Object.Integer)
Protected *obj
Protected *nVT.__Class_nVT=*self\VT-SizeOf(__Class_nVT)
If *out_Object=0
LogClass(#LogClass_Error,"No Pointer",*self)
ProcedureReturn #E_POINTER
EndIf
*out_Object\i=#Null
If *pUnkOuter
LogClass(#LogClass_Error,"Aggregation is not supported",*self)
ProcedureReturn #CLASS_E_NOAGGREGATION
EndIf
If CompareMemory(*riid, ?IID_IUnknown, SizeOf(iid)) Or CompareMemory(*riid, ?IID_IDispatch, SizeOf(iid))
*obj=CallFunctionFast(*nVT\new)
If *obj
*out_Object\i=new_IDispatch(*obj)
FreeObject(*obj)
If *out_Object\i
LogClass(#LogClass_Info,"New IDispatch "+GetClassIdName(*self\vt)+"@"+Hex(*out_Object\i),*self)
ProcedureReturn #S_OK
EndIf
EndIf
LogClass(#LogClass_Error,"Out of Memory",*self)
ProcedureReturn #E_OUTOFMEMORY
EndIf
LogClass(#LogClass_Error,"Class not available ("+GetClassIdName(*self\vt)+")",*self)
ProcedureReturn #CLASS_E_CLASSNOTAVAILABLE
EndProcedure:AsMethod(IClassFactory,CreateInstance)
DefineClass(IClassFactory,IUnknown,(*VT))
;}
EndModule
UseModule ExportCom
EndMacro
;{ Warper for IncludeFile
CompilerIf #PB_Compiler_IsMainFile=#False
InitExportCom(#True)
UndefineMacro InitExportCom
CompilerEndIf
;}