Activex coding

[Blade]

Hello,
Is it possible with PureBasic to build an Activex ?
Something like the flash plugin, callable from a HTML page via the <OBJECT> tag? No, I don't want to make a Flash clone
In other words, I'd like to make something like a Java applet, but coded in purebasic...

[benny]

Hi,

maybe this helps you ...

http://www.activex2dll.com.ar/.

Best wishes, benny!

[Blade]

Well, It's useful for controlling other applications (I did it a lot with a VB project at work) but not for building your own activex...

[Rings]

creating activeX from the ground (ASM) is a very complex thing .

Here are some very good infos using masm : http://ourworld.compuserve.com/homepage ... orld/a.htm
or here:
http://www.japheth.de/

It is not impossible, but very tricky to do such with PB.
i prefer VB or VC++ to create such.All the needed ActiveX-Ground-stuff is already included and you can create classes very easy . Also delphi and other c++ compiler should do the job.Do not know for other languages.

[Shannara]

Any luck with this Blade? Building an ActiveX control w/ Vb or VC totally goes against what PB stands for, no? horrible runtime libraries.. I am also interested in making either ActiveX controls or ActiveX DLLs (preferred), but have made almost no headway on this..

[Blade]

Any luck with this Blade?

No, I didn't even tried. I just posted that question because it's a project I'd like to start when I'll buy PB.

I'm still not sure that it can be done easily with PB too!

I hoped the the new 3.80 features (interfaces etc) could help doing this, but seeing the (few) examples it looks complex as if you had to do it using C. I hoped that PB could help somehow with this stuf...

[Leo]

I wrote a "XIncludeFile" generator in PureBasic, that generates an IncludeFile with all the CLSID, IID and VTable and Dispatch Interfaces for a selected control. After starting the program, it shows all the registered controls. By clicking a control, it fills a listview with the enums, constants, interfaces, dispinterfaces and so on for that control. By clicking a (disp)interface it fills the bottom listview with the details. That will be a custom Vtable interface, a Dispatch Interface or a Enumeration (for building your clientsite eventsink) depending on the radio buttons. You will find the Code below.

Code: Select all

;-Init Includes
XIncludeFile "Controls_Constants.pb"
XIncludeFile "Controls_Windows.pb"

Enumeration
  #INVOKE_FUNC             = 1
  #INVOKE_PROPERTYGET      = 2
  #INVOKE_PROPERTYPUT      = 4
  #INVOKE_PROPERTYPUTREF   = 8
EndEnumeration 

Enumeration 
  #USERCLASSTYPE_FULL       = 1 
  #USERCLASSTYPE_SHORT  
  #USERCLASSTYPE_APPNAME 
EndEnumeration 

Enumeration
  #TKIND_ENUM  
  #TKIND_RECORD 
  #TKIND_MODULE 
  #TKIND_INTERFACE 
  #TKIND_DISPATCH
  #TKIND_COCLASS
  #TKIND_ALIAS
  #TKIND_UNION
  #TKIND_MAX  
EndEnumeration 

Enumeration
  #FUNC_VIRTUAL    = 0
  #FUNC_PUREVIRTUAL= #FUNC_VIRTUAL + 1
  #FUNC_NONVIRTUAL = #FUNC_PUREVIRTUAL + 1
  #FUNC_STATIC     = #FUNC_NONVIRTUAL + 1
  #FUNC_DISPATCH   = #FUNC_STATIC + 1
EndEnumeration 

Enumeration
  #VAR_PERINSTANCE = 0
  #VAR_STATIC      = #VAR_PERINSTANCE + 1
  #VAR_CONST       = #VAR_STATIC + 1
  #VAR_DISPATCH    = #VAR_CONST + 1
EndEnumeration  

Enumeration
  #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_FILETIME     = 64
  #VT_BLOB         = 65
  #VT_STREAM       = 66
  #VT_STORAGE      = 67 
  #VT_STREAMED_OBJECT      = 68
  #VT_STORED_OBJECT        = 69
  #VT_BLOB_OBJECT  = 70
  #VT_CF           = 71
  #VT_CLSID        = 72
  #VT_BSTR_BLOB    = $fff
  #VT_VECTOR       = $1000
  #VT_ARRAY        = $2000
  #VT_BYREF        = $4000
  #VT_RESERVED     = $8000
  #VT_ILLEGAL      = $ffff
  #VT_ILLEGALMASKED= $fff
  #VT_TYPEMASK     = $fff
EndEnumeration                

Enumeration
  #PARAMFLAG_NONE = $00
  #PARAMFLAG_FIN = $01
  #PARAMFLAG_FOUT = $02
  #PARAMFLAG_FLCID = $04
  #PARAMFLAG_FRETVAL = $08
  #PARAMFLAG_FOPT = $10
  #PARAMFLAG_FHASDEFAULT = $20
  #PARAMFLAG_FHASCUSTDATA = $40
EndEnumeration                

Structure VARIANTARG
  vt.w
  dummy1.w
  dummy2.w
  dummy3.w
  union.l
EndStructure

Structure PARAMDESC
  pparamdescex.l
  wParamFlags.w
EndStructure  

Structure PARAMDESCEX
  cBytes.l
  dummy.l   ; Deze dummy begrijp ik niet
  varDefaultValue.VARIANTARG
EndStructure

Structure TYPEDESC
  union.l
  vt.w
EndStructure

Structure ELEMDESC 
  tdesc.TYPEDESC
  dummy.w
  paramdesc.PARAMDESC
  dummy.w
EndStructure

Structure FUNCDESC
  memid.l
  scode.l
  *lprgelemdescParam.ELEMDESC
  funckind.l
  invokekind.l
  callconv.l
  cParams.w 
  cParamsOpt.w 
  oVft.w 
  cScodes.w 
  *elemdescFunc.ELEMDESC
  wFuncFlags.w
EndStructure

Structure TYPEATTR
  guid.GUID
  lcid.l
  dwReserved.l
  memidConstructor.l
  memidDestructor.l
  lpstrSchema.l
  cbSizeInstance.l
  typekind.l
  cFuncs.w
  cVars.w
  cImplTypes.w
  cbSizeVft.w
  cbAlignment.w
  wTypeFlags.w
  wMajorVerNum.w
  wMinorVerNum.w
  tdescAlias.l
  idldescType.l
EndStructure

Structure VARDESC
  memid.l
  lpstrSchema.l
  union.l
  *elemdescVar.ELEMDESC
  wVarFlags.w
  varkind.w
EndStructure  

Procedure.s HexString(Source.l, l.l) 
    result.s
    
    result.s = ""
    For i = 0 To l
        result = result + Right("00" + Hex(PeekB(PeekL(Source)+i)), 2) + " "
    Next i
    
    ProcedureReturn result
EndProcedure


Procedure.s ByteStr(pointer.l) 
  strlen.w = WideCharToMultiByte_(#CP_ACP, 0, pointer, -1, 0, 0 , 0, 0) 
  string.s = Space(strlen) 
  If strlen <> 0 
    newlen.w = WideCharToMultiByte_(#CP_ACP, 0, pointer, -1, @string, strlen , 0, 0) 
  EndIf 
  ProcedureReturn string 
EndProcedure

Procedure.l WideStr(pointer.l, mem.l) 
  widelen.w = 2*Len(PeekS(pointer))+2 
  widebuf.l = AllocateMemory(mem, widelen) 
  longlen.w = MultiByteToWideChar_(#CP_ACP,0,pointer,-1,widebuf,widelen) 
  ProcedureReturn widebuf 
EndProcedure 

Procedure CheckFatalError(Err.l, ErrTxt.s)
  If Err <> 0
    MessageRequester("Fatal Error",ErrTxt+", Error : "+Hex(Err) ,0)
    End
  EndIf
EndProcedure
  
Procedure.l CheckError(Err.l, ErrTxt.s)
  If Err <> 0
    MessageRequester("Information",ErrTxt+", Error : "+Hex(Err) ,0)
    ProcedureReturn 1
  EndIf
  ProcedureReturn 0
EndProcedure  

Procedure.s stringCustomType(RefType.l, pTypeInfo.l)
  *TypeInfo.ITypeInfo=pTypeInfo
  
  If *TypeInfo\GetRefTypeInfo(RefType, @CustTypeInfo.ITypeInfo)=0
    If CustTypeInfo\GetDocumentation(-1, @bstrType, 0, 0, 0)=0
      ProcedureReturn ByteStr(bstrType)
    Else
      ProcedureReturn "UnknownCustomType"
    EndIf
  Else
    ProcedureReturn "UnknownCustomType"
  EndIf  
  ProcedureReturn "UnknownCustomType"
EndProcedure

Procedure.s stringTypeDesc(pTypeDesc.l, pTypeInfo.l)
  *TypeDesc.TYPEDESC=pTypeDesc
  *TypeInfo.ITypeInfo=pTypeInfo
  If *TypeDesc\vt = #VT_PTR
    ProcedureReturn stringTypeDesc(*TypeDesc\union, pTypeInfo)+"*"
  EndIf  
  If *TypeDesc\vt = #VT_SAFEARRAY
    ProcedureReturn "SAFEARRAY("+stringTypeDesc(*TypeDesc\union, pTypeInfo)+")"
  EndIf  
;  If pTypeDesc\vt = #VT_CARRAY
;    CArray.s=stringTypeDesc(@*TypeDesc\lpadesc\tdescElem, @*TypeInfo)
;  EndIf  
;  If pTypeDesc\vt = #VT_USERDEFINED
;    CArray.s=stringTypeDesc(@*TypeDesc\lpadesc\tdescElem, @*TypeInfo)
;  EndIf  
;    If(typeDesc->vt == VT_CARRAY) {
;        oss<< stringifyTypeDesc(&typeDesc->lpadesc->tdescElem, pTypeInfo);
;        for(int dim(0); typeDesc->lpadesc->cDims; ++dim) 
;            oss<< '['<< typeDesc->lpadesc->rgbounds[dim].lLbound<< "..."
;                << (typeDesc->lpadesc->rgbounds[dim].cElements + 
;                typeDesc->lpadesc->rgbounds[dim].lLbound - 1)<< ']';
;        return oss.str();
;    }
  If *TypeDesc\vt = #VT_USERDEFINED
    ProcedureReturn stringCustomType(*TypeDesc\union, pTypeInfo)
  EndIf
  Vt.l=*TypeDesc\vt
  Select Vt.l
    Case #VT_I2: ProcedureReturn "short";
    Case #VT_I4: ProcedureReturn "long";
    Case #VT_R4: ProcedureReturn "float";
    Case #VT_R8: ProcedureReturn "double";
    Case #VT_CY: ProcedureReturn "CY";
    Case #VT_DATE: ProcedureReturn "DATE";
    Case #VT_BSTR: ProcedureReturn "BSTR";
    Case #VT_DISPATCH: ProcedureReturn "IDispatch*";
    Case #VT_ERROR: ProcedureReturn "SCODE";
    Case #VT_BOOL: ProcedureReturn "VARIANT_BOOL";
    Case #VT_VARIANT: ProcedureReturn "VARIANT";
    Case #VT_UNKNOWN: ProcedureReturn "IUnknown*";
    Case #VT_UI1: ProcedureReturn "BYTE";
    Case #VT_DECIMAL: ProcedureReturn "DECIMAL";
    Case #VT_I1: ProcedureReturn "char";
    Case #VT_UI2: ProcedureReturn "USHORT";
    Case #VT_UI4: ProcedureReturn "ULONG";
    Case #VT_I8: ProcedureReturn "__int64";
    Case #VT_UI8: ProcedureReturn "unsigned __int64";
    Case #VT_INT: ProcedureReturn "int";
    Case #VT_UINT: ProcedureReturn "UINT";
    Case #VT_HRESULT: ProcedureReturn "HRESULT";
    Case #VT_VOID: ProcedureReturn "void"
    Case #VT_LPSTR: ProcedureReturn "char*";
    Case #VT_LPWSTR: ProcedureReturn "wchar_t*";
  EndSelect
  ProcedureReturn "BIG ERROR!";
EndProcedure

Procedure.s stringVarDesc(pVarDesc.l, pTypeInfo.l)
  *VarDesc.VARDESC=pVarDesc
  *TypeInfo.ITYPEINFO=pTypeInfo
  bstrName.s
  If *VarDesc\varkind = #VAR_CONST
    RetStr.s="const "+stringTypeDesc(@*VarDesc\elemdescVar\tdesc, @*TypeInfo)
    If *TypeInfo\GetDocumentation(*VarDesc\memid, @bstrName ,0, 0, 0)
      RetStr=RetStr+" "+ByteStr(@bstrName)+" = "
      If VariantChangeType_( @Variant, *VarDesc\union,0,#VT_BSTR)
        RetStr=RetStr+"???"
      Else
        RetStr=RetStr+ByteStr(@Variant)
      EndIf   
    Else
      RetStr="UnknownName"
    EndIf
  EndIf
  ProcedureReturn RetStr    
EndProcedure

Procedure.s stringParameterAttributes(pParamDesc.l) 
  *ParamDesc.PARAMDESC=pParamDesc
  paramFlags.w = *ParamDesc\wParamFlags
  
  numFlags.l=0
  bit.l=1
  While bit < #PARAMFLAG_FHASDEFAULT
    If paramFlags & bit
      numFlags=numFlags+1
    EndIf
    bit=bit*2
  Wend
  If numFlags=0
    ProcedureReturn ""
  EndIf
  RetStr.s="["
  If paramFlags & #PARAMFLAG_FIN
    RetStr=RetStr+"in, "
  EndIf 
  If paramFlags & #PARAMFLAG_FOUT
    RetStr=RetStr+"out, "
  EndIf 
  If paramFlags & #PARAMFLAG_FLCID
    RetStr=RetStr+"lcid, "
  EndIf 
  If paramFlags & #PARAMFLAG_FRETVAL
    RetStr=RetStr+"retval, "
  EndIf 
  If paramFlags & #PARAMFLAG_FOPT
    RetStr=RetStr+"optional, "
  EndIf 
  If paramFlags & #PARAMFLAG_FHASDEFAULT
    RetStr=RetStr+"defaultvalue="
    If *ParamDesc\pparamdescex
      *ParamDescEx.PARAMDESCEX=*ParamDesc\pparamdescex
      *varDefaultValue.VARIANTARG=*ParamDescEx\varDefaultValue
      
      If VariantChangeType_(@Variant.VARIANTARG,*varDefaultValue,0,#VT_BSTR)=0
        If *varDefaultValue\vt = #VT_BSTR
          RetStr=RetStr+Chr(34)
        EndIf
        RetStr=RetStr+ByteStr(Variant\union)
        If *varDefaultValue\vt = #VT_BSTR
          RetStr=RetStr+Chr(34)
        EndIf  
      Else
        RetStr=RetStr+"???"
      EndIf
    EndIf
  EndIf 
    If Right(RetStr,2)=", "
      RetStr=Left(RetStr, Len(RetStr)-2)
    EndIf
    RetStr=RetStr+"]"
  ProcedureReturn RetStr
EndProcedure  

Procedure.s stringFunctionArgument(pElemDesc.l, pTypeInfo.l)
    *ElemDesc.ELEMDESC=pElemDesc
    *TypeInfo.ITypeInfo=pTypeInfo
    pParamDesc.l=@*ElemDesc\paramdesc
    RetStr.s=stringParameterAttributes(pParamDesc)
    If Len(RetStr)>0
      RetStr=RetStr+" "      
    EndIf
    pTypeDesc.l=@*ElemDesc\tdesc
    RetStr=RetStr+stringTypeDesc(pTypeDesc.l, pTypeInfo)
  ProcedureReturn RetStr
EndProcedure  

Procedure.s stringCOMMethod(pFuncDesc.l, pTypeInfo.l)
  *FuncDesc.FUNCDESC=pFuncDesc
  *TypeInfo.ITypeInfo=pTypeInfo  
  If *FuncDesc\funckind = #FUNC_DISPATCH    
    RetStr.s="[id($"+Hex(*FuncDesc\memid)+")"
  Else 
    RetStr.s="[VOffset($"+Hex(*FuncDesc\oVft)+")"
  EndIf  
  Select *FuncDesc\invokekind
    Case #INVOKE_PROPERTYGET
      RetStr=RetStr+", propget] "
    Case #INVOKE_PROPERTYPUT
      RetStr=RetStr+", propput] "
    Case #INVOKE_PROPERTYPUTREF
      RetStr=RetStr+", propputref] "
    Case #INVOKE_FUNC
      RetStr=RetStr+"] "
  EndSelect
  RetStr=RetStr+stringTypeDesc(@*FuncDesc\elemdescFunc, pTypeInfo)
  MemberID.l=*FuncDesc\memid
  Err.l=*TypeInfo\GetDocumentation(MemberID, @bstrName, NULL, NULL, NULL)
  RetStr=RetStr+" "+ByteStr(bstrName)+"("
  RetNr.l
  ParNames.s=Space(1000)
  Nr.l=*FuncDesc\cParams
  Err.l=*TypeInfo\GetNames(MemberID,@ParNames,Nr.l+1, @RetNr)
  If *FuncDesc\cParams > 0
    pTemp.l=*FuncDesc\lprgelemdescParam
  EndIf  
  pElemDescParam.l=pTemp
  For i=0 To *FuncDesc\cParams-1
    If i>0
      RetStr=RetStr+", "
    EndIf
    RetStr=RetStr+stringFunctionArgument(pElemDescParam, pTypeInfo)
    RetStr=RetStr+" "+ByteStr(PeekL(@ParNames+((i+1)*4)))
    pElemDescParam=pElemDescParam+SizeOf(ELEMDESC)
  Next
  RetStr=RetStr+")"
  ProcedureReturn RetStr
EndProcedure  
  
DataSection 
  CATID_Control:  ;  CATID_Control, 0x40fc6ed4, 0x2438, 0x11cf, 0xa3, 0xdb, 0x08, 0x00, 0x36, 0xf1, 0x25, 0x02)
    Data.l $40FC6ED4 
    Data.w $2438,$11CF 
    Data.b $A3, $DB, $08,$00,$36,$F1,$25,$02

  CLSID_StdComponentCategoriesMgr:  ;  {0002E005-0000-0000-C000-000000000046}
    Data.l $0002E005 
    Data.w $0000,$0000 
    Data.b $C0, $00, $00,$00,$00,$00,$00,$46

  IID_ICatInformation:  ;  {0002E013-0000-0000-C000-000000000046}
    Data.l $0002E013 
    Data.w $0000,$0000 
    Data.b $C0, $00, $00,$00,$00,$00,$00,$46
    
  IID_Custom:   ; {0F21F359-AB84-41E8-9A78-36D110E6D2F9}  
    Data.l $0F21F359 
    Data.w $AB84,$41E8 
    Data.b $9A, $78, $36,$D1,$10,$E6,$D2,$F9
EndDataSection






;-Main Loop
If Window_Form1()

  SetGadgetState(#Gadget_Form1_opVtable,1)
  
  CoInitialize_(NULL)
  Err.l = CoCreateInstance_(?CLSID_StdComponentCategoriesMgr,0,1,?IID_ICatInformation,@oCatInfo.ICatInformation) 
  CheckFatalError(Err,"Can't Create Component Categories Manager")
  Err.l=oCatInfo\AddRef()
  Err.l=oCatInfo\EnumClassesOfCategories(1,?CATID_Control,0,@CatIdReg,@oEnumGUID.IEnumGUID);
  CheckFatalError(Err,"Can't Enumerate Classes of Categories")

  Clsid.GUID

  While  oEnumGUID\Next( 1, @Clsid, NULL )=0
    OleRegGetUserType_(@Clsid,#USERCLASSTYPE_FULL,@ClassName)
    StringFromClsid_(@Clsid,@ClsidWStr)
    SendMessage_( GadgetID(#Gadget_Form1_lbClassName), #LB_ADDSTRING, 0, ByteStr(ClassName)+Space(80)+ByteStr(ClsidWStr))
  Wend
  RemoveGadgetItem(#Gadget_Form1_lbClassName,0)

  Err.l=oCatInfo\Release()
  CoUninitialize_()

  quitForm1=0
  Repeat
    EventID=WaitWindowEvent()
    Select EventID
      Case #PB_Event_CloseWindow
        If EventWindowID()=#Window_Form1
          quitForm1=1
        EndIf
      Case #PB_Event_Gadget
        Select EventGadgetID()
          Case #Gadget_Form1_btSaveFile
            StandardFile$ = "C:\Programmeren\PureBasic\temp.pb"   ; set initial file+path to display 
            Pattern$ = "PureBasic (*.pb)|*.pb|All files (*.*)|*.*" 
            Pattern = 0    ; use the first of the three possible patterns as standard 
            File$ = SaveFileRequester("Please choose file to save", StandardFile$, Pattern$, Pattern) 
            If File$
              If Pattern=0 And FindString(File$,".",1) = 0
                File$=File$+".pb"
              EndIf
              If OpenFile(#1,File$)
                For I=1 To CountGadgetItems(#Gadget_Form1_lbIncludeFile)
                  WriteStringN(GetGadgetItemText(#Gadget_Form1_lbIncludeFile, I-1,0))            
                Next
                CloseFile(1)
              EndIf  
            Else 
              MessageRequester("Information", "The requester was canceled.", 0) 
            EndIf 

          Case #Gadget_Form1_lbClassName
            Select EventType()
              Case #PB_EventType_LeftDoubleClick
              Default
                ClearGadgetItemList(#Gadget_Form1_lbInterfaces)
                ClearGadgetItemList(#Gadget_Form1_lbIncludeFile)
                Err.l=SendMessage_( GadgetID(#Gadget_Form1_lbIncludeFile), #LB_SETHORIZONTALEXTENT, 0, 0)
                ClsidStr.s = GetGadgetText(#Gadget_Form1_lbClassName)
                Pos.l = FindString(ClsidStr,"{",1)
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"DataSection")
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  CLSID_"+StringField(Left(ClsidStr,Pos-1),1," ")+":")
                CtrlStr.s="ProgID_"+StringField(Left(ClsidStr,Pos-1),1," ")+".s="
                ClsidStr=Mid(ClsidStr,Pos,100)
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  Data.l $"+Mid(ClsidStr,2,8))
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  Data.w $"+Mid(ClsidStr,11,4)+",$"+Mid(ClsidStr,16,4))
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  Data.b $"+Mid(ClsidStr,21,2)+",$"+Mid(ClsidStr,23,2)+",$"+Mid(ClsidStr,26,2)+",$"+Mid(ClsidStr,28,2)+",$"+Mid(ClsidStr,30,2)+",$"+Mid(ClsidStr,32,2)+",$"+Mid(ClsidStr,34,2)+",$"+Mid(ClsidStr,36,2))
                
                                
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"EndDataSection")                
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"")
                Err.l=CLSIDFromString_(WideStr(@ClsidStr,1),@Clsid.GUID)
                ProgID.l 
                Err.l=ProgIDFromCLSID_(@Clsid,@ProgID)
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,CtrlStr+Chr(34)+ByteStr(ProgID)+Chr(34)) 
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"") 
                               
                
                Err.l = RegOpenKeyEx_(#HKEY_CLASSES_ROOT,"CLSID\"+ClsidStr+"\TypeLib",0,#KEY_READ,@hTypeLib.l)
                If CheckError(Err,"Control doesn't have a Typelib")
                  Continue
                EndIf
                TLBClsidStr.s=Space(100)
                dwSizeOfDataBlock.l=100
                RegQueryValue_(hTypeLib,NULL,@TLBClsidStr,@dwSizeOfDataBlock)
                
                tchVersionInformation.s=Space(100)
                Err.l=RegOpenKeyEx_(#HKEY_CLASSES_ROOT,"TypeLib\"+TLBClsidStr,0,KEY_READ, @hKeyClassTLB.l)
                If CheckError(Err,"Typelib not registererd")
                  Continue
                EndIf
                dwCLSIDSubKeyIndex.l = 0
                While RegEnumKey_(hKeyClassTLB,dwCLSIDSubKeyIndex ,@tchVersionInformation,20) =0
                  If RegOpenKeyEx_(hKeyClassTLB,@tchVersionInformation,0,KEY_READ,@hKeyVersion.l) =0    
                  EndIf
                  dwCLSIDSubKeyIndex=dwCLSIDSubKeyIndex+1
                Wend
                clsidTypeLib.GUID
                A$ = Space((Len(TLBClsidStr)+1)*2)
                MultiByteToWideChar_(#CP_ACP,0,TLBClsidStr,-1,@A$,Len(A$))
                Err.l = CLSIDFromString_(A$,clsidTypeLib)
                CheckFatalError(Err,"Not a valid ClassId")
                Major.l=Val(tchVersionInformation)
                Pos.l = FindString(tchVersionInformation,".",1)
                tchVersionInformation.s=Mid(tchVersionInformation,Pos+1,100)
                Minor.l=Val(tchVersionInformation)
                
                Err.l = LoadRegTypeLib_(clsidTypeLib,Major,Minor,0, @oTypeLib.ITypeLib)
                CheckFatalError(Err,"Can't load TypeLib")
                Nr.l = oTypeLib\GetTypeInfoCount();
                For I = 0 To Nr-1
                  Err.l = oTypeLib\GetDocumentation(I, @bstrName, @bstrDocString, NULL, NULL)
                  CheckFatalError(Err,"Can't extract Interface from TypeLib")
                  AddGadgetItem(#Gadget_Form1_lbInterfaces,-1,ByteStr(PeekL(@bstrName)))                
                Next               
                
            EndSelect
          Case #Gadget_Form1_lbInterfaces
            Select EventType()
              Case #PB_EventType_LeftDoubleClick
              Default
                Params.s=" a.l,b.l,c.l,d.l,e.l,f.l,g.l,h.l,i.l,j.l,k.l,l.l,m.l,n.l,o.l,p.l,q.l,r.l,s.l,t.l,u.l,v.l,w.l,x.l,y.l,z.l"
                Index.l = GetGadgetState(#Gadget_Form1_lbInterfaces)
                Err.l = oTypeLib\GetTypeInfo(Index, @oCurrentTypeInfo.ITypeInfo);
                CheckFatalError(Err,"Can't get TypeInfo from TypeLib")
                aTypeAttributes.l
                Err.l = oCurrentTypeInfo\GetTypeAttr(@aTypeAttributes)
                CheckFatalError(Err,"Can't get TypeAttributes from TypeInfo")
                *oTypeAttributes.TYPEATTR=aTypeAttributes
                If *oTypeAttributes\typekind=#TKIND_DISPATCH Or *oTypeAttributes\typekind=#TKIND_INTERFACE
                  Err.l = StringFromClsid_(*oTypeAttributes\guid,@IIDwStr)
                  CheckFatalError(Err,"Not a valid IDD")
                  IIDbStr.s=ByteStr(IIDwStr)
                
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"DataSection")
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  IID_"+GetGadgetText(#Gadget_Form1_lbInterfaces)+":")
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  Data.l $"+Mid(IIDbStr,2,8))
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  Data.w $"+Mid(IIDbStr,11,4)+",$"+Mid(IIDbStr,16,4))
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  Data.b $"+Mid(IIDbStr,21,2)+",$"+Mid(IIDbStr,23,2)+",$"+Mid(IIDbStr,26,2)+",$"+Mid(IIDbStr,28,2)+",$"+Mid(IIDbStr,30,2)+",$"+Mid(IIDbStr,32,2)+",$"+Mid(IIDbStr,34,2)+",$"+Mid(IIDbStr,36,2))
                
                                
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"EndDataSection")                
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"")                
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"IID_"+GetGadgetText(#Gadget_Form1_lbInterfaces)+"Str.s="+Chr(34)+IIDbStr+Chr(34))
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"")                
                
                  Nr.l=*oTypeAttributes\cFuncs
                  If GetGadgetState(#Gadget_Form1_opVtable)=1
                    hRefType.l
                    Err.l=oCurrentTypeInfo\GetRefTypeOfImplType(-1,@hRefType)
                    If CheckError(Err,"No custom Vtable interface, choose dispinterface")
                      Continue
                    EndIf  
                    Err.l=oCurrentTypeInfo\GetRefTypeInfo(hRefType,@oCurrentTypeInfo.ITypeInfo)
                    If CheckError(Err,"No custom Vtable interface, choose dispinterface")
                      Continue
                    EndIf  
                    Nr=Nr-7
                    Extends.s=" Extends IDispatch"
                  Else
                    Extends.s=""    
                  EndIf
                  
                  If Nr>0
                    If GetGadgetState(#Gadget_Form1_opEnumEvents)=1
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"Enumeration")                
                    Else
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"Interface "+GetGadgetText(#Gadget_Form1_lbInterfaces)+Extends)                
                    EndIf
                  EndIf

                  For I = 0 To Nr-1
                    Err.l = oCurrentTypeInfo\GetFuncDesc(I, @aFuncDesc.l)
                    CheckFatalError(Err,"Can't Function Descriprion from TypeInfo")
                    *oFuncDesc.FUNCDESC=aFuncDesc
                    MemberID=*oFuncDesc\memid
                    NrOfParams.l=*oFuncDesc\cParams
                    NrOfParamsOpt.l=*oFuncDesc\cParamsOpt
                    InvokeKind.l=*oFuncDesc\invokekind
                    Err.l = oCurrentTypeInfo\GetDocumentation(memberID, @bstrMethod, NULL, NULL, NULL)
                    pTypeInfo.l=oCurrentTypeInfo
                    
                    STRCOMMethod.s=stringCOMMethod(*oFuncDesc, pTypeInfo)
                    
                    PreFix.s=""
                    Select InvokeKind
                      Case #INVOKE_PROPERTYGET
                        PreFix.s="Get_"
                      Case #INVOKE_PROPERTYPUT
                        PreFix.s="Put_"
                      Case #INVOKE_PROPERTYPUTREF
                        PreFix.s="Put_"
                    EndSelect
                    If GetGadgetState(#Gadget_Form1_opEnumEvents)=1
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  #On_"+ByteStr(bstrMethod)+" = "+Str(MemberID)+"   ; "+STRCOMMethod) 
                    Else
                      Err.l = oCurrentTypeInfo\GetDocumentation(memberID, @bstrMethod, NULL, NULL, NULL)
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  "+Prefix+ByteStr(bstrMethod)+"("+Mid(Left(Params,NrOfParams*4),2,100)+")"+"   ; "+STRCOMMethod) 
                    EndIf                 
                  Next
                  If Nr>0
                    If GetGadgetState(#Gadget_Form1_opEnumEvents)=1
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"EndEnumeration")                
                    Else  
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"EndInterface")                
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"")                
                    EndIf  
                  EndIf
                  CharLen.l=0
                  For i=0 To CountGadgetItems(#Gadget_Form1_lbIncludeFile)-1
                    TmpCharLen.l=Len(GetGadgetItemText(#Gadget_Form1_lbIncludeFile, i,0))
                    If TmpCharLen > CharLen
                      CharLen=TmpCharLen
                    EndIf
                  Next
                  Err.l=GetTextMetrics_(GetDC_(GadgetID(#Gadget_Form1_lbIncludeFile)),@tm.TEXTMETRIC)
                  PixLen.l=CharLen*tm\tmAveCharWidth
                  Err.l=SendMessage_( GadgetID(#Gadget_Form1_lbIncludeFile), #LB_SETHORIZONTALEXTENT, PixLen, 0)
                Else
                  MessageRequester("Information","Only (Dispatch)-Interfaces contribute to the Include File",0)
                EndIf  
            EndSelect
           Case #Gadget_Form1_lbIncludeFile
            Select EventType()
              Case #PB_EventType_LeftDoubleClick
              Default
            EndSelect
        EndSelect

    EndSelect
  Until quitForm1
  CloseWindow(#Window_Form1)
EndIf
End

The 2 include file for this program

Code: Select all

;-Window Constants
Enumeration
  #Window_Form1
EndEnumeration
#WindowIndex=#PB_Compiler_EnumerationValue




;-Gadget Constants
Enumeration
  ;Window_Form1
  #Gadget_Form1_lbClassName
  #Gadget_Form1_lbInterfaces
  #Gadget_Form1_lbIncludeFile
  #Gadget_Form1_btSaveFile
  #Gadget_Form1_txControls
  #Gadget_Form1_txInterfaces
  #Gadget_Form1_txInckudeFile
  #Gadget_Form1_opVtable
  #Gadget_Form1_opDispatch
  #Gadget_Form1_opEnumEvents


EndEnumeration
#GadgetIndex=#PB_Compiler_EnumerationValue





;-Load Images

and

Code: Select all

XIncludeFile "Controls_Constants.pb"


Procedure.l Window_Form1()
  If OpenWindow(#Window_Form1,95,349,603,484,#PB_Window_SystemMenu|#PB_Window_MinimizeGadget|#PB_Window_MaximizeGadget|#PB_Window_Invisible," OLE/COM Include File Generator")
    If CreateGadgetList(WindowID(#Window_Form1))
      ListViewGadget(#Gadget_Form1_lbClassName,10,30,260,200,#LBS_SORT)
      ListViewGadget(#Gadget_Form1_lbInterfaces,290,30,300,200)
      ListViewGadget(#Gadget_Form1_lbIncludeFile,10,270,460,200,#WS_HSCROLL)
      ButtonGadget(#Gadget_Form1_btSaveFile,490,270,100,20,"Save XIncludeFile")
      TextGadget(#Gadget_Form1_txControls,10,10,95,15,"OLE/COM Controls")
      TextGadget(#Gadget_Form1_txInterfaces,305,10,50,15,"Interfaces")
      TextGadget(#Gadget_Form1_txInckudeFile,10,250,110,15,"PureBasic Include File")
      OptionGadget(#Gadget_Form1_opVtable,355,10,55,15,"VTable")
      OptionGadget(#Gadget_Form1_opDispatch,415,10,85,15,"DispInterface")
      OptionGadget(#Gadget_Form1_opEnumEvents,500,10,85,15,"Enum-Events")
      HideWindow(#Window_Form1,0)
      ProcedureReturn WindowID()
    EndIf
  EndIf
EndProcedure

I made an example how to use the generator with the MS Calendar Control
The main PB file

Code: Select all

;-Init Includes
XIncludeFile "Calendar_Constants.pb"
XIncludeFile "Calendar_Windows.pb"
XIncludeFile "Calendar.inc"
XIncludeFile "OleCom.inc"

Procedure CheckError(Err.l, ErrTxt.s)
  If Err <> 0
    MessageRequester("Fatal Error",ErrTxt+", Error : "+Hex(Err) ,0)
    End
  EndIf
EndProcedure  

Procedure Dummy(a.l)
  ProcedureReturn 0
EndProcedure

Procedure QueryInterface(this.l, a.l, b.l)
  ProcedureReturn @Event
EndProcedure

Procedure Invoke(this.l, dispid.l, b.l, c.l, d.l, pDispParam.l,f.l,g.l,h.l)
  Select dispid
    Case #On_DblClick
      MessageRequester("Dubble click", "Happy 2004",0)
    Case #On_KeyPress
      *DispParams.DISPPARAMS=pDispParam
      *Variant.VARIANTARG=*DispParams\rgvarg
      MessageRequester("Key Pressed",Hex(*Variant\vt)+" "+Chr(PeekW(*Variant\union)),0)
    Case #On_NewMonth
      MessageRequester("Change Month", "Happy 2004",0)
    Case #On_NewYear
      MessageRequester("Change Year", "Happy 2004",0)
    Default  
  EndSelect    
  ProcedureReturn 0
EndProcedure

Procedure CreateMyClass() 
  Shared x 
  Dim CreateMyClass_Interface.l(7) 
  CreateMyClass_Interface(0) = @QueryInterface() 
  CreateMyClass_Interface(1) = @Dummy() 
  CreateMyClass_Interface(2) = @Dummy() 
  CreateMyClass_Interface(3) = @Dummy() 
  CreateMyClass_Interface(4) = @Dummy() 
  CreateMyClass_Interface(5) = @Dummy() 
  CreateMyClass_Interface(6) = @Invoke() 
  x = @CreateMyClass_Interface() 
  ProcedureReturn @x 
EndProcedure 

Event.IDispatch=CreateMyClass()

;-Main Loop
If Window_Form1()
  *oCal.ICalendar = ActiveXContainer(WindowID(),20,20,290,200,ProgID_Calendar,IID_ICalendarStr)

  Err.l=*oCal\QueryInterface(?IConnectionPointContainer,@oCPC.ICPC)
  CheckError(Err,"Couldn't init ConnectionPointContainer")
  Err.l=oCPC\AddRef()

  Err.l=oCPC\FindConnectionPoint(?IID_DCalendarEvents,@oCP.ICP)
  CheckError(Err,"Couldn't find ConnectionPoint")
  Err.l=oCP\AddRef()

  Err.l=oCP\Advise(Event,@Cookie)
  CheckError(Err,"Couldn't advise Event")

  Err.l=oCPC\Release()
  Err.l=oCP\Release()

  quitForm1=0
  Repeat
    EventID=WaitWindowEvent()
    Select EventID
      Case #PB_Event_CloseWindow
        If EventWindowID()=#Window_Form1
          quitForm1=1
        EndIf
      Case #PB_Event_Gadget
        Select EventGadgetID()
          Case #Gadget_Form1_String2
          Case #Gadget_Form1_Button3
            Maand.l
            Dag.l
            Jaar.l
            Err.l=*oCal\Get_Month(@Maand)
            Err.l=*oCal\Get_Day(@Dag)
            Err.l=*oCal\Get_Year(@Jaar)
            SetGadgetText(#Gadget_Form1_String2,Str(Dag)+"/"+Str(Maand)+"/"+Str(Jaar))
        EndSelect
    EndSelect
  Until quitForm1
  Delete(*oCal)
  CloseWindow(#Window_Form1)
EndIf
End

The generated XIncludeFile : Calendar.inc

Code: Select all

DataSection
  CLSID_Calendar:
  Data.l $8E27C92B
  Data.w $1264,$101C
  Data.b $8A,$2F,$04,$02,$24,$00,$9C,$02
EndDataSection

ProgID_Calendar.s="MSCAL.Calendar.7"

DataSection
  IID_ICalendar:
  Data.l $8E27C92C
  Data.w $1264,$101C
  Data.b $8A,$2F,$04,$02,$24,$00,$9C,$02
EndDataSection

IID_ICalendarStr.s="{8E27C92C-1264-101C-8A2F-040224009C02}"

Interface ICalendar Extends IDispatch
  Get_BackColor(a.l)   ; [VOffset($1C), propget] HRESULT BackColor([out, retval] OLE_COLOR* pclrBackColor)
  Put_BackColor(a.l)   ; [VOffset($20), propput] HRESULT BackColor([in] OLE_COLOR pclrBackColor)
  Get_Day(a.l)   ; [VOffset($24), propget] HRESULT Day([out, retval] short* pnDay)
  Put_Day(a.l)   ; [VOffset($28), propput] HRESULT Day([in] short pnDay)
  Get_DayFont(a.l)   ; [VOffset($2C), propget] HRESULT DayFont([out, retval] IFontDisp** ppfontDayFont)
  Put_DayFont(a.l)   ; [VOffset($30), propput] HRESULT DayFont([in] IFontDisp* ppfontDayFont)
  Get_DayFontColor(a.l)   ; [VOffset($34), propget] HRESULT DayFontColor([out, retval] OLE_COLOR* pclrDayFontColor)
  Put_DayFontColor(a.l)   ; [VOffset($38), propput] HRESULT DayFontColor([in] OLE_COLOR pclrDayFontColor)
  Get_DayLength(a.l)   ; [VOffset($3C), propget] HRESULT DayLength([out, retval] short* pnDayLength)
  Put_DayLength(a.l)   ; [VOffset($40), propput] HRESULT DayLength([in] short pnDayLength)
  Get_FirstDay(a.l)   ; [VOffset($44), propget] HRESULT FirstDay([out, retval] short* pnFirstDay)
  Put_FirstDay(a.l)   ; [VOffset($48), propput] HRESULT FirstDay([in] short pnFirstDay)
  Get_GridCellEffect(a.l)   ; [VOffset($4C), propget] HRESULT GridCellEffect([out, retval] long* plGridCellEffect)
  Put_GridCellEffect(a.l)   ; [VOffset($50), propput] HRESULT GridCellEffect([in] long plGridCellEffect)
  Get_GridFont(a.l)   ; [VOffset($54), propget] HRESULT GridFont([out, retval] IFontDisp** ppfontGridFont)
  Put_GridFont(a.l)   ; [VOffset($58), propput] HRESULT GridFont([in] IFontDisp* ppfontGridFont)
  Get_GridFontColor(a.l)   ; [VOffset($5C), propget] HRESULT GridFontColor([out, retval] OLE_COLOR* pclrGridFontColor)
  Put_GridFontColor(a.l)   ; [VOffset($60), propput] HRESULT GridFontColor([in] OLE_COLOR pclrGridFontColor)
  Get_GridLinesColor(a.l)   ; [VOffset($64), propget] HRESULT GridLinesColor([out, retval] OLE_COLOR* pclrGridLinesColor)
  Put_GridLinesColor(a.l)   ; [VOffset($68), propput] HRESULT GridLinesColor([in] OLE_COLOR pclrGridLinesColor)
  Get_Month(a.l)   ; [VOffset($6C), propget] HRESULT Month([out, retval] short* pnMonth)
  Put_Month(a.l)   ; [VOffset($70), propput] HRESULT Month([in] short pnMonth)
  Get_MonthLength(a.l)   ; [VOffset($74), propget] HRESULT MonthLength([out, retval] short* pnMonthLength)
  Put_MonthLength(a.l)   ; [VOffset($78), propput] HRESULT MonthLength([in] short pnMonthLength)
  Get_ShowDateSelectors(a.l)   ; [VOffset($7C), propget] HRESULT ShowDateSelectors([out, retval] VARIANT_BOOL* pfShowDateSelectors)
  Put_ShowDateSelectors(a.l)   ; [VOffset($80), propput] HRESULT ShowDateSelectors([in] VARIANT_BOOL pfShowDateSelectors)
  Get_ShowDays(a.l)   ; [VOffset($84), propget] HRESULT ShowDays([out, retval] VARIANT_BOOL* pfShowDays)
  Put_ShowDays(a.l)   ; [VOffset($88), propput] HRESULT ShowDays([in] VARIANT_BOOL pfShowDays)
  Get_ShowHorizontalGrid(a.l)   ; [VOffset($8C), propget] HRESULT ShowHorizontalGrid([out, retval] VARIANT_BOOL* pfShowHorizontalGrid)
  Put_ShowHorizontalGrid(a.l)   ; [VOffset($90), propput] HRESULT ShowHorizontalGrid([in] VARIANT_BOOL pfShowHorizontalGrid)
  Get_ShowTitle(a.l)   ; [VOffset($94), propget] HRESULT ShowTitle([out, retval] VARIANT_BOOL* pfShowTitle)
  Put_ShowTitle(a.l)   ; [VOffset($98), propput] HRESULT ShowTitle([in] VARIANT_BOOL pfShowTitle)
  Get_ShowVerticalGrid(a.l)   ; [VOffset($9C), propget] HRESULT ShowVerticalGrid([out, retval] VARIANT_BOOL* pfShowVerticalGrid)
  Put_ShowVerticalGrid(a.l)   ; [VOffset($A0), propput] HRESULT ShowVerticalGrid([in] VARIANT_BOOL pfShowVerticalGrid)
  Get_TitleFont(a.l)   ; [VOffset($A4), propget] HRESULT TitleFont([out, retval] IFontDisp** ppfontTitleFont)
  Put_TitleFont(a.l)   ; [VOffset($A8), propput] HRESULT TitleFont([in] IFontDisp* ppfontTitleFont)
  Get_TitleFontColor(a.l)   ; [VOffset($AC), propget] HRESULT TitleFontColor([out, retval] OLE_COLOR* pclrTitleFontColor)
  Put_TitleFontColor(a.l)   ; [VOffset($B0), propput] HRESULT TitleFontColor([in] OLE_COLOR pclrTitleFontColor)
  Get_Value(a.l)   ; [VOffset($B4), propget] HRESULT Value([out, retval] VARIANT* pvarValue)
  Put_Value(a.l)   ; [VOffset($B8), propput] HRESULT Value([in] VARIANT pvarValue)
  Get__Value(a.l)   ; [VOffset($BC), propget] HRESULT _Value([out, retval] VARIANT* pvarValue)
  Put__Value(a.l)   ; [VOffset($C0), propput] HRESULT _Value([in] VARIANT pvarValue)
  Get_ValueIsNull(a.l)   ; [VOffset($C4), propget] HRESULT ValueIsNull([out, retval] VARIANT_BOOL* pfValueIsNull)
  Put_ValueIsNull(a.l)   ; [VOffset($C8), propput] HRESULT ValueIsNull([in] VARIANT_BOOL pfValueIsNull)
  Get_Year(a.l)   ; [VOffset($CC), propget] HRESULT Year([out, retval] short* pnYear)
  Put_Year(a.l)   ; [VOffset($D0), propput] HRESULT Year([in] short pnYear)
  NextDay()   ; [VOffset($D4)] HRESULT NextDay()
  NextMonth()   ; [VOffset($D8)] HRESULT NextMonth()
  NextWeek()   ; [VOffset($DC)] HRESULT NextWeek()
  NextYear()   ; [VOffset($E0)] HRESULT NextYear()
  PreviousDay()   ; [VOffset($E4)] HRESULT PreviousDay()
  PreviousMonth()   ; [VOffset($E8)] HRESULT PreviousMonth()
  PreviousWeek()   ; [VOffset($EC)] HRESULT PreviousWeek()
  PreviousYear()   ; [VOffset($F0)] HRESULT PreviousYear()
  Refresh()   ; [VOffset($F4)] HRESULT Refresh()
  Today()   ; [VOffset($F8)] HRESULT Today()
  AboutBox()   ; [VOffset($FC)] HRESULT AboutBox()
EndInterface

DataSection
  IID_DCalendarEvents:
  Data.l $8E27C92D
  Data.w $1264,$101C
  Data.b $8A,$2F,$04,$02,$24,$00,$9C,$02
EndDataSection

IID_DCalendarEventsStr.s="{8E27C92D-1264-101C-8A2F-040224009C02}"

Enumeration
  #On_Click = -600   ; [id($FFFFFDA8)] void Click()
  #On_DblClick = -601   ; [id($FFFFFDA7)] void DblClick()
  #On_KeyDown = -602   ; [id($FFFFFDA6)] void KeyDown(short* KeyCode, short Shift)
  #On_KeyPress = -603   ; [id($FFFFFDA5)] void KeyPress(short* KeyAscii)
  #On_KeyUp = -604   ; [id($FFFFFDA4)] void KeyUp(short* KeyCode, short Shift)
  #On_BeforeUpdate = 2   ; [id($2)] void BeforeUpdate(short* Cancel)
  #On_AfterUpdate = 1   ; [id($1)] void AfterUpdate()
  #On_NewMonth = 3   ; [id($3)] void NewMonth()
  #On_NewYear = 4   ; [id($4)] void NewYear()
EndEnumeration

A standard OLECOM.inc file :

Code: Select all

;  Enumerations

Enumeration  
  #DVASPECT_CONTENT    = 1 
  #DVASPECT_THUMBNAIL  = 2 
  #DVASPECT_ICON       = 4 
  #DVASPECT_DOCPRINT   = 8 
EndEnumeration 

;  Structures

Structure DISPPARAMS
  rgvarg.l
  rgdispidNamedArgs.l
  cArgs.w
  cNamedArgs.w
EndStructure

Structure VARIANTARG
  vt.w
  dummy1.w
  dummy2.w
  dummy3.w
  union.l
EndStructure

Interface ICP Extends IUnknown
  GetConnectionInterface(a.l)
  GetConnectionPointContainer(a.l)
  Advise(a.l, b.l)
  Unadvise(a.l)
  EnumConnections(a.l)
EndInterface

;  Interfaces

Interface ICPC Extends IUnknown
  EnumConnectionPoints (a.l)
  FindConnectionPoint (a.l, b.l)
EndInterface

Interface IOleWindow Extends IUnknown
  GetWindow()
  ContextSensitiveHelp()
EndInterface

Interface IOleInPlaceObject Extends IOleWindow
  InPlaceDeactivate()
  UIDeactivate()
  SetObjectRects(a.l, b.l)
  ReactivateAndUndo()
EndInterface


Interface IOleObject Extends IUnknown
  SetClientSite(a.l)
  GetClientSite(a.l)
  SetHostNames()
  Close()
  SetMoniker()
  GetMoniker()
  InitFromData()
  GetClipboardData()
  DoVerb(a.l, b.l, c.l, d.l, e.l, f.l)
  EnumVerbs()
  Update()
  IsUpToDate()
  GetUserClassID()
  GetUserType()
  SetExtent(a.l,b.l)
  GetExtent(a.l,b.l)
  Advise()
  UnAdvise()
  EnumAdvise()
  GetMiscStatus()
  SetColorScheme()
EndInterface

Interface IViewObject Extends IUnknown
  Draw(a.l, b.l, c.l, d.l, e.l, f.l, g.l, h.l, i.l, j.l)
  GetColorSet()
  Freeze()
  UnFreeze()
  SetAdvise()
  GetAdvise()
EndInterface

Interface IViewObject2 Extends IViewObject
  GetExtent(a.l)
EndInterface

; Data Section

DataSection 
  IConnectionPointContainer:  ;  {B196B284-BAB4-101A-B69C-00AA00341D07}
    Data.l $B196B284 
    Data.w $BAB4,$101A 
    Data.b $B6, $9C, $00,$AA,$00,$34,$1D,$07 
    
  IOleObject:   ;  {00000112-0000-0000-C000-000000000046}  
    Data.l $00000112 
    Data.w $0000,$0000 
    Data.b $C0, $00, $00,$00,$00,$00,$00,$46
    
  IOleInPlaceObject:  ;  {00000113-0000-0000-C000-000000000046}    
    Data.l $00000113 
    Data.w $0000,$0000 
    Data.b $C0, $00, $00,$00,$00,$00,$00,$46
    
  IViewObject:  ; {0000010D-0000-0000-C000-000000000046}  
    Data.l $0000010D 
    Data.w $0000,$0000 
    Data.b $C0, $00, $00,$00,$00,$00,$00,$46
EndDataSection 

;  Procedures

Procedure RegisterDLL(DLL$)
  CoInitialize_(0)
  If OpenLibrary(1,DLL$)
    If CallFunction(1,"DllRegisterServer") = #S_OK
      RegisterDLL = #TRUE
    EndIf
    CloseLibrary(1)
  EndIf

  ProcedureReturn RegisterDLL
EndProcedure


Procedure UnRegisterDLL(DLL$)
  CoUninitialize_()
  If OpenLibrary(1,DLL$)
    If CallFunction(1,"DllUnregisterServer") = #S_OK
      UnRegisterDLL = #TRUE
    EndIf
    CloseLibrary(1)
  EndIf
  ProcedureReturn UnRegisterDLL
EndProcedure


Procedure Delete(*obj.IUnknown)
  Err.l=*obj\Release()
EndProcedure

Procedure EndAtlAx()
  CallFunction(2,"AtlAxWinTerm")
EndProcedure


Procedure ActiveXContainer(hParent,x,y,w,h,Control$,IID$)
  Shared CreateActiveXControl_init

  If CreateActiveXControl_init=0
    If OpenLibrary(2,"ATL.DLL")
      CallFunction(2,"AtlAxWinInit")
      CreateActiveXControl_init=1
    Else
      MessageRequester("","Geen ATL",0)
      ProcedureReturn 0
    EndIf
  Else  
      MessageRequester("","Geen ATL",0)
  EndIf
  ;  MessageRequester("","", 0)

  hWnd = CreateWindowEx_(0,"AtlAxWin",Control$,#WS_CHILD|#WS_VISIBLE,x,y,w,h,hParent,0,GetModuleHandle_(0),0)
  If hWnd
    CallFunction(2,"AtlAxGetControl",hWnd,@obj2.IUnknown)
    A$ = Space((Len(IID$)+1)*2)
    MultiByteToWideChar_(#CP_ACP,0,IID$,-1,@A$,Len(A$))
    If CLSIDFromString_(A$,IID.GUID) = #NOERROR
      obj2\QueryInterface(IID,@final)
    EndIf
    If final
      CreateActiveXControl = final
    Else
      MessageRequester("Fatal Error","Could not create ActiveX instance",0)
      DestroyWindow_(hWnd)
      End
    EndIf
    
  EndIf
  ProcedureReturn CreateActiveXControl
EndProcedure

And the two PureVision includes files :

Code: Select all

;-Window Constants
Enumeration
  #Window_Form1
EndEnumeration
#WindowIndex=#PB_Compiler_EnumerationValue




;-Gadget Constants
Enumeration
  ;Window_Form1
  #Gadget_Form1_String2
  #Gadget_Form1_Button3


EndEnumeration
#GadgetIndex=#PB_Compiler_EnumerationValue





;-Load Images

And

Code: Select all

XIncludeFile "Calendar_Constants.pb"


Procedure.l Window_Form1()
  If OpenWindow(#Window_Form1,276,5,347,300,#PB_Window_SystemMenu|#PB_Window_MinimizeGadget|#PB_Window_MaximizeGadget|#PB_Window_Invisible,"MS Calendar ActiveX Sample")
    If CreateGadgetList(WindowID(#Window_Form1))
      StringGadget(#Gadget_Form1_String2,95,260,80,20,"")
      ButtonGadget(#Gadget_Form1_Button3,20,260,70,20,"Show Datum")
      HideWindow(#Window_Form1,0)
      ProcedureReturn WindowID()
    EndIf
  EndIf
EndProcedure

A lot of code, I hope you can use it.

[Leo]

Code and Executables of ActiveX Include File Generator with some more examples can now be downloaded from http://www.reelmediaproductions.com/pb/ ... deFile.zip

Greetings

Leo

[Fred]

Very interesting piece of code, thanks..

[Manne]

@Leo

Doesn't work here.
Get always the following error, "Typelib not registered. Error:5".
Win XP SP1

Manne

[fsw]

@Leo

Doesn't work here.
Get always the following error, "Typelib not registered. Error:5".
Win XP SP1

Manne

Same here... WinXPhomeSP1

Also it's not possible to compile controls.pb, GUID structure is missing.

[PolyVector]

Same here
WinXP Pro SP1

[Leo]

I developed the program on Win 98 and did not test it on WIN XP.

About the error.

In the top left listview's the controls in the registry are shown. If you click one of them, the program searches for the registered typelib of the control. The typelib contains all the information about the control and without it, it is impossible to retrieve the data necessary for generating the XIncludeFile.

Greetings

Leo

[Leo]

I added some code that will ask for the file that contains the typelibrary (*.tlb; *.olb, *.dll, *.exe; *.ocx) if the type library is not registered. In that case you have to know the file name.

Code: Select all

;-Init Includes
XIncludeFile "Controls_Constants.pb"
XIncludeFile "Controls_Windows.pb"

Enumeration
  #INVOKE_FUNC             = 1
  #INVOKE_PROPERTYGET      = 2
  #INVOKE_PROPERTYPUT      = 4
  #INVOKE_PROPERTYPUTREF   = 8
EndEnumeration 

Enumeration 
  #USERCLASSTYPE_FULL       = 1 
  #USERCLASSTYPE_SHORT  
  #USERCLASSTYPE_APPNAME 
EndEnumeration 

Enumeration
  #TKIND_ENUM  
  #TKIND_RECORD 
  #TKIND_MODULE 
  #TKIND_INTERFACE 
  #TKIND_DISPATCH
  #TKIND_COCLASS
  #TKIND_ALIAS
  #TKIND_UNION
  #TKIND_MAX  
EndEnumeration 

Enumeration
  #FUNC_VIRTUAL    = 0
  #FUNC_PUREVIRTUAL= #FUNC_VIRTUAL + 1
  #FUNC_NONVIRTUAL = #FUNC_PUREVIRTUAL + 1
  #FUNC_STATIC     = #FUNC_NONVIRTUAL + 1
  #FUNC_DISPATCH   = #FUNC_STATIC + 1
EndEnumeration 

Enumeration
  #VAR_PERINSTANCE = 0
  #VAR_STATIC      = #VAR_PERINSTANCE + 1
  #VAR_CONST       = #VAR_STATIC + 1
  #VAR_DISPATCH    = #VAR_CONST + 1
EndEnumeration  

Enumeration
  #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_FILETIME     = 64
  #VT_BLOB         = 65
  #VT_STREAM       = 66
  #VT_STORAGE      = 67 
  #VT_STREAMED_OBJECT      = 68
  #VT_STORED_OBJECT        = 69
  #VT_BLOB_OBJECT  = 70
  #VT_CF           = 71
  #VT_CLSID        = 72
  #VT_BSTR_BLOB    = $fff
  #VT_VECTOR       = $1000
  #VT_ARRAY        = $2000
  #VT_BYREF        = $4000
  #VT_RESERVED     = $8000
  #VT_ILLEGAL      = $ffff
  #VT_ILLEGALMASKED= $fff
  #VT_TYPEMASK     = $fff
EndEnumeration                

Enumeration
  #PARAMFLAG_NONE = $00
  #PARAMFLAG_FIN = $01
  #PARAMFLAG_FOUT = $02
  #PARAMFLAG_FLCID = $04
  #PARAMFLAG_FRETVAL = $08
  #PARAMFLAG_FOPT = $10
  #PARAMFLAG_FHASDEFAULT = $20
  #PARAMFLAG_FHASCUSTDATA = $40
EndEnumeration                

Structure VARIANTARG
  vt.w
  dummy1.w
  dummy2.w
  dummy3.w
  union.l
EndStructure

Structure PARAMDESC
  pparamdescex.l
  wParamFlags.w
EndStructure  

Structure PARAMDESCEX
  cBytes.l
  dummy.l   ; Deze dummy begrijp ik niet
  varDefaultValue.VARIANTARG
EndStructure

Structure TYPEDESC
  union.l
  vt.w
EndStructure

Structure ELEMDESC 
  tdesc.TYPEDESC
  dummy.w
  paramdesc.PARAMDESC
  dummy.w
EndStructure

Structure FUNCDESC
  memid.l
  scode.l
  *lprgelemdescParam.ELEMDESC
  funckind.l
  invokekind.l
  callconv.l
  cParams.w 
  cParamsOpt.w 
  oVft.w 
  cScodes.w 
  *elemdescFunc.ELEMDESC
  wFuncFlags.w
EndStructure

Structure TYPEATTR
  guid.GUID
  lcid.l
  dwReserved.l
  memidConstructor.l
  memidDestructor.l
  lpstrSchema.l
  cbSizeInstance.l
  typekind.l
  cFuncs.w
  cVars.w
  cImplTypes.w
  cbSizeVft.w
  cbAlignment.w
  wTypeFlags.w
  wMajorVerNum.w
  wMinorVerNum.w
  tdescAlias.l
  idldescType.l
EndStructure

Structure VARDESC
  memid.l
  lpstrSchema.l
  union.l
  *elemdescVar.ELEMDESC
  wVarFlags.w
  varkind.w
EndStructure  

Procedure.s HexString(Source.l, l.l) 
    result.s
    
    result.s = ""
    For i = 0 To l
        result = result + Right("00" + Hex(PeekB(PeekL(Source)+i)), 2) + " "
    Next i
    
    ProcedureReturn result
EndProcedure


Procedure.s ByteStr(pointer.l) 
  strlen.w = WideCharToMultiByte_(#CP_ACP, 0, pointer, -1, 0, 0 , 0, 0) 
  string.s = Space(strlen) 
  If strlen <> 0 
    newlen.w = WideCharToMultiByte_(#CP_ACP, 0, pointer, -1, @string, strlen , 0, 0) 
  EndIf 
  ProcedureReturn string 
EndProcedure

Procedure.l WideStr(pointer.l, mem.l) 
  widelen.w = 2*Len(PeekS(pointer))+2 
  widebuf.l = AllocateMemory(mem, widelen) 
  longlen.w = MultiByteToWideChar_(#CP_ACP,0,pointer,-1,widebuf,widelen) 
  ProcedureReturn widebuf 
EndProcedure 

Procedure CheckFatalError(Err.l, ErrTxt.s)
  If Err <> 0
    MessageRequester("Fatal Error",ErrTxt+", Error : "+Hex(Err) ,0)
    End
  EndIf
EndProcedure
  
Procedure.l CheckError(Err.l, ErrTxt.s)
  If Err <> 0
    MessageRequester("Information",ErrTxt+", Error : "+Hex(Err) ,0)
    ProcedureReturn 1
  EndIf
  ProcedureReturn 0
EndProcedure  

Procedure.s stringCustomType(RefType.l, pTypeInfo.l)
  *TypeInfo.ITypeInfo=pTypeInfo
  
  If *TypeInfo\GetRefTypeInfo(RefType, @CustTypeInfo.ITypeInfo)=0
    If CustTypeInfo\GetDocumentation(-1, @bstrType, 0, 0, 0)=0
      ProcedureReturn ByteStr(bstrType)
    Else
      ProcedureReturn "UnknownCustomType"
    EndIf
  Else
    ProcedureReturn "UnknownCustomType"
  EndIf  
  ProcedureReturn "UnknownCustomType"
EndProcedure

Procedure.s stringTypeDesc(pTypeDesc.l, pTypeInfo.l)
  *TypeDesc.TYPEDESC=pTypeDesc
  *TypeInfo.ITypeInfo=pTypeInfo
  If *TypeDesc\vt = #VT_PTR
    ProcedureReturn stringTypeDesc(*TypeDesc\union, pTypeInfo)+"*"
  EndIf  
  If *TypeDesc\vt = #VT_SAFEARRAY
    ProcedureReturn "SAFEARRAY("+stringTypeDesc(*TypeDesc\union, pTypeInfo)+")"
  EndIf  
;  If pTypeDesc\vt = #VT_CARRAY
;    CArray.s=stringTypeDesc(@*TypeDesc\lpadesc\tdescElem, @*TypeInfo)
;  EndIf  
;  If pTypeDesc\vt = #VT_USERDEFINED
;    CArray.s=stringTypeDesc(@*TypeDesc\lpadesc\tdescElem, @*TypeInfo)
;  EndIf  
;    If(typeDesc->vt == VT_CARRAY) {
;        oss<< stringifyTypeDesc(&typeDesc->lpadesc->tdescElem, pTypeInfo);
;        for(int dim(0); typeDesc->lpadesc->cDims; ++dim) 
;            oss<< '['<< typeDesc->lpadesc->rgbounds[dim].lLbound<< "..."
;                << (typeDesc->lpadesc->rgbounds[dim].cElements + 
;                typeDesc->lpadesc->rgbounds[dim].lLbound - 1)<< ']';
;        return oss.str();
;    }
  If *TypeDesc\vt = #VT_USERDEFINED
    ProcedureReturn stringCustomType(*TypeDesc\union, pTypeInfo)
  EndIf
  Vt.l=*TypeDesc\vt
  Select Vt.l
    Case #VT_I2: ProcedureReturn "short";
    Case #VT_I4: ProcedureReturn "long";
    Case #VT_R4: ProcedureReturn "float";
    Case #VT_R8: ProcedureReturn "double";
    Case #VT_CY: ProcedureReturn "CY";
    Case #VT_DATE: ProcedureReturn "DATE";
    Case #VT_BSTR: ProcedureReturn "BSTR";
    Case #VT_DISPATCH: ProcedureReturn "IDispatch*";
    Case #VT_ERROR: ProcedureReturn "SCODE";
    Case #VT_BOOL: ProcedureReturn "VARIANT_BOOL";
    Case #VT_VARIANT: ProcedureReturn "VARIANT";
    Case #VT_UNKNOWN: ProcedureReturn "IUnknown*";
    Case #VT_UI1: ProcedureReturn "BYTE";
    Case #VT_DECIMAL: ProcedureReturn "DECIMAL";
    Case #VT_I1: ProcedureReturn "char";
    Case #VT_UI2: ProcedureReturn "USHORT";
    Case #VT_UI4: ProcedureReturn "ULONG";
    Case #VT_I8: ProcedureReturn "__int64";
    Case #VT_UI8: ProcedureReturn "unsigned __int64";
    Case #VT_INT: ProcedureReturn "int";
    Case #VT_UINT: ProcedureReturn "UINT";
    Case #VT_HRESULT: ProcedureReturn "HRESULT";
    Case #VT_VOID: ProcedureReturn "void"
    Case #VT_LPSTR: ProcedureReturn "char*";
    Case #VT_LPWSTR: ProcedureReturn "wchar_t*";
  EndSelect
  ProcedureReturn "BIG ERROR!";
EndProcedure

Procedure.s stringVarDesc(pVarDesc.l, pTypeInfo.l)
  *VarDesc.VARDESC=pVarDesc
  *TypeInfo.ITYPEINFO=pTypeInfo
  bstrName.s
  If *VarDesc\varkind = #VAR_CONST
    RetStr.s="const "+stringTypeDesc(@*VarDesc\elemdescVar\tdesc, @*TypeInfo)
    If *TypeInfo\GetDocumentation(*VarDesc\memid, @bstrName ,0, 0, 0)
      RetStr=RetStr+" "+ByteStr(@bstrName)+" = "
      If VariantChangeType_( @Variant, *VarDesc\union,0,#VT_BSTR)
        RetStr=RetStr+"???"
      Else
        RetStr=RetStr+ByteStr(@Variant)
      EndIf   
    Else
      RetStr="UnknownName"
    EndIf
  EndIf
  ProcedureReturn RetStr    
EndProcedure

Procedure.s stringParameterAttributes(pParamDesc.l) 
  *ParamDesc.PARAMDESC=pParamDesc
  paramFlags.w = *ParamDesc\wParamFlags
  
  numFlags.l=0
  bit.l=1
  While bit < #PARAMFLAG_FHASDEFAULT
    If paramFlags & bit
      numFlags=numFlags+1
    EndIf
    bit=bit*2
  Wend
  If numFlags=0
    ProcedureReturn ""
  EndIf
  RetStr.s="["
  If paramFlags & #PARAMFLAG_FIN
    RetStr=RetStr+"in, "
  EndIf 
  If paramFlags & #PARAMFLAG_FOUT
    RetStr=RetStr+"out, "
  EndIf 
  If paramFlags & #PARAMFLAG_FLCID
    RetStr=RetStr+"lcid, "
  EndIf 
  If paramFlags & #PARAMFLAG_FRETVAL
    RetStr=RetStr+"retval, "
  EndIf 
  If paramFlags & #PARAMFLAG_FOPT
    RetStr=RetStr+"optional, "
  EndIf 
  If paramFlags & #PARAMFLAG_FHASDEFAULT
    RetStr=RetStr+"defaultvalue="
    If *ParamDesc\pparamdescex
      *ParamDescEx.PARAMDESCEX=*ParamDesc\pparamdescex
      *varDefaultValue.VARIANTARG=*ParamDescEx\varDefaultValue
      
      If VariantChangeType_(@Variant.VARIANTARG,*varDefaultValue,0,#VT_BSTR)=0
        If *varDefaultValue\vt = #VT_BSTR
          RetStr=RetStr+Chr(34)
        EndIf
        RetStr=RetStr+ByteStr(Variant\union)
        If *varDefaultValue\vt = #VT_BSTR
          RetStr=RetStr+Chr(34)
        EndIf  
      Else
        RetStr=RetStr+"???"
      EndIf
    EndIf
  EndIf 
    If Right(RetStr,2)=", "
      RetStr=Left(RetStr, Len(RetStr)-2)
    EndIf
    RetStr=RetStr+"]"
  ProcedureReturn RetStr
EndProcedure  

Procedure.s stringFunctionArgument(pElemDesc.l, pTypeInfo.l)
    *ElemDesc.ELEMDESC=pElemDesc
    *TypeInfo.ITypeInfo=pTypeInfo
    pParamDesc.l=@*ElemDesc\paramdesc
    RetStr.s=stringParameterAttributes(pParamDesc)
    If Len(RetStr)>0
      RetStr=RetStr+" "      
    EndIf
    pTypeDesc.l=@*ElemDesc\tdesc
    RetStr=RetStr+stringTypeDesc(pTypeDesc.l, pTypeInfo)
  ProcedureReturn RetStr
EndProcedure  

Procedure.s stringCOMMethod(pFuncDesc.l, pTypeInfo.l)
  *FuncDesc.FUNCDESC=pFuncDesc
  *TypeInfo.ITypeInfo=pTypeInfo  
  If *FuncDesc\funckind = #FUNC_DISPATCH    
    RetStr.s="[id($"+Hex(*FuncDesc\memid)+")"
  Else 
    RetStr.s="[VOffset($"+Hex(*FuncDesc\oVft)+")"
  EndIf  
  Select *FuncDesc\invokekind
    Case #INVOKE_PROPERTYGET
      RetStr=RetStr+", propget] "
    Case #INVOKE_PROPERTYPUT
      RetStr=RetStr+", propput] "
    Case #INVOKE_PROPERTYPUTREF
      RetStr=RetStr+", propputref] "
    Case #INVOKE_FUNC
      RetStr=RetStr+"] "
  EndSelect
  RetStr=RetStr+stringTypeDesc(@*FuncDesc\elemdescFunc, pTypeInfo)
  MemberID.l=*FuncDesc\memid
  Err.l=*TypeInfo\GetDocumentation(MemberID, @bstrName, NULL, NULL, NULL)
  RetStr=RetStr+" "+ByteStr(bstrName)+"("
  RetNr.l
  ParNames.s=Space(1000)
  Nr.l=*FuncDesc\cParams
  Err.l=*TypeInfo\GetNames(MemberID,@ParNames,Nr.l+1, @RetNr)
  If *FuncDesc\cParams > 0
    pTemp.l=*FuncDesc\lprgelemdescParam
  EndIf  
  pElemDescParam.l=pTemp
  For i=0 To *FuncDesc\cParams-1
    If i>0
      RetStr=RetStr+", "
    EndIf
    RetStr=RetStr+stringFunctionArgument(pElemDescParam, pTypeInfo)
    RetStr=RetStr+" "+ByteStr(PeekL(@ParNames+((i+1)*4)))
    pElemDescParam=pElemDescParam+SizeOf(ELEMDESC)
  Next
  RetStr=RetStr+")"
  ProcedureReturn RetStr
EndProcedure  
  
DataSection 
  CATID_Control:  ;  CATID_Control, 0x40fc6ed4, 0x2438, 0x11cf, 0xa3, 0xdb, 0x08, 0x00, 0x36, 0xf1, 0x25, 0x02)
    Data.l $40FC6ED4 
    Data.w $2438,$11CF 
    Data.b $A3, $DB, $08,$00,$36,$F1,$25,$02

  CLSID_StdComponentCategoriesMgr:  ;  {0002E005-0000-0000-C000-000000000046}
    Data.l $0002E005 
    Data.w $0000,$0000 
    Data.b $C0, $00, $00,$00,$00,$00,$00,$46

  IID_ICatInformation:  ;  {0002E013-0000-0000-C000-000000000046}
    Data.l $0002E013 
    Data.w $0000,$0000 
    Data.b $C0, $00, $00,$00,$00,$00,$00,$46
    
  IID_Custom:   ; {0F21F359-AB84-41E8-9A78-36D110E6D2F9}  
    Data.l $0F21F359 
    Data.w $AB84,$41E8 
    Data.b $9A, $78, $36,$D1,$10,$E6,$D2,$F9
EndDataSection






;-Main Loop
If Window_Form1()

  SetGadgetState(#Gadget_Form1_opVtable,1)
  
  CoInitialize_(NULL)
  Err.l = CoCreateInstance_(?CLSID_StdComponentCategoriesMgr,0,1,?IID_ICatInformation,@oCatInfo.ICatInformation) 
  CheckFatalError(Err,"Can't Create Component Categories Manager")
  Err.l=oCatInfo\AddRef()
  Err.l=oCatInfo\EnumClassesOfCategories(1,?CATID_Control,0,@CatIdReg,@oEnumGUID.IEnumGUID);
  CheckFatalError(Err,"Can't Enumerate Classes of Categories")

  Clsid.GUID

  While  oEnumGUID\Next( 1, @Clsid, NULL )=0
    OleRegGetUserType_(@Clsid,#USERCLASSTYPE_FULL,@ClassName)
    StringFromClsid_(@Clsid,@ClsidWStr)
    SendMessage_( GadgetID(#Gadget_Form1_lbClassName), #LB_ADDSTRING, 0, ByteStr(ClassName)+Space(80)+ByteStr(ClsidWStr))
  Wend
  RemoveGadgetItem(#Gadget_Form1_lbClassName,0)

  Err.l=oCatInfo\Release()
  CoUninitialize_()

  quitForm1=0
  Repeat
    EventID=WaitWindowEvent()
    Select EventID
      Case #PB_Event_CloseWindow
        If EventWindowID()=#Window_Form1
          quitForm1=1
        EndIf
      Case #PB_Event_Gadget
        Select EventGadgetID()
          Case #Gadget_Form1_btSaveFile
            StandardFile$ = "C:\Programmeren\PureBasic\temp.pb"   ; set initial file+path to display 
            Pattern$ = "PureBasic (*.pb)|*.pb|All files (*.*)|*.*" 
            Pattern = 0    ; use the first of the three possible patterns as standard 
            File$ = SaveFileRequester("Please choose file to save", StandardFile$, Pattern$, Pattern) 
            If File$
              If Pattern=0 And FindString(File$,".",1) = 0
                File$=File$+".pb"
              EndIf
              If OpenFile(#1,File$)
                For I=1 To CountGadgetItems(#Gadget_Form1_lbIncludeFile)
                  WriteStringN(GetGadgetItemText(#Gadget_Form1_lbIncludeFile, I-1,0))            
                Next
                CloseFile(1)
              EndIf  
            Else 
              MessageRequester("Information", "The requester was canceled.", 0) 
            EndIf 

          Case #Gadget_Form1_lbClassName
            Select EventType()
              Case #PB_EventType_LeftDoubleClick
              Default
                ClearGadgetItemList(#Gadget_Form1_lbInterfaces)
                ClearGadgetItemList(#Gadget_Form1_lbIncludeFile)
                Err.l=SendMessage_( GadgetID(#Gadget_Form1_lbIncludeFile), #LB_SETHORIZONTALEXTENT, 0, 0)
                ClsidStr.s = GetGadgetText(#Gadget_Form1_lbClassName)
                Pos.l = FindString(ClsidStr,"{",1)
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"DataSection")
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  CLSID_"+StringField(Left(ClsidStr,Pos-1),1," ")+":")
                CtrlStr.s="ProgID_"+StringField(Left(ClsidStr,Pos-1),1," ")+".s="
                ClsidStr=Mid(ClsidStr,Pos,100)
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  Data.l $"+Mid(ClsidStr,2,8))
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  Data.w $"+Mid(ClsidStr,11,4)+",$"+Mid(ClsidStr,16,4))
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  Data.b $"+Mid(ClsidStr,21,2)+",$"+Mid(ClsidStr,23,2)+",$"+Mid(ClsidStr,26,2)+",$"+Mid(ClsidStr,28,2)+",$"+Mid(ClsidStr,30,2)+",$"+Mid(ClsidStr,32,2)+",$"+Mid(ClsidStr,34,2)+",$"+Mid(ClsidStr,36,2))
                
                                
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"EndDataSection")                
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"")
                Err.l=CLSIDFromString_(WideStr(@ClsidStr,1),@Clsid.GUID)
                ProgID.l 
                Err.l=ProgIDFromCLSID_(@Clsid,@ProgID)
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,CtrlStr+Chr(34)+ByteStr(ProgID)+Chr(34)) 
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"") 
                               
                NoRegTLB=0
                Err.l = RegOpenKeyEx_(#HKEY_CLASSES_ROOT,"CLSID\"+ClsidStr+"\TypeLib",0,#KEY_READ,@hTypeLib.l)
                If CheckError(Err,"Control doesn't have a Typelib")
                  NoRegTLB=1
                Else
                  TLBClsidStr.s=Space(100)
                  dwSizeOfDataBlock.l=100
                  RegQueryValue_(hTypeLib,NULL,@TLBClsidStr,@dwSizeOfDataBlock)
                
                  tchVersionInformation.s=Space(100)
                  Err.l=RegOpenKeyEx_(#HKEY_CLASSES_ROOT,"TypeLib\"+TLBClsidStr,0,KEY_READ, @hKeyClassTLB.l)
                  If CheckError(Err,"Typelib not registered")
                    NoRegTLB=1
                  Else  
                    dwCLSIDSubKeyIndex.l = 0
                    While RegEnumKey_(hKeyClassTLB,dwCLSIDSubKeyIndex ,@tchVersionInformation,20) =0
                      If RegOpenKeyEx_(hKeyClassTLB,@tchVersionInformation,0,KEY_READ,@hKeyVersion.l) =0    
                      EndIf
                      dwCLSIDSubKeyIndex=dwCLSIDSubKeyIndex+1
                    Wend
                    clsidTypeLib.GUID
                    A$ = Space((Len(TLBClsidStr)+1)*2)
                    MultiByteToWideChar_(#CP_ACP,0,TLBClsidStr,-1,@A$,Len(A$))
                    Err.l = CLSIDFromString_(A$,clsidTypeLib)
                    If CheckFatalError(Err,"Not a valid ClassId")
                      Continue
                    EndIf  
                    Major.l=Val(tchVersionInformation)
                    Pos.l = FindString(tchVersionInformation,".",1)
                    tchVersionInformation.s=Mid(tchVersionInformation,Pos+1,100)
                    Minor.l=Val(tchVersionInformation)
                
                    Err.l = LoadRegTypeLib_(clsidTypeLib,Major,Minor,0, @oTypeLib.ITypeLib)
                    If CheckError(Err,"Can't load registered TypeLib")
                      NoRegTLB=1
                    EndIf
                  EndIf    
                EndIf
                If NoRegTLB=1
                  StandardFile$ = "C:\test.dll"   ; set initial file+path to display 
                  Pattern$ = "TypeLib (*.tlb;*.olb;*.dll;*.exe;*.ocx)|*.tlb;*.olb;*.dll;*.exe;*.ocx|All files (*.*)|*.*" 
                  Pattern = 0    ; use the first of the three possible patterns as standard 
                  File$ = OpenFileRequester("Try to load TLB from File", StandardFile$, Pattern$, Pattern) 
                  If File$
                    Err.l = LoadTypeLib_(WideStr(@File$,1),@oTypeLib.ITypeLib)
                    If CheckError(Err,"Can't load TypeLib")
                      Continue
                    EndIf  
                  Else 
                    MessageRequester("Information", "The requester was canceled.", 0) 
                    Continue
                  EndIf 
                EndIf
                Nr.l = oTypeLib\GetTypeInfoCount();
                For I = 0 To Nr-1
                  Err.l = oTypeLib\GetDocumentation(I, @bstrName, @bstrDocString, NULL, NULL)
                  CheckFatalError(Err,"Can't extract Interface from TypeLib")
                  AddGadgetItem(#Gadget_Form1_lbInterfaces,-1,ByteStr(PeekL(@bstrName)))                
                Next               
                
            EndSelect
          Case #Gadget_Form1_lbInterfaces
            Select EventType()
              Case #PB_EventType_LeftDoubleClick
              Default
                Params.s=" a.l,b.l,c.l,d.l,e.l,f.l,g.l,h.l,i.l,j.l,k.l,l.l,m.l,n.l,o.l,p.l,q.l,r.l,s.l,t.l,u.l,v.l,w.l,x.l,y.l,z.l"
                Index.l = GetGadgetState(#Gadget_Form1_lbInterfaces)
                Err.l = oTypeLib\GetTypeInfo(Index, @oCurrentTypeInfo.ITypeInfo);
                CheckFatalError(Err,"Can't get TypeInfo from TypeLib")
                aTypeAttributes.l
                Err.l = oCurrentTypeInfo\GetTypeAttr(@aTypeAttributes)
                CheckFatalError(Err,"Can't get TypeAttributes from TypeInfo")
                *oTypeAttributes.TYPEATTR=aTypeAttributes
                If *oTypeAttributes\typekind=#TKIND_DISPATCH Or *oTypeAttributes\typekind=#TKIND_INTERFACE
                  Err.l = StringFromClsid_(*oTypeAttributes\guid,@IIDwStr)
                  CheckFatalError(Err,"Not a valid IDD")
                  IIDbStr.s=ByteStr(IIDwStr)
                
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"DataSection")
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  IID_"+GetGadgetText(#Gadget_Form1_lbInterfaces)+":")
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  Data.l $"+Mid(IIDbStr,2,8))
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  Data.w $"+Mid(IIDbStr,11,4)+",$"+Mid(IIDbStr,16,4))
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  Data.b $"+Mid(IIDbStr,21,2)+",$"+Mid(IIDbStr,23,2)+",$"+Mid(IIDbStr,26,2)+",$"+Mid(IIDbStr,28,2)+",$"+Mid(IIDbStr,30,2)+",$"+Mid(IIDbStr,32,2)+",$"+Mid(IIDbStr,34,2)+",$"+Mid(IIDbStr,36,2))
                
                                
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"EndDataSection")                
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"")                
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"IID_"+GetGadgetText(#Gadget_Form1_lbInterfaces)+"Str.s="+Chr(34)+IIDbStr+Chr(34))
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"")                
                
                  Nr.l=*oTypeAttributes\cFuncs
                  If GetGadgetState(#Gadget_Form1_opVtable)=1
                    hRefType.l
                    Err.l=oCurrentTypeInfo\GetRefTypeOfImplType(-1,@hRefType)
                    If CheckError(Err,"No custom Vtable interface, choose dispinterface")
                      Continue
                    EndIf  
                    Err.l=oCurrentTypeInfo\GetRefTypeInfo(hRefType,@oCurrentTypeInfo.ITypeInfo)
                    If CheckError(Err,"No custom Vtable interface, choose dispinterface")
                      Continue
                    EndIf  
                    Nr=Nr-7
                    Extends.s=" Extends IDispatch"
                  Else
                    Extends.s=""    
                  EndIf
                  
                  If Nr>0
                    If GetGadgetState(#Gadget_Form1_opEnumEvents)=1
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"Enumeration")                
                    Else
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"Interface "+GetGadgetText(#Gadget_Form1_lbInterfaces)+Extends)                
                    EndIf
                  EndIf

                  For I = 0 To Nr-1
                    Err.l = oCurrentTypeInfo\GetFuncDesc(I, @aFuncDesc.l)
                    CheckFatalError(Err,"Can't Function Description from TypeInfo")
                    *oFuncDesc.FUNCDESC=aFuncDesc
                    MemberID=*oFuncDesc\memid
                    NrOfParams.l=*oFuncDesc\cParams
                    NrOfParamsOpt.l=*oFuncDesc\cParamsOpt
                    InvokeKind.l=*oFuncDesc\invokekind
                    Err.l = oCurrentTypeInfo\GetDocumentation(memberID, @bstrMethod, NULL, NULL, NULL)
                    pTypeInfo.l=oCurrentTypeInfo
                    
                    STRCOMMethod.s=stringCOMMethod(*oFuncDesc, pTypeInfo)
                    
                    PreFix.s=""
                    Select InvokeKind
                      Case #INVOKE_PROPERTYGET
                        PreFix.s="Get_"
                      Case #INVOKE_PROPERTYPUT
                        PreFix.s="Put_"
                      Case #INVOKE_PROPERTYPUTREF
                        PreFix.s="Put_"
                    EndSelect
                    If GetGadgetState(#Gadget_Form1_opEnumEvents)=1
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  #On_"+ByteStr(bstrMethod)+" = "+Str(MemberID)+"   ; "+STRCOMMethod) 
                    Else
                      Err.l = oCurrentTypeInfo\GetDocumentation(memberID, @bstrMethod, NULL, NULL, NULL)
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  "+Prefix+ByteStr(bstrMethod)+"("+Mid(Left(Params,NrOfParams*4),2,100)+")"+"   ; "+STRCOMMethod) 
                    EndIf                 
                  Next
                  If Nr>0
                    If GetGadgetState(#Gadget_Form1_opEnumEvents)=1
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"EndEnumeration")                
                    Else  
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"EndInterface")                
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"")                
                    EndIf  
                  EndIf
                  CharLen.l=0
                  For i=0 To CountGadgetItems(#Gadget_Form1_lbIncludeFile)-1
                    TmpCharLen.l=Len(GetGadgetItemText(#Gadget_Form1_lbIncludeFile, i,0))
                    If TmpCharLen > CharLen
                      CharLen=TmpCharLen
                    EndIf
                  Next
                  Err.l=GetTextMetrics_(GetDC_(GadgetID(#Gadget_Form1_lbIncludeFile)),@tm.TEXTMETRIC)
                  PixLen.l=CharLen*tm\tmAveCharWidth
                  Err.l=SendMessage_( GadgetID(#Gadget_Form1_lbIncludeFile), #LB_SETHORIZONTALEXTENT, PixLen, 0)
                Else
                  MessageRequester("Information","Only (Dispatch)-Interfaces contribute to the Include File",0)
                EndIf  
            EndSelect
           Case #Gadget_Form1_lbIncludeFile
            Select EventType()
              Case #PB_EventType_LeftDoubleClick
              Default
            EndSelect
        EndSelect

    EndSelect
  Until quitForm1
  CloseWindow(#Window_Form1)
EndIf
End

Try it again

Leo

[Leo]

I added some code that will ask for the file that contains the typelibrary (*.tlb; *.olb, *.dll, *.exe; *.ocx) if the type library is not registered. In that case you have to know the file name.

Code: Select all

;-Init Includes
XIncludeFile "Controls_Constants.pb"
XIncludeFile "Controls_Windows.pb"

Enumeration
  #INVOKE_FUNC             = 1
  #INVOKE_PROPERTYGET      = 2
  #INVOKE_PROPERTYPUT      = 4
  #INVOKE_PROPERTYPUTREF   = 8
EndEnumeration 

Enumeration 
  #USERCLASSTYPE_FULL       = 1 
  #USERCLASSTYPE_SHORT  
  #USERCLASSTYPE_APPNAME 
EndEnumeration 

Enumeration
  #TKIND_ENUM  
  #TKIND_RECORD 
  #TKIND_MODULE 
  #TKIND_INTERFACE 
  #TKIND_DISPATCH
  #TKIND_COCLASS
  #TKIND_ALIAS
  #TKIND_UNION
  #TKIND_MAX  
EndEnumeration 

Enumeration
  #FUNC_VIRTUAL    = 0
  #FUNC_PUREVIRTUAL= #FUNC_VIRTUAL + 1
  #FUNC_NONVIRTUAL = #FUNC_PUREVIRTUAL + 1
  #FUNC_STATIC     = #FUNC_NONVIRTUAL + 1
  #FUNC_DISPATCH   = #FUNC_STATIC + 1
EndEnumeration 

Enumeration
  #VAR_PERINSTANCE = 0
  #VAR_STATIC      = #VAR_PERINSTANCE + 1
  #VAR_CONST       = #VAR_STATIC + 1
  #VAR_DISPATCH    = #VAR_CONST + 1
EndEnumeration  

Enumeration
  #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_FILETIME     = 64
  #VT_BLOB         = 65
  #VT_STREAM       = 66
  #VT_STORAGE      = 67 
  #VT_STREAMED_OBJECT      = 68
  #VT_STORED_OBJECT        = 69
  #VT_BLOB_OBJECT  = 70
  #VT_CF           = 71
  #VT_CLSID        = 72
  #VT_BSTR_BLOB    = $fff
  #VT_VECTOR       = $1000
  #VT_ARRAY        = $2000
  #VT_BYREF        = $4000
  #VT_RESERVED     = $8000
  #VT_ILLEGAL      = $ffff
  #VT_ILLEGALMASKED= $fff
  #VT_TYPEMASK     = $fff
EndEnumeration                

Enumeration
  #PARAMFLAG_NONE = $00
  #PARAMFLAG_FIN = $01
  #PARAMFLAG_FOUT = $02
  #PARAMFLAG_FLCID = $04
  #PARAMFLAG_FRETVAL = $08
  #PARAMFLAG_FOPT = $10
  #PARAMFLAG_FHASDEFAULT = $20
  #PARAMFLAG_FHASCUSTDATA = $40
EndEnumeration                

Structure VARIANTARG
  vt.w
  dummy1.w
  dummy2.w
  dummy3.w
  union.l
EndStructure

Structure PARAMDESC
  pparamdescex.l
  wParamFlags.w
EndStructure  

Structure PARAMDESCEX
  cBytes.l
  dummy.l   ; Deze dummy begrijp ik niet
  varDefaultValue.VARIANTARG
EndStructure

Structure TYPEDESC
  union.l
  vt.w
EndStructure

Structure ELEMDESC 
  tdesc.TYPEDESC
  dummy.w
  paramdesc.PARAMDESC
  dummy.w
EndStructure

Structure FUNCDESC
  memid.l
  scode.l
  *lprgelemdescParam.ELEMDESC
  funckind.l
  invokekind.l
  callconv.l
  cParams.w 
  cParamsOpt.w 
  oVft.w 
  cScodes.w 
  *elemdescFunc.ELEMDESC
  wFuncFlags.w
EndStructure

Structure TYPEATTR
  guid.GUID
  lcid.l
  dwReserved.l
  memidConstructor.l
  memidDestructor.l
  lpstrSchema.l
  cbSizeInstance.l
  typekind.l
  cFuncs.w
  cVars.w
  cImplTypes.w
  cbSizeVft.w
  cbAlignment.w
  wTypeFlags.w
  wMajorVerNum.w
  wMinorVerNum.w
  tdescAlias.l
  idldescType.l
EndStructure

Structure VARDESC
  memid.l
  lpstrSchema.l
  union.l
  *elemdescVar.ELEMDESC
  wVarFlags.w
  varkind.w
EndStructure  

Procedure.s HexString(Source.l, l.l) 
    result.s
    
    result.s = ""
    For i = 0 To l
        result = result + Right("00" + Hex(PeekB(PeekL(Source)+i)), 2) + " "
    Next i
    
    ProcedureReturn result
EndProcedure


Procedure.s ByteStr(pointer.l) 
  strlen.w = WideCharToMultiByte_(#CP_ACP, 0, pointer, -1, 0, 0 , 0, 0) 
  string.s = Space(strlen) 
  If strlen <> 0 
    newlen.w = WideCharToMultiByte_(#CP_ACP, 0, pointer, -1, @string, strlen , 0, 0) 
  EndIf 
  ProcedureReturn string 
EndProcedure

Procedure.l WideStr(pointer.l, mem.l) 
  widelen.w = 2*Len(PeekS(pointer))+2 
  widebuf.l = AllocateMemory(mem, widelen) 
  longlen.w = MultiByteToWideChar_(#CP_ACP,0,pointer,-1,widebuf,widelen) 
  ProcedureReturn widebuf 
EndProcedure 

Procedure CheckFatalError(Err.l, ErrTxt.s)
  If Err <> 0
    MessageRequester("Fatal Error",ErrTxt+", Error : "+Hex(Err) ,0)
    End
  EndIf
EndProcedure
  
Procedure.l CheckError(Err.l, ErrTxt.s)
  If Err <> 0
    MessageRequester("Information",ErrTxt+", Error : "+Hex(Err) ,0)
    ProcedureReturn 1
  EndIf
  ProcedureReturn 0
EndProcedure  

Procedure.s stringCustomType(RefType.l, pTypeInfo.l)
  *TypeInfo.ITypeInfo=pTypeInfo
  
  If *TypeInfo\GetRefTypeInfo(RefType, @CustTypeInfo.ITypeInfo)=0
    If CustTypeInfo\GetDocumentation(-1, @bstrType, 0, 0, 0)=0
      ProcedureReturn ByteStr(bstrType)
    Else
      ProcedureReturn "UnknownCustomType"
    EndIf
  Else
    ProcedureReturn "UnknownCustomType"
  EndIf  
  ProcedureReturn "UnknownCustomType"
EndProcedure

Procedure.s stringTypeDesc(pTypeDesc.l, pTypeInfo.l)
  *TypeDesc.TYPEDESC=pTypeDesc
  *TypeInfo.ITypeInfo=pTypeInfo
  If *TypeDesc\vt = #VT_PTR
    ProcedureReturn stringTypeDesc(*TypeDesc\union, pTypeInfo)+"*"
  EndIf  
  If *TypeDesc\vt = #VT_SAFEARRAY
    ProcedureReturn "SAFEARRAY("+stringTypeDesc(*TypeDesc\union, pTypeInfo)+")"
  EndIf  
;  If pTypeDesc\vt = #VT_CARRAY
;    CArray.s=stringTypeDesc(@*TypeDesc\lpadesc\tdescElem, @*TypeInfo)
;  EndIf  
;  If pTypeDesc\vt = #VT_USERDEFINED
;    CArray.s=stringTypeDesc(@*TypeDesc\lpadesc\tdescElem, @*TypeInfo)
;  EndIf  
;    If(typeDesc->vt == VT_CARRAY) {
;        oss<< stringifyTypeDesc(&typeDesc->lpadesc->tdescElem, pTypeInfo);
;        for(int dim(0); typeDesc->lpadesc->cDims; ++dim) 
;            oss<< '['<< typeDesc->lpadesc->rgbounds[dim].lLbound<< "..."
;                << (typeDesc->lpadesc->rgbounds[dim].cElements + 
;                typeDesc->lpadesc->rgbounds[dim].lLbound - 1)<< ']';
;        return oss.str();
;    }
  If *TypeDesc\vt = #VT_USERDEFINED
    ProcedureReturn stringCustomType(*TypeDesc\union, pTypeInfo)
  EndIf
  Vt.l=*TypeDesc\vt
  Select Vt.l
    Case #VT_I2: ProcedureReturn "short";
    Case #VT_I4: ProcedureReturn "long";
    Case #VT_R4: ProcedureReturn "float";
    Case #VT_R8: ProcedureReturn "double";
    Case #VT_CY: ProcedureReturn "CY";
    Case #VT_DATE: ProcedureReturn "DATE";
    Case #VT_BSTR: ProcedureReturn "BSTR";
    Case #VT_DISPATCH: ProcedureReturn "IDispatch*";
    Case #VT_ERROR: ProcedureReturn "SCODE";
    Case #VT_BOOL: ProcedureReturn "VARIANT_BOOL";
    Case #VT_VARIANT: ProcedureReturn "VARIANT";
    Case #VT_UNKNOWN: ProcedureReturn "IUnknown*";
    Case #VT_UI1: ProcedureReturn "BYTE";
    Case #VT_DECIMAL: ProcedureReturn "DECIMAL";
    Case #VT_I1: ProcedureReturn "char";
    Case #VT_UI2: ProcedureReturn "USHORT";
    Case #VT_UI4: ProcedureReturn "ULONG";
    Case #VT_I8: ProcedureReturn "__int64";
    Case #VT_UI8: ProcedureReturn "unsigned __int64";
    Case #VT_INT: ProcedureReturn "int";
    Case #VT_UINT: ProcedureReturn "UINT";
    Case #VT_HRESULT: ProcedureReturn "HRESULT";
    Case #VT_VOID: ProcedureReturn "void"
    Case #VT_LPSTR: ProcedureReturn "char*";
    Case #VT_LPWSTR: ProcedureReturn "wchar_t*";
  EndSelect
  ProcedureReturn "BIG ERROR!";
EndProcedure

Procedure.s stringVarDesc(pVarDesc.l, pTypeInfo.l)
  *VarDesc.VARDESC=pVarDesc
  *TypeInfo.ITYPEINFO=pTypeInfo
  bstrName.s
  If *VarDesc\varkind = #VAR_CONST
    RetStr.s="const "+stringTypeDesc(@*VarDesc\elemdescVar\tdesc, @*TypeInfo)
    If *TypeInfo\GetDocumentation(*VarDesc\memid, @bstrName ,0, 0, 0)
      RetStr=RetStr+" "+ByteStr(@bstrName)+" = "
      If VariantChangeType_( @Variant, *VarDesc\union,0,#VT_BSTR)
        RetStr=RetStr+"???"
      Else
        RetStr=RetStr+ByteStr(@Variant)
      EndIf   
    Else
      RetStr="UnknownName"
    EndIf
  EndIf
  ProcedureReturn RetStr    
EndProcedure

Procedure.s stringParameterAttributes(pParamDesc.l) 
  *ParamDesc.PARAMDESC=pParamDesc
  paramFlags.w = *ParamDesc\wParamFlags
  
  numFlags.l=0
  bit.l=1
  While bit < #PARAMFLAG_FHASDEFAULT
    If paramFlags & bit
      numFlags=numFlags+1
    EndIf
    bit=bit*2
  Wend
  If numFlags=0
    ProcedureReturn ""
  EndIf
  RetStr.s="["
  If paramFlags & #PARAMFLAG_FIN
    RetStr=RetStr+"in, "
  EndIf 
  If paramFlags & #PARAMFLAG_FOUT
    RetStr=RetStr+"out, "
  EndIf 
  If paramFlags & #PARAMFLAG_FLCID
    RetStr=RetStr+"lcid, "
  EndIf 
  If paramFlags & #PARAMFLAG_FRETVAL
    RetStr=RetStr+"retval, "
  EndIf 
  If paramFlags & #PARAMFLAG_FOPT
    RetStr=RetStr+"optional, "
  EndIf 
  If paramFlags & #PARAMFLAG_FHASDEFAULT
    RetStr=RetStr+"defaultvalue="
    If *ParamDesc\pparamdescex
      *ParamDescEx.PARAMDESCEX=*ParamDesc\pparamdescex
      *varDefaultValue.VARIANTARG=*ParamDescEx\varDefaultValue
      
      If VariantChangeType_(@Variant.VARIANTARG,*varDefaultValue,0,#VT_BSTR)=0
        If *varDefaultValue\vt = #VT_BSTR
          RetStr=RetStr+Chr(34)
        EndIf
        RetStr=RetStr+ByteStr(Variant\union)
        If *varDefaultValue\vt = #VT_BSTR
          RetStr=RetStr+Chr(34)
        EndIf  
      Else
        RetStr=RetStr+"???"
      EndIf
    EndIf
  EndIf 
    If Right(RetStr,2)=", "
      RetStr=Left(RetStr, Len(RetStr)-2)
    EndIf
    RetStr=RetStr+"]"
  ProcedureReturn RetStr
EndProcedure  

Procedure.s stringFunctionArgument(pElemDesc.l, pTypeInfo.l)
    *ElemDesc.ELEMDESC=pElemDesc
    *TypeInfo.ITypeInfo=pTypeInfo
    pParamDesc.l=@*ElemDesc\paramdesc
    RetStr.s=stringParameterAttributes(pParamDesc)
    If Len(RetStr)>0
      RetStr=RetStr+" "      
    EndIf
    pTypeDesc.l=@*ElemDesc\tdesc
    RetStr=RetStr+stringTypeDesc(pTypeDesc.l, pTypeInfo)
  ProcedureReturn RetStr
EndProcedure  

Procedure.s stringCOMMethod(pFuncDesc.l, pTypeInfo.l)
  *FuncDesc.FUNCDESC=pFuncDesc
  *TypeInfo.ITypeInfo=pTypeInfo  
  If *FuncDesc\funckind = #FUNC_DISPATCH    
    RetStr.s="[id($"+Hex(*FuncDesc\memid)+")"
  Else 
    RetStr.s="[VOffset($"+Hex(*FuncDesc\oVft)+")"
  EndIf  
  Select *FuncDesc\invokekind
    Case #INVOKE_PROPERTYGET
      RetStr=RetStr+", propget] "
    Case #INVOKE_PROPERTYPUT
      RetStr=RetStr+", propput] "
    Case #INVOKE_PROPERTYPUTREF
      RetStr=RetStr+", propputref] "
    Case #INVOKE_FUNC
      RetStr=RetStr+"] "
  EndSelect
  RetStr=RetStr+stringTypeDesc(@*FuncDesc\elemdescFunc, pTypeInfo)
  MemberID.l=*FuncDesc\memid
  Err.l=*TypeInfo\GetDocumentation(MemberID, @bstrName, NULL, NULL, NULL)
  RetStr=RetStr+" "+ByteStr(bstrName)+"("
  RetNr.l
  ParNames.s=Space(1000)
  Nr.l=*FuncDesc\cParams
  Err.l=*TypeInfo\GetNames(MemberID,@ParNames,Nr.l+1, @RetNr)
  If *FuncDesc\cParams > 0
    pTemp.l=*FuncDesc\lprgelemdescParam
  EndIf  
  pElemDescParam.l=pTemp
  For i=0 To *FuncDesc\cParams-1
    If i>0
      RetStr=RetStr+", "
    EndIf
    RetStr=RetStr+stringFunctionArgument(pElemDescParam, pTypeInfo)
    RetStr=RetStr+" "+ByteStr(PeekL(@ParNames+((i+1)*4)))
    pElemDescParam=pElemDescParam+SizeOf(ELEMDESC)
  Next
  RetStr=RetStr+")"
  ProcedureReturn RetStr
EndProcedure  
  
DataSection 
  CATID_Control:  ;  CATID_Control, 0x40fc6ed4, 0x2438, 0x11cf, 0xa3, 0xdb, 0x08, 0x00, 0x36, 0xf1, 0x25, 0x02)
    Data.l $40FC6ED4 
    Data.w $2438,$11CF 
    Data.b $A3, $DB, $08,$00,$36,$F1,$25,$02

  CLSID_StdComponentCategoriesMgr:  ;  {0002E005-0000-0000-C000-000000000046}
    Data.l $0002E005 
    Data.w $0000,$0000 
    Data.b $C0, $00, $00,$00,$00,$00,$00,$46

  IID_ICatInformation:  ;  {0002E013-0000-0000-C000-000000000046}
    Data.l $0002E013 
    Data.w $0000,$0000 
    Data.b $C0, $00, $00,$00,$00,$00,$00,$46
    
  IID_Custom:   ; {0F21F359-AB84-41E8-9A78-36D110E6D2F9}  
    Data.l $0F21F359 
    Data.w $AB84,$41E8 
    Data.b $9A, $78, $36,$D1,$10,$E6,$D2,$F9
EndDataSection






;-Main Loop
If Window_Form1()

  SetGadgetState(#Gadget_Form1_opVtable,1)
  
  CoInitialize_(NULL)
  Err.l = CoCreateInstance_(?CLSID_StdComponentCategoriesMgr,0,1,?IID_ICatInformation,@oCatInfo.ICatInformation) 
  CheckFatalError(Err,"Can't Create Component Categories Manager")
  Err.l=oCatInfo\AddRef()
  Err.l=oCatInfo\EnumClassesOfCategories(1,?CATID_Control,0,@CatIdReg,@oEnumGUID.IEnumGUID);
  CheckFatalError(Err,"Can't Enumerate Classes of Categories")

  Clsid.GUID

  While  oEnumGUID\Next( 1, @Clsid, NULL )=0
    OleRegGetUserType_(@Clsid,#USERCLASSTYPE_FULL,@ClassName)
    StringFromClsid_(@Clsid,@ClsidWStr)
    SendMessage_( GadgetID(#Gadget_Form1_lbClassName), #LB_ADDSTRING, 0, ByteStr(ClassName)+Space(80)+ByteStr(ClsidWStr))
  Wend
  RemoveGadgetItem(#Gadget_Form1_lbClassName,0)

  Err.l=oCatInfo\Release()
  CoUninitialize_()

  quitForm1=0
  Repeat
    EventID=WaitWindowEvent()
    Select EventID
      Case #PB_Event_CloseWindow
        If EventWindowID()=#Window_Form1
          quitForm1=1
        EndIf
      Case #PB_Event_Gadget
        Select EventGadgetID()
          Case #Gadget_Form1_btSaveFile
            StandardFile$ = "C:\Programmeren\PureBasic\temp.pb"   ; set initial file+path to display 
            Pattern$ = "PureBasic (*.pb)|*.pb|All files (*.*)|*.*" 
            Pattern = 0    ; use the first of the three possible patterns as standard 
            File$ = SaveFileRequester("Please choose file to save", StandardFile$, Pattern$, Pattern) 
            If File$
              If Pattern=0 And FindString(File$,".",1) = 0
                File$=File$+".pb"
              EndIf
              If OpenFile(#1,File$)
                For I=1 To CountGadgetItems(#Gadget_Form1_lbIncludeFile)
                  WriteStringN(GetGadgetItemText(#Gadget_Form1_lbIncludeFile, I-1,0))            
                Next
                CloseFile(1)
              EndIf  
            Else 
              MessageRequester("Information", "The requester was canceled.", 0) 
            EndIf 

          Case #Gadget_Form1_lbClassName
            Select EventType()
              Case #PB_EventType_LeftDoubleClick
              Default
                ClearGadgetItemList(#Gadget_Form1_lbInterfaces)
                ClearGadgetItemList(#Gadget_Form1_lbIncludeFile)
                Err.l=SendMessage_( GadgetID(#Gadget_Form1_lbIncludeFile), #LB_SETHORIZONTALEXTENT, 0, 0)
                ClsidStr.s = GetGadgetText(#Gadget_Form1_lbClassName)
                Pos.l = FindString(ClsidStr,"{",1)
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"DataSection")
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  CLSID_"+StringField(Left(ClsidStr,Pos-1),1," ")+":")
                CtrlStr.s="ProgID_"+StringField(Left(ClsidStr,Pos-1),1," ")+".s="
                ClsidStr=Mid(ClsidStr,Pos,100)
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  Data.l $"+Mid(ClsidStr,2,8))
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  Data.w $"+Mid(ClsidStr,11,4)+",$"+Mid(ClsidStr,16,4))
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  Data.b $"+Mid(ClsidStr,21,2)+",$"+Mid(ClsidStr,23,2)+",$"+Mid(ClsidStr,26,2)+",$"+Mid(ClsidStr,28,2)+",$"+Mid(ClsidStr,30,2)+",$"+Mid(ClsidStr,32,2)+",$"+Mid(ClsidStr,34,2)+",$"+Mid(ClsidStr,36,2))
                
                                
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"EndDataSection")                
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"")
                Err.l=CLSIDFromString_(WideStr(@ClsidStr,1),@Clsid.GUID)
                ProgID.l 
                Err.l=ProgIDFromCLSID_(@Clsid,@ProgID)
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,CtrlStr+Chr(34)+ByteStr(ProgID)+Chr(34)) 
                AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"") 
                               
                NoRegTLB=0
                Err.l = RegOpenKeyEx_(#HKEY_CLASSES_ROOT,"CLSID\"+ClsidStr+"\TypeLib",0,#KEY_READ,@hTypeLib.l)
                If CheckError(Err,"Control doesn't have a Typelib")
                  NoRegTLB=1
                Else
                  TLBClsidStr.s=Space(100)
                  dwSizeOfDataBlock.l=100
                  RegQueryValue_(hTypeLib,NULL,@TLBClsidStr,@dwSizeOfDataBlock)
                
                  tchVersionInformation.s=Space(100)
                  Err.l=RegOpenKeyEx_(#HKEY_CLASSES_ROOT,"TypeLib\"+TLBClsidStr,0,KEY_READ, @hKeyClassTLB.l)
                  If CheckError(Err,"Typelib not registered")
                    NoRegTLB=1
                  Else  
                    dwCLSIDSubKeyIndex.l = 0
                    While RegEnumKey_(hKeyClassTLB,dwCLSIDSubKeyIndex ,@tchVersionInformation,20) =0
                      If RegOpenKeyEx_(hKeyClassTLB,@tchVersionInformation,0,KEY_READ,@hKeyVersion.l) =0    
                      EndIf
                      dwCLSIDSubKeyIndex=dwCLSIDSubKeyIndex+1
                    Wend
                    clsidTypeLib.GUID
                    A$ = Space((Len(TLBClsidStr)+1)*2)
                    MultiByteToWideChar_(#CP_ACP,0,TLBClsidStr,-1,@A$,Len(A$))
                    Err.l = CLSIDFromString_(A$,clsidTypeLib)
                    If CheckFatalError(Err,"Not a valid ClassId")
                      Continue
                    EndIf  
                    Major.l=Val(tchVersionInformation)
                    Pos.l = FindString(tchVersionInformation,".",1)
                    tchVersionInformation.s=Mid(tchVersionInformation,Pos+1,100)
                    Minor.l=Val(tchVersionInformation)
                
                    Err.l = LoadRegTypeLib_(clsidTypeLib,Major,Minor,0, @oTypeLib.ITypeLib)
                    If CheckError(Err,"Can't load registered TypeLib")
                      NoRegTLB=1
                    EndIf
                  EndIf    
                EndIf
                If NoRegTLB=1
                  StandardFile$ = "C:\test.dll"   ; set initial file+path to display 
                  Pattern$ = "TypeLib (*.tlb;*.olb;*.dll;*.exe;*.ocx)|*.tlb;*.olb;*.dll;*.exe;*.ocx|All files (*.*)|*.*" 
                  Pattern = 0    ; use the first of the three possible patterns as standard 
                  File$ = OpenFileRequester("Try to load TLB from File", StandardFile$, Pattern$, Pattern) 
                  If File$
                    Err.l = LoadTypeLib_(WideStr(@File$,1),@oTypeLib.ITypeLib)
                    If CheckError(Err,"Can't load TypeLib")
                      Continue
                    EndIf  
                  Else 
                    MessageRequester("Information", "The requester was canceled.", 0) 
                    Continue
                  EndIf 
                EndIf
                Nr.l = oTypeLib\GetTypeInfoCount();
                For I = 0 To Nr-1
                  Err.l = oTypeLib\GetDocumentation(I, @bstrName, @bstrDocString, NULL, NULL)
                  CheckFatalError(Err,"Can't extract Interface from TypeLib")
                  AddGadgetItem(#Gadget_Form1_lbInterfaces,-1,ByteStr(PeekL(@bstrName)))                
                Next               
                
            EndSelect
          Case #Gadget_Form1_lbInterfaces
            Select EventType()
              Case #PB_EventType_LeftDoubleClick
              Default
                Params.s=" a.l,b.l,c.l,d.l,e.l,f.l,g.l,h.l,i.l,j.l,k.l,l.l,m.l,n.l,o.l,p.l,q.l,r.l,s.l,t.l,u.l,v.l,w.l,x.l,y.l,z.l"
                Index.l = GetGadgetState(#Gadget_Form1_lbInterfaces)
                Err.l = oTypeLib\GetTypeInfo(Index, @oCurrentTypeInfo.ITypeInfo);
                CheckFatalError(Err,"Can't get TypeInfo from TypeLib")
                aTypeAttributes.l
                Err.l = oCurrentTypeInfo\GetTypeAttr(@aTypeAttributes)
                CheckFatalError(Err,"Can't get TypeAttributes from TypeInfo")
                *oTypeAttributes.TYPEATTR=aTypeAttributes
                If *oTypeAttributes\typekind=#TKIND_DISPATCH Or *oTypeAttributes\typekind=#TKIND_INTERFACE
                  Err.l = StringFromClsid_(*oTypeAttributes\guid,@IIDwStr)
                  CheckFatalError(Err,"Not a valid IDD")
                  IIDbStr.s=ByteStr(IIDwStr)
                
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"DataSection")
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  IID_"+GetGadgetText(#Gadget_Form1_lbInterfaces)+":")
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  Data.l $"+Mid(IIDbStr,2,8))
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  Data.w $"+Mid(IIDbStr,11,4)+",$"+Mid(IIDbStr,16,4))
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  Data.b $"+Mid(IIDbStr,21,2)+",$"+Mid(IIDbStr,23,2)+",$"+Mid(IIDbStr,26,2)+",$"+Mid(IIDbStr,28,2)+",$"+Mid(IIDbStr,30,2)+",$"+Mid(IIDbStr,32,2)+",$"+Mid(IIDbStr,34,2)+",$"+Mid(IIDbStr,36,2))
                
                                
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"EndDataSection")                
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"")                
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"IID_"+GetGadgetText(#Gadget_Form1_lbInterfaces)+"Str.s="+Chr(34)+IIDbStr+Chr(34))
                  AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"")                
                
                  Nr.l=*oTypeAttributes\cFuncs
                  If GetGadgetState(#Gadget_Form1_opVtable)=1
                    hRefType.l
                    Err.l=oCurrentTypeInfo\GetRefTypeOfImplType(-1,@hRefType)
                    If CheckError(Err,"No custom Vtable interface, choose dispinterface")
                      Continue
                    EndIf  
                    Err.l=oCurrentTypeInfo\GetRefTypeInfo(hRefType,@oCurrentTypeInfo.ITypeInfo)
                    If CheckError(Err,"No custom Vtable interface, choose dispinterface")
                      Continue
                    EndIf  
                    Nr=Nr-7
                    Extends.s=" Extends IDispatch"
                  Else
                    Extends.s=""    
                  EndIf
                  
                  If Nr>0
                    If GetGadgetState(#Gadget_Form1_opEnumEvents)=1
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"Enumeration")                
                    Else
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"Interface "+GetGadgetText(#Gadget_Form1_lbInterfaces)+Extends)                
                    EndIf
                  EndIf

                  For I = 0 To Nr-1
                    Err.l = oCurrentTypeInfo\GetFuncDesc(I, @aFuncDesc.l)
                    CheckFatalError(Err,"Can't Function Description from TypeInfo")
                    *oFuncDesc.FUNCDESC=aFuncDesc
                    MemberID=*oFuncDesc\memid
                    NrOfParams.l=*oFuncDesc\cParams
                    NrOfParamsOpt.l=*oFuncDesc\cParamsOpt
                    InvokeKind.l=*oFuncDesc\invokekind
                    Err.l = oCurrentTypeInfo\GetDocumentation(memberID, @bstrMethod, NULL, NULL, NULL)
                    pTypeInfo.l=oCurrentTypeInfo
                    
                    STRCOMMethod.s=stringCOMMethod(*oFuncDesc, pTypeInfo)
                    
                    PreFix.s=""
                    Select InvokeKind
                      Case #INVOKE_PROPERTYGET
                        PreFix.s="Get_"
                      Case #INVOKE_PROPERTYPUT
                        PreFix.s="Put_"
                      Case #INVOKE_PROPERTYPUTREF
                        PreFix.s="Put_"
                    EndSelect
                    If GetGadgetState(#Gadget_Form1_opEnumEvents)=1
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  #On_"+ByteStr(bstrMethod)+" = "+Str(MemberID)+"   ; "+STRCOMMethod) 
                    Else
                      Err.l = oCurrentTypeInfo\GetDocumentation(memberID, @bstrMethod, NULL, NULL, NULL)
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"  "+Prefix+ByteStr(bstrMethod)+"("+Mid(Left(Params,NrOfParams*4),2,100)+")"+"   ; "+STRCOMMethod) 
                    EndIf                 
                  Next
                  If Nr>0
                    If GetGadgetState(#Gadget_Form1_opEnumEvents)=1
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"EndEnumeration")                
                    Else  
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"EndInterface")                
                      AddGadgetItem(#Gadget_Form1_lbIncludeFile,-1,"")                
                    EndIf  
                  EndIf
                  CharLen.l=0
                  For i=0 To CountGadgetItems(#Gadget_Form1_lbIncludeFile)-1
                    TmpCharLen.l=Len(GetGadgetItemText(#Gadget_Form1_lbIncludeFile, i,0))
                    If TmpCharLen > CharLen
                      CharLen=TmpCharLen
                    EndIf
                  Next
                  Err.l=GetTextMetrics_(GetDC_(GadgetID(#Gadget_Form1_lbIncludeFile)),@tm.TEXTMETRIC)
                  PixLen.l=CharLen*tm\tmAveCharWidth
                  Err.l=SendMessage_( GadgetID(#Gadget_Form1_lbIncludeFile), #LB_SETHORIZONTALEXTENT, PixLen, 0)
                Else
                  MessageRequester("Information","Only (Dispatch)-Interfaces contribute to the Include File",0)
                EndIf  
            EndSelect
           Case #Gadget_Form1_lbIncludeFile
            Select EventType()
              Case #PB_EventType_LeftDoubleClick
              Default
            EndSelect
        EndSelect

    EndSelect
  Until quitForm1
  CloseWindow(#Window_Form1)
EndIf
End

Try it again

Leo