INSIDE ACTIVEX WITH FREEBASIC

aloberoger · Post by **aloberoger** » Apr 12, 2015 18:26

you must create a .tlb I think to work, if not how the dll can be loaded
If the dll is not registred it is necessary to load it and use one exported function to work
If you provide a .tlb imbeded in the dll, you need to createobject to work
perhaps you can use the plugin technic to work

VANYA · Post by **VANYA** » Apr 13, 2015 4:06

aloberoger wrote:you must create a .tlb I think to work, if not how the dll can be loaded
If the dll is not registred it is necessary to load it and use one exported function to work
If you provide a .tlb imbeded in the dll, you need to createobject to work
perhaps you can use the plugin technic to work

Thank you. Something is wrong in the initializations freebasic when you work with dll...

aloberoger · Post by **aloberoger** » May 21, 2015 11:21

Here is an example of calculation of a COM component with two interfaces and two coclasses
instead of the multiple heritage we uses containment.
it is simpler to use the method of the virtual classes, but ...
Useless to seek to compile with the headers provided by FB, perhaps - it would be worth to adopt the Vtbl method which is more complex in this case.
since there you can test the dll provided to you.

The remarks that I wanted to make are:
in the headers if defined __ cplusplus - it is significant? , I don't think so,
other I had to compile this DLL with the old versions (and the headers modified) the size was of 110 KB
now it is of 44 KB

I had noticed that there was a light increase, it is true of the size of the DLL implemented with the virtual classes compared to the Vtbl method
That was due to the use of the operator new.
in this precise case it I use the new operator, did this operator has been modified in the compiler?

in my opinion #if defined(__cplusplus) and Not Defined(CINTERFACE) is not usefull than
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")

because the first one don't provide a default behaviour
the second provide a default behaviour since __FB_VERSION__ >= "0.90"
http://www.2shared.com/file/_7poJigi/Co ... c__FB.html

VANYA · Post by **VANYA** » May 23, 2015 5:27

Hi aloberoger!

Could you throw off your headers (the whole folder Inc. compiler)? I have neither your example does not compile (a bunch of errors).

aloberoger · Post by **aloberoger** » May 23, 2015 10:59

Just the headers necessary to compile the example
http://www.2shared.com/file/tJCfj6JH/New_headers.html

VANYA · Post by **VANYA** » May 23, 2015 11:41

aloberoger wrote:Just the headers necessary to compile the example
http://www.2shared.com/file/tJCfj6JH/New_headers.html

Thanks, but nothing happens. I win32, can in this case ...

C:\Compilier\fbc -s console "FbTemp.bas"
C:\Compilier\inc\win\oaidl.bi(214) error 14: Expected identifier, found 'VARIANT' in 'pvarVal as VARIANT ptr'
C:\Compilier\inc\win\oaidl.bi(352) error 70: Incomplete type in 'varDefaultValue as VARIANTARG'
C:\Compilier\inc\win\oaidl.bi(523) error 14: Expected identifier, found 'VARIANT' in 'lpvarValue as VARIANT ptr'
C:\Compilier\inc\win\oaidl.bi(603) error 70: Incomplete type in 'varValue as VARIANTARG'
C:\Compilier\inc\win\oaidl.bi(624) error 221: Method declared ABSTRACT, but UDT does not extend OBJECT, found 'abstract' in 'Declare abstract Function SetGuid( byval guid as const GUID const Ptr) as HRESULT'
C:\Compilier\inc\win\oaidl.bi(625) error 221: Method declared ABSTRACT, but UDT does not extend OBJECT, found 'abstract' in 'Declare abstract Function SetTypeFlags( byval uTypeFlags as UINT) as HRESULT'
C:\Compilier\inc\win\oaidl.bi(626) error 221: Method declared ABSTRACT, but UDT does not extend OBJECT, found 'abstract' in 'Declare abstract Function SetDocString( byval pStrDoc as LPOLESTR) as HRESULT'
C:\Compilier\inc\win\oaidl.bi(627) error 221: Method declared ABSTRACT, but UDT does not extend OBJECT, found 'abstract' in 'Declare abstract Function SetHelpContext( byval dwHelpContext as DWORD) as HRESULT'
C:\Compilier\inc\win\oaidl.bi(628) error 221: Method declared ABSTRACT, but UDT does not extend OBJECT, found 'abstract' in 'Declare abstract Function SetVersion( byval wMajorVerNum as WORD, ByVal wMinorVerNum as WORD) as HRESULT'
C:\Compilier\inc\win\oaidl.bi(629) error 221: Method declared ABSTRACT, but UDT does not extend OBJECT, found 'abstract' in 'Declare abstract Function AddRefTypeInfo( byval pTInfo as ITypeInfo ptr, ByVal phRefType as HREFTYPE ptr) as HRESULT'
C:\Compilier\inc\win\oaidl.bi(629) error 132: Too many errors, exiting

Okay , I will be very slowly learn to work with COM.

aloberoger · Post by **aloberoger** » May 23, 2015 18:10

However that is enough for creating the DLL, you can temporarily store the old headers, and quite simply replace these headers by the new ones
before compiling.
you will be able if you want to replace old the file at the proper time.

you need #Define __ cplusplus at the beginning of the main file.

I used the not registred version, though the recorded version can function with FB, but not with VB because the .tlb would be necessary
That should compile, if someone else the same difficulty I would be obliged to post the whole of my files.

aloberoger · Post by **aloberoger** » Jun 08, 2015 18:54

truelly first .ocx with Freebasic
this project is not complete but work and can be displayed by vb brosher or Delphi
http://www.2shared.com/file/P3rkx8ef/fb ... poste.html

with vb the ocx are displayed via add components not via add references
with delphi ocx are displayed via import activex not via import typelibrary

aloberoger · Post by **aloberoger** » Jun 09, 2015 9:35

Similation of multiple inheritance
aggr.bas

Code: Select all

#Include Once "windows.bi"
#include Once "win/unknwn.bi"
#Include Once "win/ocidl.bi"
#Include Once "crt.bi"

#Include "win/initguid.bi"

' {211FE1E1-FA21-11d5-9867-9880AB8D8130}

DEFINE_GUID(IID_IInterf1, &h211fe1e1, &hfa21, &h11d5, &h98, &h67, &h98, &h80, &hab, &h8d, &h81, &h30) 

 

' {211FE1E2-FA21-11d5-9867-9880AB8D8130}

DEFINE_GUID(IID_IInterf2, &h211fe1e2, &hfa21, &h11d5, &h98, &h67, &h98, &h80, &hab, &h8d, &h81, &h30) 

Type  IInterf1 extends IUnknown  
  Declare abstract Function Hi() As HRESULT
End Type 

 

Type  IInterf2  extends IUnknown  
  Declare abstract Function  Hi() As HRESULT
End Type 

Type CAny As CAny_

Type Interf2Impl extends IInterf2  
  Declare virtual function AddRef() As ULong 
  Declare virtual function Release()  As ULong
  Declare virtual function  QueryInterface(riid As REFIID ,ppv As LPVOID Ptr) As HRESULT

  Declare virtual Function  Hi() As HRESULT

   m_pParent As CAny Ptr   ' spécifier la coclasse qui va contenir toutes les interfaces obligation de pointeur car la classe n'a pas encore été définie

End Type


Type CAny_ extends IInterf1  

public:
  Declare virtual function AddRef() As ULong 
  Declare virtual function Release()  As ULong
  Declare virtual function  QueryInterface(riid As REFIID ,ppv As LPVOID Ptr) As HRESULT

  Declare virtual Function  Hi() As HRESULT

 Declare Constructor()

private:
    As ULong m_refCount 
    As Interf2Impl m_impl     ' spécifier les interfaces implementées
End Type

Constructor CAny_()
   m_impl.m_pParent = @this 
End Constructor

function CAny_.AddRef() As ULong 
	m_refCount +=1
   Return  m_refCount 
End Function

 function CAny_.Release()  As ULong
 	 m_refCount-=1

if( m_refCount = 0) Then
 Delete @this
  Return 0 
Else
  return m_refCount 
End If
 End Function
Function CAny_.QueryInterface(riid As REFIID ,ppv As LPVOID Ptr) As HRESULT

If(riid =  IID_IUnknown) Then
   *ppv = Cast(IUnknown Ptr,@This)
ElseIf(riid = IID_IInterf1) Then
   *ppv = Cast(IInterf1 Ptr,@This)

ElseIf(riid = IID_IInterf2) Then
  *ppv = @m_impl

Else
  *ppv = NULL 
   Return E_NOINTERFACE 
End If

Cast(IUnknown Ptr,*ppv)->AddRef() 

return S_OK 

End Function



Function CAny.Hi()As HRESULT
      print "Hi from Interf1Impl" 
      return S_OK 
End Function


 
 

function Interf2Impl.AddRef() As ULong 
	Return m_pParent->AddRef()
End Function

 function Interf2Impl.Release()  As ULong
 	Return m_pParent->Release()
 End Function
 
Function Interf2Impl.QueryInterface(riid As REFIID ,ppv As LPVOID Ptr) As HRESULT
Return m_pParent->QueryInterface(riid ,ppv) 
End Function

Function  Interf2Impl.Hi()As HRESULT
      print "Hi from Interf2Impl"
      return S_OK
End Function

 
 'Rq: En POO pur on aurait: dim pi1 as Interf1 ptr=new CAny  pi1->Hi() 
 
 
 Dim as CAny Ptr pa = new CAny 
   Dim As IInterf1 Ptr pi1 
   Dim As IInterf1 Ptr pi2
   Dim As HRESULT hr = pa->QueryInterface(@IID_IInterf1, cast(lpvoid Ptr,@pi1 ))

   pi1 ->Hi() 
   
   hr = pa->QueryInterface(@IID_IInterf2, cast(lpvoid Ptr,@pi2 ))

   pi2 ->Hi() 
   
   sleep

aloberoger · Post by **aloberoger** » Jul 31, 2015 16:50

how to read com componants another way
browher.bas

Code: Select all

'***************************************************************
#Include Once "gui.bi"

Dim Shared  Form1 As TFORM
DIM SHARED 	Static1	 AS 	TSTATIC
DIM SHARED 	Static2	 AS 	TSTATIC
DIM SHARED 	m_ListCtrl	       As 	TListview
DIM SHARED 	m_ListTypeAttribs	 AS 	TListview
DIM SHARED 	m_ListTypeInfo	    AS 	TListview

DIM SHARED 	Static3	 AS 	TSTATIC
DIM SHARED 	Static4	 AS 	TSTATIC
DIM SHARED 	Static5	 AS 	TSTATIC
DIM SHARED 	Static6	 AS 	TSTATIC
DIM SHARED 	Static7	 AS 	TSTATIC
DIM SHARED 	Static8	 AS 	TSTATIC
DIM SHARED 	Static9	 AS 	TSTATIC
DIM SHARED 	Static10	 AS 	TSTATIC
DIM SHARED 	Static11	 AS 	TSTATIC
DIM SHARED 	Static12	 AS 	TSTATIC
DIM SHARED 	Static13	 AS 	TSTATIC
DIM SHARED 	Static14	 AS 	TSTATIC
DIM SHARED 	Static15	 AS 	TSTATIC
DIM SHARED 	Static16	 AS 	TSTATIC


'**************************************************************
' Other variables & constants used by the program go here
'**************************************************************

#Include Once "TlbReaderClassgui.bas"

Declare Sub Form1_Create(Sender As TForm)
Declare Sub Form1_Show(Sender As TForm)
Declare Sub Form1_Destroy(Sender As TForm)
 

Declare Sub Form1_ItemClick(Sender As TMenuItem)

Declare Sub Form1_ButtonClick(Sender As TButton)
Declare Sub m_ListCtrl_Click(ByRef sender As TListView,buton As Long,iitem As Long,isubitem As Long) 
Declare Sub m_ListTypeInfo_Click(ByRef sender As TListView,buton As Long,iitem As Long,isubitem As Long)
Declare Sub m_ListTypeAttribs_Click(ByRef sender As TListView,buton As Long,iitem As Long,isubitem As Long)
 
 Declare Sub UpdateDisplay()
 
  Dim Shared gtlbr As CTLBBrowser
 


'***************************************************************
' Now let's create and load the form and all of its controls
'***************************************************************

SUB Form1_LOAD()
 With Form1
     .mainform=TRUE
      .Create    
      .Caption     =  "type library Reader"
      .Left        =  4
      .Top         =  30
      .Width       =  740
      .Height      =  567 
      .borderstyle =bsDialog
    
      .OnDestroy    = @Form1_Destroy
      .Center 
   	 
 
 	WITH  Static1
   			.Caption     =  "Registered typelibraries:"
   			.Parent     =  Form1
   			.Left        =   8
   			.Top         =   8
  			   .Width       =   272
  			   .Height      =   22
  			   .Visible      = TRUE
            .Font.Name           =  "arial"
            .Font.Size           =  9
 	END WITH
 
 	WITH  Static2
   			.Caption     =  "type Information:"
   			.Parent     =  Form1
   			.Left        =   384
   			.Top         =   8
  			   .Width       =   264
  			   .Height      =   22
  			   .Visible      = TRUE
            .Font.Name           =  "arial"
            .Font.Size           =  9
 
 	END WITH
  
 		WITH  m_ListCtrl
  			 	   .Parent     =  Form1
   				.Left        =   8
   				.Top         =  33
   				.Width       =   336
   				.Height      =   191
   				.OnClick  =@m_ListCtrl_Click
   				.Visible      = TRUE
 		END WITH
            m_ListCtrl.AddColumns 330,"Type Library Description"
            m_ListCtrl.gridlines=TRUE
            m_ListCtrl.RowSelect=true
            
            
            
 		WITH  m_ListTypeInfo
  			 	   .Parent     =  Form1
   				.Left        =   400
   				.Top         =   33
   				.Width       =   312
   				.Height      =   191
   				.OnClick  =@m_ListTypeInfo_Click
   				.Visible      = TRUE
 		END WITH
  
             m_ListTypeInfo.AddColumns 310,"Type Information"
             m_ListTypeInfo.gridlines=TRUE
             m_ListTypeInfo.RowSelect=TRUE  
             
             
             
 	WITH  Static3
   			.Caption     =  "GUID for type library:"
   			.Parent      =  Form1
   			.Left        =   10
   			.Top         =   256
  			   .Width       =   140
  			   .Height      =   24
  			   .Visible      = TRUE
            .Font.Name           =  "arial"
            .Font.Size           =  9
 
 	END WITH
   
 	WITH  Static4
   			.Caption     =  "Associated Help String:"
   			.Parent     =  Form1
   			.Left        =   10
   			.Top         =   280
  			   .Width       =   140
  			   .Height      =   32
  			   .Visible      = TRUE
            .Font.Name           =  "arial"
            .Font.Size           =  9
 
 	END WITH
    
 	WITH  Static5
   			.Caption     =  "Associated Help File:"
   			.Parent     =  Form1
   			.Left        =   10
   			.Top         =   312
  			   .Width       =   140
  			   .Height      =   22
  			   .Visible      = TRUE
            .Font.Name           =  "arial"
            .Font.Size           =  9
 
 	END WITH
     
 	WITH  Static6
   			.Caption     =  "Type Information details:"
   			.Parent     =  Form1
   			.Left        =   8
   			.Top         =   384
  			   .Width       =   200
  			   .Height      =   20
  			   .Visible      = TRUE
            .Font.Name           =  "arial"
            .Font.Size           =  9
 
 	END WITH
      
 	WITH  Static7
   			.Caption     =  "type:"
   			.Parent     =  Form1
   			.Left        =   400
   			.Top         =   256
  			   .Width       =   80
  			   .Height      =   22
  			   .Visible      = TRUE
            .Font.Name           =  "arial"
            .Font.Size           =  9
  
 	END WITH
       
 	WITH  Static8
   			.Caption     =  "Help String:"
   			.Parent     =  Form1
   			.Left        =   400
   			.Top         =   280
  			   .Width       =   80
  			   .Height      =   22
  			   .Visible      = TRUE
            .Font.Name           =  "arial"
            .Font.Size           =  9
 
 	END WITH
        
 	WITH  Static9
   			.Caption     =  "Help File:"
   			.Parent     =  Form1
   			.Left        =  400
   			.Top         =  312
  			   .Width       =  80
  			   .Height      =  22
  			   .Visible      = TRUE
            .Font.Name           =  "arial"
            .Font.Size           =  9
 
 	END WITH
         
 	WITH  Static10
   			.Caption    =  "Static10"
   			.Parent     =  Form1
   			.Left       =   150 
   			.Top        =   256
  			   .Width       =  230
  			   .Height      =  22
  			   .Visible      = TRUE
            .Font.Name           =  "arial"
            .Font.Size           =  9
            .Font.color =clgreen
 	END WITH
          
 	WITH  Static11
   			.Caption    =  "Static11"
   			.Parent     =  Form1
   			.Left       =   150 
   			.Top        =   280
  			   .Width       =  230
  			   .Height      =   22
  			   .Visible      = TRUE
            .Font.Name           =  "arial"
            .Font.Size           =  9
            .Font.color =clgreen
 	END WITH
           
 	WITH  Static12
   			.Caption     =  "Static12"
   			.Parent     =  Form1
   			.Left        =   150 
   			.Top         =   312
  			   .Width       =   230
  			   .Height      =   22
  			   .Visible      = TRUE
            .Font.Name           =  "arial"
            .Font.Size           =  9
            .Font.color =clgreen
 	END WITH
            
 	WITH  Static13
   			.Caption     =  "Static13"
   			.Parent      =  Form1
   			.Left        = 480
   			.Top         = 256
  			   .Width       =  228
  			   .Height      =  22
  			   .Visible     = TRUE
            .Font.Name   =  "arial"
            .Font.Size   =  9
            .Font.color=clgreen
    
 	END WITH
             
 	WITH  Static14
   			.Caption    =  "Static14"
   			.Parent     =  Form1
   			.Left       =   480
   			.Top        =   280
  			   .Width      =  228
  			   .Height     =  22
  			   .Visible    = TRUE
            .Font.Name  =  "arial"
            .Font.Size  =  9
            .Font.color=clgreen
 	END WITH
              
 	WITH  Static15
   			.Caption     =  "Static15"
   			.Parent     =  Form1
   			.Left        =   480
   			.Top         =   304
  			   .Width       =   228
  			   .Height      =   22
  			   .Visible      = TRUE
            .Font.Name           =  "arial"
            .Font.Size           =  9
            .Font.color=clgreen
 	END WITH
               
 	WITH  Static16
   			.Caption     =  "Static16"
   			.Parent     =  Form1
   			.Left        =   16
   			.Top         =   352
  			   .Width       =   687
  			   .Height      =   16
  			   .Visible      = TRUE
             .Font.Name           =  "arial"
             .Font.Size           =  9
             .color=clyellow
 	END WITH
                
 		WITH  m_ListTypeAttribs
  			 	.Parent     =  Form1
   			.Left        =   8
   			.Top         =   406 
   			.Width       =   695
   			.Height      =   110 
   			.Visible      = TRUE
   			.Onclick    =@m_ListTypeAttribs_Click
 		END WITH
            m_ListTypeAttribs.AddColumns 660,"Type Attributes"
            m_ListTypeAttribs.gridlines=TRUE
            m_ListTypeAttribs.RowSelect=TRUE  
            
            
            
      
	'Use the registry to get all registered typelibraries
 	gtlbr.EnumerateRegistryForTypeLibEntries() 


	'Get the Typelibray Info for the registered typelibrary
	'Start with the first type library
  	gtlbr.GetInformationForTLB(1) 
 	      
    UpdateDisplay()        
            
            
            
            
                 
   .Center 
   .Visible      = 1 
  .Show  ' Affiche la Form
 END WITH
END SUB


Form1_LOAD()
Application.Run
Application.Terminate




'***********************************************************************************
' Add any other supporting routines here
'***********************************************************************************
Sub Form1_Create(Sender As TForm)
End Sub


Sub Form1_Destroy(Sender As TForm)
                ' Add Your Code hear
End Sub


Sub m_ListCtrl_Click(ByRef sender As TListView,buton As Long,iitem As Long,isubitem As Long) 
  	  m_ListTypeInfo.clear
  	  gtlbr.GetInformationForTLB(iitem)
  	  UpdateDisplay()
     
End Sub
 
 
 
 
 Sub m_ListTypeInfo_Click(ByRef sender As TListView,buton As Long,iitem As Long,isubitem As Long) 
  	   m_ListTypeAttribs.clear
  	   gtlbr.GetTypeInfoInformation(Cast(DWORD,iitem))
      UpdateDisplay()
 End Sub
 
  Sub m_ListTypeAttribs_Click(ByRef sender As TListView,buton As Long,iitem As Long,isubitem As Long) 
  	      showmessage("You have clicked on " & m_ListTypeAttribs.Cell(iitem,isubitem))
  End Sub
 
 Sub UpdateDisplay()
 	Static10.caption=gtlbr.m_strGUIDTLB
 	Static11.caption=gtlbr.m_strHelpString
 	Static12.caption=gtlbr.m_strHelpFile
 	
 	Static13.caption= gtlbr.m_strErrorStatus
 	Static14.caption= gtlbr.m_strTypeHelpString 
 	Static15.caption= gtlbr.m_strTypeHelpFile
 	
 	Static16.caption=gtlbr.m_strTypeDescription
 End Sub

find a bitmap and name it bitmap1.bmp like in this .rc
brosher.rc

Code: Select all

IDR_MAINFRAME ICON DISCARDABLE "res/TLBBrowser.ico"
IDB_IMAGE_LIST BITMAP DISCARDABLE "res/bitmap1.bmp"


VS_VERSION_INFO VERSIONINFO
FILEVERSION 1,0,0,1
PRODUCTVERSION 1,0,0,1
FILEOS 0x00000004
FILETYPE 0x00000001
BEGIN
  BLOCK "StringFileInfo"
  BEGIN
    BLOCK "040904B0"
    BEGIN
      VALUE "FileDescription", "TLBBrowser Application\0"
      VALUE "FileVersion", "1, 0, 0, 1\0"
      VALUE "InternalName", "TLBBrowser\0"
      VALUE "LegalCopyright", "Copyright (C) 2015\0"
      VALUE "OriginalFilename", "TLBBrowser.EXE\0"
      VALUE "ProductName", "TLBBrowser Application\0"
      VALUE "ProductVersion", "1, 0, 0, 1\0"
    END
  END
  BLOCK "VarFileInfo"
  BEGIN
    VALUE "Translation", 0x0409, 0x04B0
  END
END

tlbreaderclassgui.bas

Code: Select all

#Include Once "windows.bi"
#Include Once "win/ole2.bi"


static Shared As ZString Ptr  g_arrClassification(0 To ...) = { @"Enum",@"Struct",@"Module",@"Interface", _
                                                                @"Dispinterface",@"Coclass",@"Typedef",@"Union"}


Function StrToBSTR(cnv_string As String) As BSTR
	Dim sb As BSTR
	Dim As Integer n
	n = (MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, NULL, 0))-1
	sb=SysAllocStringLen(sb,n)
	MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, sb, n)
	Return sb
End Function

Function CheckError(hr As HRESULT) As String
	Dim As Any Ptr pMsg

	FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,NULL,hr, _
	MAKELANGID(LANG_NEUTRAL,SUBLANG_DEFAULT),Cast(LPTSTR,@pMsg),0,NULL)

	CheckError= " : Error(&h" & Hex(hr) & "): "  & *Cast(ZString Ptr,pMsg)

	LocalFree(pMsg)
End Function

Sub ShowOleError   ( hr As HRESULT, addit As String="")
	Dim serr As String
	If hr=s_ok Then Exit Sub
	serr=addit & " " & CheckError(hr)
	MessageBox (getactiveWindow(),serr,"OLE ERROR ",MB_ICONERROR Or MB_TASKMODAL)
End Sub

#Include Once "Utils.bi"


Type CTypeLibraryData
	As String m_strCLSIDTypeLib
	As String m_strDescription
	As Long   m_lMajorVersion
	As Long   m_lMinorVersion
End Type





Type CTLBBrowser


	public:
	Declare Constructor()
	Declare Destructor()




	As ZString*128	m_strGUIDTLB
	As ZString*255	m_strHelpString
	As ZString*256	m_strHelpFile
	As ZString*255	m_strErrorStatus
	As ZString*256	m_strTypeHelpFile
	As ZString*255	m_strTypeHelpString
	As ZString*55	m_strTypeDescription





	Declare Function  OnInitRead() As BOOL
	Declare Function  EnumerateRegistryForTypeLibEntries()As BOOL
	Declare Function  GetInformationForTLB(dwIndex As DWORD )As BOOL
	Declare Function  ExtractComponentsFromTLB(iIndex As Integer )As BOOL
	Declare Function  GetTypeInfoInformation(dwIndex As DWORD )As BOOL
	Declare Function  GetTypeAttributes()As BOOL


	As Integer m_nTLBListLastSelectedItem
	As CTypeLibraryData Ptr m_arrayData(Any)


	As ITypeLib Ptr  m_pTypeLib
	As ITypeInfo Ptr m_pCurrentTypeInfo

End Type



Constructor CTLBBrowser()

m_strGUIDTLB = ""
m_strHelpString = ""
m_strHelpFile = ""
m_strErrorStatus = ""
m_strTypeHelpFile = ""
m_strTypeHelpString = ""
m_strTypeDescription = ""


'Initialize the interface pointers
m_pTypeLib = NULL
m_pCurrentTypeInfo = NULL

End Constructor




Destructor CTLBBrowser

'Release our interfaces

if(m_pTypeLib)         Then m_pTypeLib->Release()
if(m_pCurrentTypeInfo) Then m_pCurrentTypeInfo->Release()


'Clean up the array
for  iIndex As Integer= 0 To UBound(m_arrayData) '-1
	delete m_arrayData(iIndex)
Next


Erase m_arrayData


End Destructor




Function CTLBBrowser.OnInitRead() As BOOL

	EnumerateRegistryForTypeLibEntries() 'Use the registry to get all registered typelibraries

	'Get the Typelibray Info for the registered typelibrary
	'Start with the first type library
	GetInformationForTLB(1)

	return TRUE   ' return TRUE  unless you set the focus to a control

End Function






' This function enumerates through the registry entries picking
' up all registered type libraries

Function CTLBBrowser.EnumerateRegistryForTypeLibEntries()As BOOL


Dim As HKEY   hKeyTypeLib = NULL
Dim As HKEY   hKeyClassTLB = NULL
Dim As DWORD  dwSubKeyIndex = 0
Dim As DWORD  dwCLSIDSubKeyIndex = 0
Dim As Long  dwSizeOfDataBlock = 0
Dim As ZString*128  tchTypeCLSID
Dim As ZString*128  tchVersionInformation
Dim As DWORD  dwLibMajorVersion = 0
Dim As BOOL    bSuccess = TRUE
Dim As HRESULT hr = S_OK
Dim As ZString Ptr pDescription = NULL
Dim As Long lRegResult = 0
Dim As Integer iIndex = 0
Dim As BOOL bAlreadyInArray = FALSE




'Open the TypeLib Key under HKCR
lRegResult =RegOpenKeyEx(HKEY_CLASSES_ROOT,"TypeLib",0,KEY_READ,@hKeyTypeLib)

if(lRegResult <> ERROR_SUCCESS) Then
	Messagebox NULL,!"Error occured while trying to open key \r\n","error",MB_ICONERROR
	bSuccess = FALSE
End If



'If all's well go ahead
if(bSuccess) Then

	ASSERT(hKeyTypeLib <> NULL)

	'Enumerate thru all the typelib CLSID entries

	Do While RegEnumKey(hKeyTypeLib, dwSubKeyIndex, StrPtr(tchTypeCLSID), sizeof(tchTypeCLSID)) = ERROR_SUCCESS

		'Open each CLSID Subkey  under the TypeLib key
		lRegResult = RegOpenKeyEx(hKeyTypeLib,StrPtr(tchTypeCLSID),0, KEY_READ, @hKeyClassTLB)

		if(lRegResult <> ERROR_SUCCESS) Then
			bSuccess = FALSE
		End If

		if(bSuccess)Then

			dwCLSIDSubKeyIndex = 0

			'Get each Subkey under the CLSID subkey
			' We should be able to get version information
			lRegResult = RegEnumKey(hKeyClassTLB,dwCLSIDSubKeyIndex ,tchVersionInformation,SizeOf(tchVersionInformation))
			Do While(lRegResult= ERROR_SUCCESS)

				'Get the version information
				dwLibMajorVersion = CInt(tchVersionInformation)

				'Open the default key under version information
				Dim As HKEY hKeyVersion = NULL
				lRegResult = RegOpenKeyEx(hKeyClassTLB,tchVersionInformation,0,KEY_READ,@hKeyVersion)

				if(lRegResult <> ERROR_SUCCESS) Then
					bSuccess = FALSE
				End If


				if(bSuccess) Then

					'What's the size of the string we are looking for ?
					lRegResult = RegQueryValue(hKeyVersion,NULL,NULL,@dwSizeOfDataBlock)
					if(lRegResult <> ERROR_SUCCESS) Then
						bSuccess = FALSE
					End If
				End If



				if(bSuccess)  Then

					'Got the string size
					'Allocate Memory and query for description
					pDescription = new Byte[dwSizeOfDataBlock + 1]
					lRegResult = RegQueryValue(hKeyVersion,NULL,pDescription,@dwSizeOfDataBlock)

					if(lRegResult <> ERROR_SUCCESS) Then
						delete [] pDescription
						bSuccess = FALSE
					End If

				End If



				if(bSuccess)  Then

					'append version information
					Dim As String strDescription=*pDescription
					if(pDescription) Then delete pDescription
					strDescription += " "
					strDescription += tchVersionInformation

					if(strDescription <> "") Then

						'insert the information  in the list ctrl
						m_ListCtrl.Additems(strDescription)

						'Fill up our user defined data structure

						Dim As CTypeLibraryData Ptr pData = new CTypeLibraryData

						pData->m_strDescription = strDescription
						pData->m_strCLSIDTypeLib = tchTypeCLSID
						pData->m_lMajorVersion = CInt(Left(tchVersionInformation,InStr(tchVersionInformation,".")-1))
						Dim As ZString*10 pMinor = Mid(tchVersionInformation,InStr(tchVersionInformation,".")+1)

						pData->m_lMinorVersion = 0
						If Len(pMinor) Then
							pData->m_lMinorVersion = CInt(pMinor)
						End If

						'Add it to the array
						ReDim Preserve m_arrayData(iIndex)
						m_arrayData(iIndex)=pData
						iIndex+=1
					End If 'add it to the array
				End If 'if bSuccess
				dwCLSIDSubKeyIndex+=1
				lRegResult = RegEnumKey(hKeyClassTLB,dwCLSIDSubKeyIndex, tchVersionInformation, sizeof(tchVersionInformation))
			Loop 'Inner Enumeration

			RegCloseKey(hKeyClassTLB)


		End If 'if the CLSID Subkey portion is successfully opened

		dwSubKeyIndex+=1

	Loop 'Outer Enumeration

	RegCloseKey(hKeyTypeLib)

End If  'if the TypeLib under HKCR  key is opened
return TRUE
End Function





' Pick up type information for each registered type library

Function CTLBBrowser.GetInformationForTLB(dwIndex As DWORD )As BOOL
Dim As BOOL bSuccess = TRUE
Dim As HRESULT hr = S_OK
Dim As BSTR bstrHelpString = NULL
Dim As BSTR bstrCLSID = NULL
Dim As BSTR bstrHelpFileName = NULL
Dim As CLSID clsidTypeLib

'Set default display strings
Dim As String strHelpString="No Help string available"
Dim As String strHelpFileName="No Help File available"


'Get the information from the array
Dim As CTypeLibraryData Ptr pData = m_arrayData(dwIndex)


'Set the current type library CLSID
this.m_strGUIDTLB = pData->m_strCLSIDTypeLib

if(0=pData) Then
	bSuccess = FALSE
End If


'Get the CLSID from the stored string
if(bSuccess)Then
	hr = CLSIDFromString(WStr(pData->m_strCLSIDTypeLib),@clsidTypeLib)
	if(hr <> S_OK)Then
		bSuccess = FALSE
	End If
End If

 
 ' Release the typelibrary
 
if(m_pTypeLib)Then
	m_pTypeLib->Release()
End If

'Load the typelibrary
if(bSuccess)Then
	hr = LoadRegTypeLib (@clsidTypeLib,pData->m_lMajorVersion,pData->m_lMinorVersion,0,@m_pTypeLib)
	if(hr <> S_OK)Then
		Dim As String strError
		ShowOleError(hr,"LoadRegTypeLib returned error")
		m_strErrorStatus = strError
		bSuccess = FALSE
	End If
End If

if(hr <> S_OK)Then
	bSuccess = FALSE
End If

'Get the help string and the help file name
if(bSuccess)Then
	ASSERT(m_pTypeLib)
	m_pTypeLib->GetDocumentation( -1,NULL,@bstrHelpString,NULL,@bstrHelpFileName)
	If(bstrHelpString)Then
		if(*Cast(WString Ptr,bstrHelpString) <> "") Then
			strHelpString = *Cast(WString Ptr,bstrHelpString)
		End If
		.SysFreeString(bstrHelpString)
	End If

	If(bstrHelpFileName = NULL) Then
		if(*Cast(WString Ptr,bstrHelpFileName) <> "") Then
			strHelpFileName = *Cast(WString Ptr,bstrHelpFileName)
		End If
		.SysFreeString(bstrHelpFileName)
	End If


End If


if(m_pTypeLib<>0 And bSuccess<>0)Then
	ExtractComponentsFromTLB(dwIndex)  'Extract the Type Information from the Typelibrary
End If

This.m_strHelpString = strHelpString
this.m_strHelpFile = strHelpFileName

Return TRUE
End Function




'
' Actual function that culls out the type information from ITypeLib interface
'

Function CTLBBrowser.ExtractComponentsFromTLB( iIndex As Integer)As BOOL


Dim As Long lTypeInfoCount = 0
Dim As BSTR bstrName = NULL
Dim As BOOL bSuccess = TRUE


ASSERT(m_pTypeLib <> NULL)

lTypeInfoCount = m_pTypeLib->GetTypeInfoCount() 'Get the type information count

if(lTypeInfoCount =0)Then      'Make sure that we have type information
	bSuccess = FALSE
End If


if(bSuccess)Then
	'Get the help string and help file for each TypeInfo
	for  lIter As long = 0 to lTypeInfoCount -1
		m_pTypeLib->GetDocumentation(lIter, @bstrName, NULL, NULL, NULL)
		m_ListTypeInfo.Additems( *Cast(WString Ptr,bstrName))
		if(bstrName)Then .SysFreeString(bstrName)

	Next

End If

Return TRUE

End Function



' Get details for each TypeInfo (whether CoClass , dispinterface, Enum ... etc.)
'

Function CTLBBrowser.GetTypeInfoInformation(dwIndex As DWORD ) As BOOL

Dim As TYPEKIND etypeKind
Dim As BSTR bstrHelpFileName = NULL
Dim As BSTR bstrHelpString = NULL
Dim As BOOL bSuccess = TRUE
Dim As HRESULT hr = S_OK
Dim As String strHelpFileName="No help file available"
Dim As String strHelpString  ="No Help string available"


'Get the information about the TypeInfo
hr = m_pTypeLib->GetTypeInfoType(cuint(dwIndex), @etypeKind)

'index into our global array to pick up the description
if(hr <> S_OK)Then
	bSuccess = FALSE
	m_strTypeDescription = ""
else
	m_strTypeDescription = *g_arrClassification(etypeKind)
End If


 'etypeKind: donne le type d'information enum,interface,coclasse,dispinterface etc

'get the help string and help file name
if(bSuccess)Then
	hr = m_pTypeLib->GetDocumentation(cuint(dwIndex),NULL,	@bstrHelpString,NULL,@bstrHelpFileName)

	if(hr <> S_OK)Then
		bSuccess = FALSE
	else
		if(bstrHelpString)Then
			if(*Cast(WString Ptr,bstrHelpString) <> "") Then
				strHelpString = *Cast(WString Ptr,bstrHelpString)
			End If
		End If
		if(bstrHelpFileName) Then
			If(*Cast(WString Ptr,bstrHelpFileName) <> "") Then
				strHelpFileName = *Cast(WString Ptr,bstrHelpFileName)
			End If
		End If
	End If
End If  'if bSuccess


'Get the Type information ptr (ITypeInfo ptr)
'From which we can get the ITypeAttr ptr
if(bSuccess) Then
	ASSERT(m_pTypeLib)
	if(m_pCurrentTypeInfo) Then m_pCurrentTypeInfo->Release()
	hr = m_pTypeLib->GetTypeInfo(cuint(dwIndex), @m_pCurrentTypeInfo)

	if(hr <> S_OK) Then
		bSuccess = FALSE
	End If
End If


if(bSuccess)Then
	ASSERT(m_pCurrentTypeInfo)

	'All's well (we got the ITypeInfo ptr)
	'Now go ahead and get the ITypeAttr ptr
	GetTypeAttributes()
End If

this.m_strTypeHelpFile = strHelpFileName
this.m_strTypeHelpString = strHelpString
'UpdateData(FALSE)
Return bSuccess

End Function

Dim Shared ss As String


Function CTLBBrowser.GetTypeAttributes() As BOOL

ASSERT(m_pCurrentTypeInfo)

Dim As MEMBERID memberID
Dim As FUNCDESC Ptr pFuncDesc = NULL
Dim As VARDESC Ptr pVarDesc = NULL
Dim As TYPEATTR Ptr pTypeAttributes = NULL
Dim As BSTR bstrMethod = NULL
Dim As BSTR bstrProperty = NULL

m_pCurrentTypeInfo->GetTypeAttr(@pTypeAttributes) 'Get the TypeAttributes

'Dim As Integer iIndex = 0
'Lets get all the methods for this Type Info
for  iIter As Integer= 0 To pTypeAttributes->cFuncs-1
	m_pCurrentTypeInfo->GetFuncDesc(iIter, @pFuncDesc)   'Get the function description
	memberID = pFuncDesc->memid                          'Get the member ID
	m_pCurrentTypeInfo->GetDocumentation(memberID, @bstrMethod, NULL, NULL, NULL)  'Get the name of the method
   ss & = stringifyCOMMethod(pFuncDesc, m_pCurrentTypeInfo) & Chr(13,10)
'TODO:
    'récuperer info sur les functions

 	m_ListTypeAttribs.Additems(*Cast(WString Ptr,bstrMethod) & "   <" & memberID & ">" )

	If(bstrMethod) Then .SysFreeString(bstrMethod)
	m_pCurrentTypeInfo->ReleaseFuncDesc(pFuncDesc)  'Release our function description stuff
'	iIndex+=1
Next
   Open "toto.txt" For Output As #1
      Print #1,ss
    Close #1 
     ss=""
for iIter As Integer= 0 to pTypeAttributes->cVars-1
	m_pCurrentTypeInfo->GetVarDesc(iIter, @pVarDesc)   'Get the property description
	memberID = pVarDesc->memid      'Get the member ID
	m_pCurrentTypeInfo->GetDocumentation(memberID, @bstrProperty, NULL, NULL, NULL)  'Get the name of the property
	m_ListTypeAttribs.Additems(*Cast(WString Ptr,bstrProperty))
	
   ss &= stringifyVarDesc(pVarDesc,m_pCurrentTypeInfo)& Chr(13,10) 
   
	If(bstrProperty) Then .SysFreeString(bstrProperty)
 	If pVarDesc Then m_pCurrentTypeInfo->ReleaseVarDesc(pVarDesc)  'Release our variable description stuff
'	iIndex+=1

Next
  Open "totov.txt" For Output As #1
      Print #1,ss
    Close #1 
return TRUE

End Function

aloberoger · Post by **aloberoger** » Aug 25, 2015 18:30

automation object
automationob.bi

Code: Select all


#Include Once "windows.bi" 
#Include Once "win/olectl.bi" 
 
 

Function V_LET OverLoad (varValue As Double )As VARIANT
  Dim As VARIANT V
  V.vt=VT_R8 : V.dblval=varValue
  return v
End Function 

Function V_LET  (varValue As IDISPATCH Ptr )As VARIANT
  Dim As VARIANT V
  V.vt=VT_DISPATCH : V.pdispval=varValue
  return v
End Function 



Type ole_exception 
	Declare Constructor()
	Declare Constructor(h As HRESULT )  
	As HRESULT hr 
End Type

Constructor ole_exception() 
End Constructor

Constructor ole_exception(h As HRESULT ) 
   hr=h 
End Constructor


Type  Dispatch_exception extends ole_exception
 	Declare Constructor()
 	Declare Constructor(hr As HRESULT ,ByRef  ex As Const EXCEPINFO  ,uErr as UINT )  
	As EXCEPINFO m_DispEx 
	As UINT      m_ArgErr 
End Type

Constructor Dispatch_exception()
End Constructor

Constructor Dispatch_exception(hr As HRESULT ,ByRef   ex As Const EXCEPINFO  ,uErr as UINT ) 
     base(hr) 
     m_DispEx=ex 
     m_ArgErr=uErr   
End Constructor

Sub throw (ByRef ob As ole_exception,verbose As ZString Ptr=NULL)
 Dim As DWORD nLastError             ' Numéro de l'erreur 
 Dim As LPTSTR pMsg       ' Récupération du message 
  
  nLastError = ob.hr 

 Dim serr As String
 
 	 
	FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,NULL,nLastError, _
		          MAKELANGID(LANG_NEUTRAL,SUBLANG_DEFAULT), Cast(LPTSTR,@pMsg) ,0,NULL) 

	MessageBox NULL, *Cast(ZString Ptr,verbose) & " : Error(&h" & Hex(nLastError) & "): "  & _
	               *Cast(ZString Ptr,pMsg) ,"Error",MB_OK OR MB_ICONERROR  OR MB_SYSTEMMODAL
	LocalFree(pMsg)
 
End Sub

Type  AutomationOb  extends object	
	Declare constructor() 
	Declare Constructor(clsid As Const String,context As DWORD)   ' context= CLSCTX or ...
	Declare Constructor(clsid As Const String)
	Declare Constructor(clsid As Const CLSID Ptr) 
	Declare Constructor(ByRef pd As IDispatch Ptr)
	Declare Constructor(ByRef ob As Const AutomationOb) 
	Declare virtual Destructor() 
	Declare Function GetNameID(oName As String) As Const VARIANT
	Declare Function GetProperty(oName As String,paramvalues as VARIANTARG Ptr=NULL, paramscount As Integer=0) As VARIANT
	Declare Function GetProperty(dipid As DISPID,paramvalues as VARIANTARG Ptr=NULL, paramscount As Integer=0) As VARIANT
	Declare Function PutProperty(oName As String,paramvalues as VARIANTARG Ptr, paramscount As Integer=1) As Integer
	Declare Function PutProperty(dipid As DISPID,paramvalues as VARIANTARG Ptr, paramscount As Integer=1) As Integer
	Declare Function RunMethod(oName As String,paramvalues as VARIANTARG Ptr=NULL, iNum As Integer=0) As VARIANT
	Declare Function RunMethod(dipid As DISPID,paramvalues as VARIANTARG Ptr=NULL, iNum As Integer=0) As VARIANT
	Declare Function Egual (ByRef ob As Const AutomationOb) ByRef As AutomationOb
	Declare Function GetIDispatch() As IDispatch Ptr 
	Declare Sub InitializeDispatch(pDisp As IDispatch Ptr) 
   Declare Operator Cast() As IDISPATCH Ptr
   Protected:
	 As IDispatch ptr m_pDispatch 
   Private:
   Declare Function AutoWrap (autoType As Integer ,pvResult as VARIANT Ptr,pDisp as IDispatch Ptr,ptName As LPOLESTR ,pArgs As VARIANT Ptr=NULL, cArgs As Integer=0  )As HRESULT  
   Declare Function AutoWrap (autoType As Integer ,pvResult as VARIANT Ptr,pDisp as IDispatch Ptr,dispID As DISPID ,pArgs As VARIANT Ptr=NULL, cArgs As Integer=0  )As HRESULT  
   Declare Function TmpStr (Bites As size_t )As ZString Ptr
   Declare Function AnsiToWide (AnsiStr As zString Ptr,CodePage As  UINT=CP_ACP ,dwFlags As DWORD=MB_PRECOMPOSED )As LPOLESTR


End Type
 
 
  '''''''''''''''' IMPLEMENTATION '''''''''''''''''


Constructor AutomationOb()
    Oleinitialize(NULL)
    m_pDispatch=NULL
End Constructor

Constructor AutomationOb(ByRef pd As IDispatch Ptr)
	 Oleinitialize(NULL)
	If m_pDispatch Then
		m_pDispatch = pd
		#Ifndef _FB_COM_VTBL_ 
		    m_pDispatch->AddRef()
		#Else
          m_pDispatch->lpVtbl->AddRef(m_pDispatch)
      #EndIf
	Else
	   m_pDispatch = pd	
	EndIf
	
End Constructor

Constructor AutomationOb(ByRef ob As Const AutomationOb)
	 If ob.m_pDispatch Then
	  	 m_pDispatch = ob.m_pDispatch 
	    #Ifndef _FB_COM_VTBL_
	        ob.m_pDispatch->AddRef()
	    #Else
           ob.m_pDispatch->lpVtbl->AddRef(ob.m_pDispatch)
       #EndIf
	 Else
	 	 m_pDispatch = ob.m_pDispatch 
	 End If
	 
End Constructor
 
Constructor AutomationOb(clsid As Const String,context As DWORD )
 	Oleinitialize(NULL)
 	Dim As GUID acro
	Dim As BSTR tmp = SysAllocString(clsid)
	CLSIDFromString(tmp, @acro)
	Dim As HRESULT hr
	hr = CoCreateInstance(@acro, 0, context, @IID_IDispatch, Cast(LPVOID PTR,@m_pDispatch))
	if FAILED(hr) Then
		throw ole_exception(hr),"Ne peut initialiser l(objet"
	End If
	SysFreeString(tmp)
End Constructor 

 
 
Constructor AutomationOb(clsid As Const String)
   Oleinitialize(NULL)
	Dim As GUID acro
	Dim As BSTR tmp = SysAllocString(clsid)
	CLSIDFromString(tmp, @acro)
	Dim As HRESULT hr
	hr = CoCreateInstance(@acro, 0, CLSCTX_ALL, @IID_IDispatch, Cast(LPVOID PTR,@m_pDispatch))
	if FAILED(hr)Then
		throw ole_exception(hr),"Constructor AutomationOb"
	End If	
	SysFreeString(tmp)
	
 
End Constructor 
 
 
	
 Constructor AutomationOb(clsid As Const CLSID Ptr)
    Oleinitialize(NULL)
     Dim As HRESULT hr
	 hr = CoCreateInstance(clsid, 0, CLSCTX_ALL, @IID_IDispatch, Cast(LPVOID PTR,@m_pDispatch))
	if FAILED(hr)Then
		throw ole_exception(hr)
	End If	
 End Constructor
 
Destructor  AutomationOb()
	if( NULL <> m_pDispatch )Then
		#Ifndef _FB_COM_VTBL_
		    m_pDispatch->Release(): m_pDispatch=NULL
		#Else
          m_pDispatch->lpVtbl->Release(m_pDispatch): m_pDispatch=NULL
      #EndIf
	End If
End Destructor 

Function AutomationOb.TmpStr (Bites As size_t )As ZString Ptr
   Static As Integer   StrCnt 
  static  StrFunc As ZString*2048 
  StrCnt=(StrCnt + 1) And 2047 
  return Cast(ZString Ptr,calloc(Bites+128,sizeof(char)))
 End Function 
 
Function  AutomationOb.AnsiToWide (AnsiStr As zString Ptr,CodePage As  UINT=CP_ACP ,dwFlags As DWORD=MB_PRECOMPOSED )As LPOLESTR
  Dim As UINT uLen 
  Dim As BSTR WideStr 
  uLen=MultiByteToWideChar(CodePage,dwFlags,AnsiStr,-1,0,0) 
  if(uLen<=1) Then Return cast(BSTR,TmpStr(2)) 
  WideStr=cast(BSTR,TmpStr(2*uLen)) 
  MultiByteToWideChar(CodePage,dwFlags,AnsiStr,uLen,WideStr,uLen) 
  return WideStr 
End Function

Function AutomationOb.AutoWrap (autoType As Integer ,pvResult as VARIANT Ptr,pDisp as IDispatch Ptr,ptName As LPOLESTR ,pArgs As VARIANT Ptr=NULL, cArgs As Integer=0  )As HRESULT  
 
    if (0=pDisp)Then
        MessageBox(NULL, "NULL IDispatch passed", "AutoWrap()", MB_SETFOREGROUND or MB_ICONHAND)
        return E_UNEXPECTED
    End If

    ' Variables used...
   Dim As  DISPPARAMS dp = ( NULL, NULL, 0, 0 )
   Dim As  DISPID dispidNamed = DISPID_PROPERTYPUT
   Dim As  DISPID dispID
   Dim As  HRESULT hr
   Dim As ZString*200 buf  
   Dim As  ZString*200 szName 

    ' Convert name passed to to ANSI...
    WideCharToMultiByte(CP_ACP, 0, ptName, -1, szName, 200, NULL, NULL)

    ' Get DISPID for name passed...
    #Ifndef _FB_COM_VTBL_ 
         hr = pDisp->GetIDsOfNames(@IID_NULL, @ptName, 1, LOCALE_USER_DEFAULT, @dispID)
    #Else
         hr = pDisp->lpVtbl->GetIDsOfNames(pDisp, @IID_NULL, @ptName, 1, LOCALE_USER_DEFAULT, @dispID)
    #EndIf
    if(FAILED(hr))Then
        buf="IDispatch->GetIDsOfNames(" & *Cast(WString Ptr,ptName) & ") failed with error &h" & Hex(CInt(hr)  )
        MessageBox(NULL, buf, "AutoWrap()", MB_SETFOREGROUND or MB_ICONHAND)
        return hr
    End if

   Dim As VARIANTARG Ptr rgvarg = NULL 
	if(cArgs > 0)Then
	 	rgvarg = new VARIANTARG[cArgs] 
		For   i As Integer= 0  to cArgs-1   
			rgvarg[i] = pArgs[cArgs-i-1]
		next	
	End If


    ' Build DISPPARAMS...
    dp.cArgs = cArgs
    dp.rgvarg = rgvarg

    ' Handle special-case for property-puts!
    if (autoType And DISPATCH_PROPERTYPUT)Then
        dp.cNamedArgs = 1
        dp.rgdispidNamedArgs = @dispidNamed
    End If

    ' Make the call!
    #If Not Defined( _FB_COM_VTBL_)  
       hr = pDisp->Invoke(dispID, @IID_NULL, LOCALE_SYSTEM_DEFAULT, autoType, @dp, pvResult, NULL, NULL)
    #Else
       hr = pDisp->lpVtbl->Invoke(pDisp, dispID, @IID_NULL, LOCALE_SYSTEM_DEFAULT, autoType, @dp, pvResult, NULL, NULL)
    #EndIf
    
    if (FAILED(hr))Then
     
         buf="IDispatch->Invoke(" & szName & " dispid= " & dispID &  "  failed with error " & Hex(hr) 
        MessageBox(NULL, buf, "AutoWrap()", MB_SETFOREGROUND or MB_ICONHAND)
        ' Countinue by freeing the memory.
    End If 

     if(cArgs > 0)Then
	 	for i As Integer= 0  to cArgs-1   
			pArgs[cArgs-i-1]=dp.rgvarg[i]
	 	Next	
   End If

    if(cArgs > 0)Then
		delete[] rgvarg 
	End If	

    return hr
end Function

 Function AutomationOb.AutoWrap (autoType As Integer ,pvResult as VARIANT Ptr,pDisp as IDispatch Ptr,dipID As DISPID ,pArgs As VARIANT Ptr=NULL, cArgs As Integer=0  )As HRESULT  
 
    if (0=pDisp)Then
        MessageBox(NULL, "NULL IDispatch passed", "AutoWrap()", MB_SETFOREGROUND or MB_ICONHAND)
        return E_UNEXPECTED
    End If

    ' Variables used...
   Dim As  DISPPARAMS dp = ( NULL, NULL, 0, 0 )
   Dim As  DISPID dispidNamed = DISPID_PROPERTYPUT
   Dim As  HRESULT hr
   Dim As ZString*200 buf  
   
   
   Dim As VARIANTARG Ptr rgvarg = NULL 
	if(cArgs > 0)Then
	 	rgvarg = new VARIANTARG[cArgs] 
		For   i As Integer= 0  to cArgs-1   
			rgvarg[i] = pArgs[cArgs-i-1]
		next	
	End If


    ' Build DISPPARAMS...
    dp.cArgs = cArgs
    dp.rgvarg = rgvarg

    ' Handle special-case for property-puts!
    if (autoType And DISPATCH_PROPERTYPUT)Then
        dp.cNamedArgs = 1
        dp.rgdispidNamedArgs = @dispidNamed
    End If

    ' Make the call!
    #If Not Defined( _FB_COM_VTBL_)  
       hr = pDisp->Invoke(dipID, @IID_NULL, LOCALE_SYSTEM_DEFAULT, autoType, @dp, pvResult, NULL, NULL)
    #Else
       hr = pDisp->lpVtbl->Invoke(pDisp, dipID, @IID_NULL, LOCALE_SYSTEM_DEFAULT, autoType, @dp, pvResult, NULL, NULL)
    #EndIf
    
    if (FAILED(hr))Then
         buf="IDispatch->Invoke(" & " dispid= " & dipID &  "  failed with error " & Hex(hr) 
         MessageBox(NULL, buf, "AutoWrap()", MB_SETFOREGROUND or MB_ICONHAND)
        ' Countinue by freeing the memory.
    End If 

     if(cArgs > 0)Then
	 	for i As Integer= 0  to cArgs-1   
			pArgs[cArgs-i-1]=dp.rgvarg[i]
	 	Next	
   End If

    if(cArgs > 0)Then
		delete[] rgvarg 
	End If	

    return hr
end Function
  


Function AutomationOb.egual (ByRef ob As Const AutomationOb)ByRef As AutomationOb
 
	if(ob.m_pDispatch = this.m_pDispatch) Then
		return  This 
	End If
	 #Ifndef _FB_COM_VTBL_ 
	  ob.m_pDispatch->AddRef() 
	  If(m_pDispatch =  NULL)Then
		 m_pDispatch->Release() 
	  End If
	#Else
	  ob.m_pDispatch->lpvtbl->AddRef(ob.m_pDispatch) 
	  If(m_pDispatch =  NULL)Then
		 m_pDispatch->lpvtbl->Release(ob.m_pDispatch) 
	  End If
	#EndIf  
	m_pDispatch = ob.m_pDispatch
	return  This 
End Function


Function AutomationOb.RunMethod(oName As String,paramvalues as VARIANTARG Ptr, nParamCount As Integer) As VARIANT
	Dim varRes As VARIANT
   variantInit(@varRes)
   Dim As HRESULT hr= AutoWrap(DISPATCH_METHOD, @VarRes,m_pDispatch,AnsiToWide(StrPtr(oName)) ,paramvalues ,nParamCount)
	If hr=S_OK Then
  	    Return varRes
  Else
  	 	varRes.vt = VT_ERROR
		varRes.scode = -1
		return varRes
  EndIf
End Function
 
 Function AutomationOb.RunMethod(dipid As DISPID,paramvalues as VARIANTARG Ptr, nParamCount As Integer) As VARIANT
	Dim varRes As VARIANT
   variantInit(@varRes)
   Dim As HRESULT hr= AutoWrap(DISPATCH_METHOD, @VarRes,m_pDispatch,dipid,paramvalues ,nParamCount)
	If hr=S_OK Then
  	    Return varRes
  Else
  	 	varRes.vt = VT_ERROR
		varRes.scode = -1
		return varRes
  EndIf
End Function
 

 Function AutomationOb.GetProperty(oName As String,paramvalues as VARIANTARG Ptr, nParamCount As integer) As  VARIANT
 Dim varRes As VARIANT
  variantInit(@varRes)
  Dim As HRESULT hr= AutoWrap(DISPATCH_PROPERTYGET or DISPATCH_METHOD, @VarRes,m_pDispatch,AnsiToWide(StrPtr(oName)) , paramvalues,nParamCount)
  If hr=S_OK Then
  	Return varRes
  Else
  	 
		varRes.vt = VT_ERROR
		varRes.scode = -1
		return varRes
 
  EndIf
End Function

  Function AutomationOb.GetProperty(dipid As DISPID,paramvalues as VARIANTARG Ptr=NULL, nParamCount As Integer=0) As VARIANT
  	Dim varRes As VARIANT
   variantInit(@varRes)
   Dim As HRESULT hr= AutoWrap(DISPATCH_PROPERTYGET or DISPATCH_METHOD, @VarRes,m_pDispatch,dipid, paramvalues,nParamCount)
  If hr=S_OK Then
  	Return varRes
  Else
  	 
		varRes.vt = VT_ERROR
		varRes.scode = -1
		return varRes
 
  EndIf
  End Function

Function AutomationOb.PutProperty(oName As String,paramvalues as VARIANTARG Ptr, nParamCount As integer) As  Integer
 Dim As HRESULT hr= AutoWrap(DISPATCH_PROPERTYPUT , NULL,m_pDispatch,AnsiToWide(StrPtr(oName)) , paramvalues,nParamCount)
 If hr=S_OK Then
  	Return TRUE
  Else
		return FALSE
 EndIf
End Function

Function AutomationOb.PutProperty(dipid As DISPID,paramvalues as VARIANTARG Ptr, nParamCount As integer) As  Integer
 Dim As HRESULT hr= AutoWrap(DISPATCH_PROPERTYPUT , NULL,m_pDispatch,dipid , paramvalues,nParamCount)
 If hr=S_OK Then
  	Return TRUE
  Else
		return FALSE
 EndIf
End Function

Sub AutomationOb.InitializeDispatch(pDisp As IDispatch Ptr)
	if(NULL<>m_pDispatch)Then
		#Ifndef _FB_COM_VTBL_ 
		   m_pDispatch->Release()
		#Else
		   m_pDispatch->lpVtbl->Release(m_pDispatch)
		#EndIf
	End If
	m_pDispatch = pDisp
	#Ifndef _FB_COM_VTBL_ 
	    m_pDispatch->Addref()
	#Else
       m_pDispatch->lpVtbl->Addref(m_pDispatch)
   #EndIf
End Sub

 Function AutomationOb.GetNameID(oName As String) As Const VARIANT
 
	Dim As VARIANT vRes
	VariantInit(@vRes)
	if(0=m_pDispatch) then
		vRes.vt = VT_ERROR
		vRes.scode = -1
		return vRes
	End If	
	Dim As DISPID did
	Dim As HRESULT hr 
   Dim w As WString*120=oName
   Dim As LPOLESTR wname=@w
	#Ifndef _FB_COM_VTBL_ 
	   hr = m_pDispatch->GetIDsOfNames(@IID_NULL, @wName, 1, LOCALE_SYSTEM_DEFAULT, @did)
   #Else
      hr = m_pDispatch->GetIDsOfNames(m_pDispatch,@IID_NULL, @wName, 1, LOCALE_SYSTEM_DEFAULT, @did)
   #EndIf
   
	if(FAILED(hr))Then
		throw ole_exception(hr)
	End If
	vRes.vt = VT_I4
	vRes.lVal = did
	return vRes
 End Function
 
  
 
Function AutomationOb.GetIDispatch() As IDispatch Ptr
	return m_pDispatch 
End Function

Operator AutomationOb.Cast() As IDISPATCH Ptr
	 return m_pDispatch 
End Operator

tes_automationob.bas

Code: Select all

#include Once "win/ocidl.bi"
#Include Once "win/initguid.bi"
 
'================================================================================
'CLSID - fbpoint server?{73205EF0-6E5C-4384-B720-C2766B38E52E}
'================================================================================

Const CLSID_Calculs="{869CE9D0-BF3B-439A-9AA2-DDB46CF9E309}"     'Calculs object
Dim Shared As ZString*40 CLSID_POINTD="{5F02CF88-12BE-4240-9EEA-13D81DDDE441}"     'POINTD object

'================================================================================
'ProgID - fbpoint server?{73205EF0-6E5C-4384-B720-C2766B38E52E}
'================================================================================
Const ProgID_Calculs="FBpoint.Calculs.1"
Const ProgID_POINTD="FBpoint.POINTD.1"
 

Declare FUNCTION Msgbox(strMsg As STRING, strTitle AS String="", flag As Integer=0) AS Long
 
 


#Include Once "oleautomationob.bi"

Type  Calculs  extends AutomationOb 
	Declare  Function Addxy ( Byval x As double, Byval y As double) As double  
	Declare   Constructor()
	Declare Constructor(ByRef p As IDISPATCH Ptr)
End Type

  Constructor Calculs()
      base(CLSID_Calculs)
  End Constructor
  Constructor Calculs(ByRef p As IDISPATCH Ptr)
        base(p)
  End Constructor
Function Calculs.Addxy ( Byval x As double, Byval y As double) As double 
	Dim As VARIANT v(2) : VariantInit(@v(0))
	v(0).vt = VT_R8
	v(0).dblval  = x
	
	v(1).vt = VT_R8
	v(1).dblval  = y

	Return RunMethod("Addxy",@v(0),2).dblval
End Function

Type POINTD  extends AutomationOb
  Declare   Sub Affiche ()  
  Declare   Property x() As Double    
  Declare   property x(As Double  )  
  Declare   Property y() As Double    
  Declare   property y(As Double  )
  Declare Function Produit   () As double 
  Declare Function Norme()As Double
  Declare Function Angle()As Double
  Declare Property Name(Byval value As String) 
  Declare Property Name() As String  
  Declare Function Somme( Byval p1 As POINTD, Byval p2 As POINTD) As POINTD 
  Declare   property Calcul() As Calculs
  Declare   Constructor()
  Declare   Constructor(ByRef p As IDISPATCH Ptr)
  Declare   Destructor()
End Type


Sub POINTD.Affiche()  
	 RunMethod("Affiche")  
End Sub

    Property POINTD.x() As Double 
     	Dim As VARIANT v 
	   v=GetProperty("x")
    	Return v.dblval
     End Property
    
    Property POINTD.x(value As Double ) 
      Dim As VARIANT v : VariantInit(@v)
	   v.vt = VT_R8
	   v.dblval  = value
	   PutProperty("x", @v)
    End Property
    
    Property POINTD.y() As Double
    	Return GetProperty("y").dblval
     End Property
    
    Property POINTD.y(value As Double ) 
      Dim As VARIANT v : VariantInit(@v)
	   v.vt = VT_R8
	   v.dblval  = value
	   PutProperty("y", @v)
    End Property
    
    Function POINTD.Produit() As Double
    	Return RunMethod("Produit").dblval
    End Function
    
    Function POINTD.Norme()As Double
    	Return RunMethod("Norme").dblval
    End Function
    
   Function POINTD.Angle()As Double
   	Return RunMethod("Angle").dblval
   End Function
   
   Property POINTD.Name(Byval value As String)
      Dim As VARIANT v : VariantInit(@v)
	   Dim As WString*200 zvalue=value
	   v.vt = VT_BSTR
	   v.bstrval  = sysallocstring(@zvalue)
	   PutProperty("Name", @v)
   End Property
   
   Property POINTD.Name() As String 
       Return *Cast(WString Ptr,GetProperty("Name").bstrval)
   End Property
   
   Function POINTD.Somme(ByVal p1 As POINTD, Byval p2 As POINTD) As POINTD
   	 Dim As VARIANT v(2) : VariantInit(@v(0))
   	 v(0).vt=VT_DISPATCH
   	 v(0).pdispval= p1.GetIDispatch() 
   	 v(1).vt=VT_DISPATCH
   	 v(1).pdispval= p2.GetIDispatch()
   	  Dim pres As POINTD=POINTD(RunMethod("Somme",@v(0),2).pdispval)
   	  
   	 Return pres
   End Function
    
    property POINTD.Calcul() As Calculs
      Return GetProperty("Calculs").pdispval  
    End Property
    
  Constructor POINTD()
      base(CLSID_POINTD)
  End Constructor
  
  Constructor POINTD(ByRef p As IDISPATCH Ptr)
        base(p)
  End Constructor
  
  Destructor POINTD()
  End Destructor

   

DIM Shared Form1  AS HANDLE
DIM SHARED Ctrl1  AS HANDLE
CONST  ID_Ctr1 =  101


  Dim SHARED P1 as POINTD 
  Dim SHARED P2 as POINTD
 
FUNCTION Msgbox(strMsg As STRING, strTitle AS String="", flag As Integer=0) AS LONG
	Return MessageBox( 0, strMsg, strTitle, flag)
End Function

 
FUNCTION WindowProc(hWnd AS HWND, uMsg AS UINT, wParam AS WPARAM, lParam AS LPARAM) AS LRESULT

 
	SELECT Case uMsg
	 CASE WM_CLOSE
       oleUninitialize()
       
		Case WM_CREATE
			 
	
	        
	 Case WM_COMMAND
      If LoWord(wparam) = ID_Ctr1 THEN 
          DIM X As double,X2 AS Double
         Dim s As ZString*500
          P1.x=4 :P1.y=3
          P2.x=5 :P2.y=4
          s="P1(x,y)=: (" & P1.x & ", " & P1.y & ")" & Chr(13,10)
          s &="P2(x,y)=: (" & P2.x & ", " & P2.y & ")"  
           MSGBOX(s)
     
           MSGBOX("Produit: " & P1.Produit())  
           P1.Affiche()
         Dim cal As Calculs
          Msgbox "cal.Addxy(200,560): " &   cal.Addxy(200,560)
          Dim p As POINTD
          p=p.Somme(p1,P2)
          Msgbox "P(x,y)=: (" & P.x & ", " & P.y & ")"
      End If
     
     Case WM_DESTROY
        oleUninitialize()
        postquitMessage(0)
        
	End Select
	
	Return  DefWindowProc(hWnd, uMsg, wParam, lParam)

END FUNCTION

Function winMain(hinst As HINSTANCE,hprev As HINSTANCE,lpzcmd As ZString Ptr,icmdshow As Integer) As Integer
	
	  Oleinitialize(NULL)
	
	 
	Dim wc AS WNDCLASSEX
	wc.cbSize = SIZEOF(wc)
	wc.style = 0
	wc.lpfnWndProc =@WindowProc
	wc.cbClsExtra = 0
	wc.cbWndExtra = 0
	wc.hInstance = hInst
	wc.hbrBackground = Cast(HBRUSH,16)
	wc.lpszMenuName = NULL
	wc.lpszClassName = StrPtr("testfbcom.dll")
	wc.hCursor = LoadCursor(0, BYVAL IDC_ARROW)
	wc.hIcon = LoadIcon(0, BYVAL IDI_APPLICATION)
	wc.hIconSm = 0
	RegisterClassEx(@wc)

	 
	
	DIM title As String = "  COM Client test"
	Form1 = CreateWindowEx(0, "testfbcom.dll" , title, _
		                    WS_CLIPCHILDREN OR WS_VISIBLE OR WS_SIZEBOX OR WS_CAPTION Or _
		                    WS_SYSMENU OR WS_MINIMIZEBOX Or WS_MAXIMIZEBOX, 100, 100, 500, _
		                    400, HWND_DESKTOP, 0, hInst, BYVAL 0)

	Ctrl1 = CreateWindowEx(0, "Button", "Call Affichage function", WS_CHILD OR WS_VISIBLE Or _
		                    WS_BORDER, 216, 38, 200, 25, Form1, Cast(HMENU,ID_Ctr1), hInst, BYVAL 0)

	 

	ShowWindow(Form1, 1)
	

	Dim Msg AS MSG
	DO WHILE GetMessage(@Msg, 0, 0, 0)
		TranslateMessage(@Msg)
		DispatchMessage(@Msg)
	Loop
	
	Return msg.wparam
	
END Function
End winMain(getmoduleHandle(0),NULL,Command,SW_SHOW)

you need fbpoint.dll new one

aloberoger · Post by **aloberoger** » Aug 28, 2015 16:46

Understanding offset of in vtbl Interfaces
reading this file you can notice simulation of inheritance :
FBEx6.bi

Code: Select all

/'******************************************************************************
 Code machine generated by FBTLBREADER
 Copyright (c) 2014 Alober  All Rights Reserved.
 Date: 08-19-2015  Time: 19:28:40
 contact: aloberr@yahoo.fr
****************************************************************************** '/


#include once "windows.bi"
#include once "Win/ole2.bi"


/'******************************************************************************
 LIBRARY NAME: FBEx6lib
    path = C:\WINDOWS\system32\FBEx6.dll
    libiid = {8A25007F-CBFD-4D30-8185-9DE0EA5FE58E}
    szDocString  = FBEx6 server library
    version = 1.0
    szHelpFile = 
    dwHelpContext = 0
    lcid  = 0
    syskind = SYS_WIN32
    wMajorVerNum = 1
    wMinorVerNum = 0
    wLibFlags =  [HasDiskImage]
    typeinfoCount  = 8
****************************************************************************** '/




#define W2Ansi(A,W)     WideCharToMultiByte(CP_ACP,0,W,-1,A,2047,0,0)
#define A2Wide(A,W,L)   MultiByteToWideChar(CP_ACP,0,A,-1,W,L)
#define CompareIID(A,B) memcmp (A,B,sizeof (GUID))


Declare Function StrToBSTR(cnv_string As String) As BSTR
Declare Function CheckError(hr As HRESULT) As String
Declare Sub ShowOleError OverLoad  ( hr As HRESULT, addit As String="")


Declare Function CreateObject OverLoad (ByVal ProgID as String,ByVal ppdisp As IDISPATCH Ptr Ptr) as HRESULT
Declare Function CreateObject(ByVal ProgID as String,ByVal ppunk As IUNKNOWN Ptr Ptr) as HRESULT
Declare  Function CreateObject(ByVal ProgID as string) as VARIANT    ' ProgID is progid or clsid string result is variant(iunknown or idispatch)








DIM SHARED AS CONST CLSID  CLSID_SchoolMember = (&h5E085128, &h6C53, &h4361, {&h83, &hE7, &hCA, &h5B, &hF8, &hFB, &h51, &h1B})
DIM SHARED AS CONST IID  IID_ISchoolMember = (&h1C853201, &h622D, &h4A1F, {&h96, &hAD, &h9C, &h68, &h9C, &hCC, &h99, &hBC})
DIM SHARED AS CONST CLSID  CLSID_Teacher = (&h17C097FA, &h77B8, &h48CF, {&h8F, &h2, &hBC, &h63, &h22, &h13, &h8C, &h16})
DIM SHARED AS CONST IID  IID_ITeacher = (&hFE05A53E, &hEE99, &h4010, {&h8D, &h87, &h7, &hA6, &h3D, &h12, &h36, &h78})
DIM SHARED AS CONST CLSID  CLSID_Student = (&h5F937F76, &h3722, &h4F0B, {&hB2, &hFC, &h62, &h18, &h71, &hBE, &h66, &hF7})
DIM SHARED AS CONST IID  IID_IStudent = (&h341AF897, &hF764, &h45E1, {&h9A, &hD4, &h28, &h20, &hAE, &hAB, &h68, &h6})
DIM SHARED AS CONST CLSID  CLSID_StudentFree = (&h5F937F76, &h3722, &h4F0B, {&hB2, &hFC, &h62, &h18, &h71, &hBE, &h66, &hF8})
DIM SHARED AS CONST IID  IID_IStudentFree = (&h341AF897, &hF764, &h45E1, {&h9A, &hD4, &h28, &h20, &hAE, &hAB, &h68, &h7})


#define PROGID_SchoolMember  "FBEx6lib.SchoolMember.1"
#define INDPROGID_SchoolMember  "FBEx6lib.SchoolMember"
#define PROGID_Teacher  "FBEx6lib.Teacher.1"
#define INDPROGID_Teacher  "FBEx6lib.Teacher"
#define PROGID_Student  "FBEx6lib.Student.1"
#define INDPROGID_Student  "FBEx6lib.Student"
#define PROGID_StudentFree  "FBEx6lib.StudentFree.1"
#define INDPROGID_StudentFree  "FBEx6lib.StudentFree"






'*******************************************************************************
'Interface Name  = ISchoolMember
'*******************************************************************************
'memid = 0
'DocString = 
'iid = {1C853201-622D-4A1F-96AD-9C689CCC99BC}
'typekind  = INTERFACE
'Attributes  =  [Hidden] [Dual] [Nonextensible] [Oleautomation] [Dispatchable]
'Number of Functions: 6
'*******************************************************************************


Type ISchoolMember Extends IDispatch
    Declare abstract Function Init(BYVAL prm_name AS BSTR Ptr,BYVAL prm_age AS LONG) AS HRESULT    ' No help avalaible
    Declare abstract Function get_Name(BYVAL prmretval AS BSTR Ptr) AS HRESULT    ' No help avalaible
    Declare abstract Function put_Name(BYVAL prmretval AS BSTR) AS HRESULT    ' No help avalaible
    Declare abstract Function get_age(BYVAL prmretval AS LONG Ptr) AS HRESULT    ' No help avalaible
    Declare abstract Function put_age(BYVAL prmretval AS LONG) AS HRESULT    ' No help avalaible
    Declare abstract Function Show() AS HRESULT    ' No help avalaible
End Type 




'*******************************************************************************
'Interface Name  = ITeacher
'*******************************************************************************
'memid = 1
'DocString = 
'iid = {FE05A53E-EE99-4010-8D87-07A63D123678}
'typekind  = INTERFACE
'Attributes  =  [Hidden] [Dual] [Nonextensible] [Oleautomation] [Dispatchable]
'Number of Functions: 4
'*******************************************************************************


Type ITeacher Extends ISchoolMember
    Declare abstract Function Construct(BYVAL prm_name AS BSTR Ptr,BYVAL prm_age AS LONG,BYVAL prm_salary AS LONG) AS HRESULT    ' No help avalaible
    Declare abstract Function get_salary(BYVAL prmretval AS LONG Ptr) AS HRESULT    ' No help avalaible
    Declare abstract Function put_salary(BYVAL prmretval AS LONG) AS HRESULT    ' No help avalaible
    Declare abstract Function Tell() AS HRESULT    ' No help avalaible
End Type 




'*******************************************************************************
'Interface Name  = IStudent
'*******************************************************************************
'memid = 2
'DocString = 
'iid = {341AF897-F764-45E1-9AD4-2820AEAB6806}
'typekind  = INTERFACE
'Attributes  =  [Hidden] [Dual] [Nonextensible] [Oleautomation] [Dispatchable]
'Number of Functions: 4
'*******************************************************************************


Type IStudent Extends ISchoolMember
    Declare abstract Function Construct(BYVAL prm_name AS BSTR Ptr,BYVAL prm_age AS LONG,BYVAL prm_marks AS LONG) AS HRESULT    ' No help avalaible
    Declare abstract Function get_marks(BYVAL prmretval AS LONG Ptr) AS HRESULT    ' No help avalaible
    Declare abstract Function put_marks(BYVAL prmretval AS LONG) AS HRESULT    ' No help avalaible
    Declare abstract Function Tell() AS HRESULT    ' No help avalaible
End Type 




'*******************************************************************************
'Interface Name  = IStudentFree
'*******************************************************************************
'memid = 3
'DocString = 
'iid = {341AF897-F764-45E1-9AD4-2820AEAB6807}
'typekind  = INTERFACE
'Attributes  =  [Hidden] [Dual] [Nonextensible] [Oleautomation] [Dispatchable]
'Number of Functions: 1
'*******************************************************************************


Type IStudentFree Extends IStudent
    Declare abstract Function paiement(BYVAL prmretval AS LONG Ptr) AS HRESULT    ' montant payed by Freestudent
End Type 






'******************************************************************************
' Helper Functions - Interface Creation
'******************************************************************************


 Dim shared IsOleInitialized as BOOLEAN=FALSE




FUNCTION Create_ISchoolMember() As ISchoolMember Ptr
dim hr As HRESULT
Dim As IUNKNOWN Ptr  punk  = NULL
If IsOleInitialized=FALSE then OleInitialize(NULL):IsOleInitialized=TRUE: ENDIF
Dim pobj As ISchoolMember Ptr
  hr=CoCreateInstance(@CLSID_SchoolMember, NULL, CLSCTX_SERVER, @IID_IUNKNOWN,cast(LPVOID ptr,@punk))
   if hr=S_OK then 
      hr = punk->QueryInterface(@IID_ISchoolMember, cast(LPVOID Ptr,@pobj)) 
      If hr=S_OK then  
           punk->Release()
           Return pobj
      else
         Return Cast(ISchoolMember Ptr,punk)
      EndIf	
 Else 
   MessageBox NULL,"Error number hr=" & hr,"Can't create ISchoolMember",0
   Return NULL
END IF
END FUNCTION




FUNCTION Create_ITeacher() As ITeacher Ptr
dim hr As HRESULT
Dim As IUNKNOWN Ptr  punk  = NULL
If IsOleInitialized=FALSE then OleInitialize(NULL):IsOleInitialized=TRUE: ENDIF
Dim pobj As ITeacher Ptr
  hr=CoCreateInstance(@CLSID_Teacher, NULL, CLSCTX_SERVER, @IID_IUNKNOWN,cast(LPVOID ptr,@punk))
   if hr=S_OK then 
      hr = punk->QueryInterface(@IID_ITeacher, cast(LPVOID Ptr,@pobj)) 
      If hr=S_OK then  
           punk->Release()
           Return pobj
      else
         Return Cast(ITeacher Ptr,punk)
      EndIf	
 Else 
   MessageBox NULL,"Error number hr=" & hr,"Can't create ITeacher",0
   Return NULL
END IF
END FUNCTION




FUNCTION Create_IStudent() As IStudent Ptr
dim hr As HRESULT
Dim As IUNKNOWN Ptr  punk  = NULL
If IsOleInitialized=FALSE then OleInitialize(NULL):IsOleInitialized=TRUE: ENDIF
Dim pobj As IStudent Ptr
  hr=CoCreateInstance(@CLSID_Student, NULL, CLSCTX_SERVER, @IID_IUNKNOWN,cast(LPVOID ptr,@punk))
   if hr=S_OK then 
      hr = punk->QueryInterface(@IID_IStudent, cast(LPVOID Ptr,@pobj)) 
      If hr=S_OK then  
           punk->Release()
           Return pobj
      else
         Return Cast(IStudent Ptr,punk)
      EndIf	
 Else 
   MessageBox NULL,"Error number hr=" & hr,"Can't create IStudent",0
   Return NULL
END IF
END FUNCTION




FUNCTION Create_IStudentFree() As IStudentFree Ptr
dim hr As HRESULT
Dim As IUNKNOWN Ptr  punk  = NULL
If IsOleInitialized=FALSE then OleInitialize(NULL):IsOleInitialized=TRUE: ENDIF
Dim pobj As IStudentFree Ptr
  hr=CoCreateInstance(@CLSID_StudentFree, NULL, CLSCTX_SERVER, @IID_IUNKNOWN,cast(LPVOID ptr,@punk))
   if hr=S_OK then 
      hr = punk->QueryInterface(@IID_IStudentFree, cast(LPVOID Ptr,@pobj)) 
      If hr=S_OK then  
           punk->Release()
           Return pobj
      else
         Return Cast(IStudentFree Ptr,punk)
      EndIf	
 Else 
   MessageBox NULL,"Error number hr=" & hr,"Can't create IStudentFree",0
   Return NULL
END IF
END FUNCTION


'******************************************************************************
' Helper Functions - General
'******************************************************************************


Function StrToBSTR(cnv_string As String) As BSTR
 Dim sb As BSTR
 Dim As Integer n
 n = (MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, strptr(cnv_string), -1, NULL, 0))-1
 sb=SysAllocStringLen(sb,n)
 MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, strptr(cnv_string), -1, sb, n)
 Return sb
End Function




Function CheckError(hr As HRESULT) As String
 Dim As Any Ptr pMsg 
 FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,NULL,hr, _ 
	             MAKELANGID(LANG_NEUTRAL,SUBLANG_DEFAULT),Cast(LPTSTR,@pMsg),0,NULL)
 CheckError= " : Error(&h" & Hex(hr) & "): " & *Cast(ZString Ptr,pMsg)
 LocalFree(pMsg)
End Function



Sub ShowOleError OverLoad  ( hr As HRESULT, addit As String="")
  Dim serr As String
  If hr=s_ok Then Exit Sub
  serr=addit & " " & CheckError(hr)
  MessageBox (getactiveWindow(),serr,"OLE ERROR ",MB_ICONERROR Or MB_TASKMODAL)
End Sub


Function CreateObject OverLoad (ByVal ProgID as String,ByVal ppdisp As IDISPATCH Ptr Ptr) as HRESULT


Dim As IDISPATCH Ptr pdisp = NULL
 Dim As IUNKNOWN Ptr  punk  = NULL
 Dim as HRESULT hr


     If IsoleInitialized=false Then 
   	  oleInitialize(NULL)
   	  IsoleInitialized=TRUE
     EndIf


      *ppdisp=NULL


      Dim As  CLSID clsid
      hr=CLSIDFromProgID(WStr(ProgID), @clsid)
      If clsid=CLSID_NULL Then hr=CLSIDFromString(WStr(ProgID), @clsid)
      If clsid=CLSID_NULL Then goto errorn


      hr = CoCreateInstance(@clsid, NULL, CLSCTX_SERVER, @IID_IUNKNOWN, cast(LPVOID Ptr,@punk))


      If  FAILED(hr)  then	goto errorn 
   	 #If Not Defined( _FB_COM_VTBL_)
   	   hr = punk->QueryInterface(@IID_IDispatch, cast(LPVOID Ptr,@pdisp)) 
   	 #Else 
   	   hr = punk->lpvtbl->QueryInterface(punk,@IID_IDispatch, cast(LPVOID Ptr,@pdisp)) 
	    #EndIf
	   If  FAILED(hr)  Then goto errorn 


	   *ppdisp = pdisp  
	   #If Not Defined( _FB_COM_VTBL_)
	      punk->Release()
	   #Else 
   	   punk->lpvtbl->Release(punk) 
      #EndIf
      Return NOERROR 


errorn: 
	      ShowOleError(hr,"CreateObject(ProgID)")
   #If Not Defined( _FB_COM_VTBL_)
	   If (punk)  Then punk->Release()  
	   If (pdisp) Then pdisp->Release() 
	#Else 
   	If (punk)  Then punk->lpvtbl->Release(punk) 
   	If (pdisp) Then pdisp->lpvtbl->Release(pdisp)
   #EndIf
	return hr  


end Function


Function CreateObject(ByVal ProgID as String,ByVal ppunk As IUNKNOWN Ptr Ptr) as HRESULT


 Dim As IUNKNOWN Ptr  punk  = NULL 
 Dim as HRESULT hr


      If IsoleInitialized=false Then 
   	  oleInitialize(NULL)
   	  IsoleInitialized=TRUE
      EndIf


     *ppunk=NULL


      Dim As  CLSID clsid
      hr=CLSIDFromProgID(WStr(ProgID), @clsid)
      If clsid=CLSID_NULL Then hr=CLSIDFromString(WStr(ProgID), @clsid)
      If clsid=CLSID_NULL Then goto errorn


      hr = CoCreateInstance(@clsid, NULL, CLSCTX_SERVER, @IID_IUNKNOWN, cast(LPVOID Ptr,@punk))


      If  FAILED(hr)  then	goto errorn 


	   *ppunk = punk  


      Return NOERROR 


errorn: 
	      ShowOleError(hr,"CreateObject(ProgID)")
	If (punk)  Then 
	  #If Not Defined( _FB_COM_VTBL_)
	       punk->Release() 
	  #Else 
   	    punk->lpvtbl->Release(punk) 
     #EndIf
	EndIf


	return hr 


end Function


 Function CreateObject(ByVal ProgID as string) as VARIANT    ' ProgID is progid or clsid string result is variant(iunknown or idispatch)
 Dim As  HRESULT hr  
 Dim As IUNKNOWN Ptr  punk  = NULL 


     If IsoleInitialized=false Then 
   	  oleInitialize(NULL)
   	  IsoleInitialized=TRUE
      EndIf


   Dim as VARIANT Vvar
   VariantInit(@Vvar) 


       Dim As  CLSID clsid 
        hr=CLSIDFromProgID(WStr(ProgID), @clsid) 
        If clsid=CLSID_NULL Then hr=CLSIDFromString(WStr(ProgID), @clsid)
       If clsid=CLSID_NULL Then 
        	  	Vvar .vt = VT_ERROR
		      Vvar .scode = -1
	      ShowOleError(hr,"CreateObject(ProgID)")
		      Return Vvar 
       EndIf
       hr = CoCreateInstance(@clsid, NULL,CLSCTX_SERVER,@IID_IUNKNOWN, cast(LPVOID Ptr,@punk))
       if(FAILED(hr))then
	      ShowOleError(hr,"CreateObject(ProgID)")
           Exit Function 
       end if
       #If Not Defined( _FB_COM_VTBL_)
          hr = punk->QueryInterface(@IID_IDispatch, cast(LPVOID Ptr,@Vvar.pdispval))
       #Else 
  	     hr=punk->lpvtbl->QueryInterface(punk,@IID_IDispatch, cast(LPVOID Ptr,@Vvar.pdispval))
       #EndIf 
	     If (FAILED(hr)) Then 
	     	  	Vvar.vt = VT_UNKNOWN
		      Vvar.punkval = punk
		      Return Vvar
	     EndIf
 	     #If Not Defined( _FB_COM_VTBL_)
	         punk->Release() 
	     #Else 
   	      If (punk)  Then punk->lpvtbl->Release(punk) 
        #EndIf


        Vvar.vt = VT_DISPATCH
      return Vvar
end Function

this file is obtained for abstract methods, if you prefer vtbl methods, you can have the following one

Code: Select all

Type ISchoolMember as IISchoolMember
Type ITeacher as IITeacher
Type IStudent as IIStudent

 
Type ISchoolMembervTbl_  As ISchoolMembervTbl
Type IISchoolMember
	lpvtbl As ISchoolMembervTbl_ Ptr
End Type

Type ISchoolMembervTbl
	QueryInterface As Function (pThis As ISchoolMember ptr ,riid As GUID ptr,ppvObj As Any ptr) As hResult
	AddRef As Function (pThis As ISchoolMember ptr ) As HRESULT
	Release As Function (pThis As ISchoolMember ptr) As HRESULT
	GetTypeInfoCount As Function(pThis As ISchoolMember ptr,pctinfo As UINT Ptr) As HRESULT
	GetTypeInfo As Function(pThis As ISchoolMember ptr,itinfo As UINT,lcid As LCID,pptinfo As lpvoid Ptr) As HRESULT
	GetIDsOfNames As Function(pThis As ISchoolMember ptr,riid As GUID Ptr,rgszNames As BYTE Ptr Ptr,cNames As UINT,lcid As LCID,rgdispid As DISPID Ptr) As HRESULT
	Invoke As Function(pThis As ISchoolMember ptr,dispidMember As DISPID,riid As GUID Ptr,lcid As LCID,wFlags As USHORT,pdispparams As DISPPARAMS Ptr,byval pvarResult As VARIANT Ptr,pexcepinfo As EXCEPINFO Ptr,puArgErr As UINT Ptr) As HRESULT
	Init As Function(pThis As ISchoolMember ptr, Byval _name As BSTR Ptr, Byval _age As long) As HRESULT     'No help avalaible
	get_Name As Function(pThis As ISchoolMember ptr, Byval retval As BSTR Ptr) As HRESULT     'No help avalaible
	put_Name As Function(pThis As ISchoolMember ptr, Byval retval As BSTR) As HRESULT     'No help avalaible
	get_age As Function(pThis As ISchoolMember ptr, Byval retval As long Ptr) As HRESULT     'No help avalaible
	put_age As Function(pThis As ISchoolMember ptr, Byval retval As long) As HRESULT     'No help avalaible
	Show As Function(pThis As ISchoolMember ptr) As HRESULT     'No help avalaible
End Type

 
Type ITeachervTbl_  As ITeachervTbl
Type IITeacher
	lpvtbl As ITeachervTbl_ Ptr
End Type

Type ITeachervTbl
	QueryInterface As Function (pThis As ITeacher ptr ,riid As GUID ptr,ppvObj As Any ptr) As hResult
	AddRef As Function (pThis As ITeacher ptr ) As HRESULT
	Release As Function (pThis As ITeacher ptr) As HRESULT
	GetTypeInfoCount As Function(pThis As ITeacher ptr,pctinfo As UINT Ptr) As HRESULT
	GetTypeInfo As Function(pThis As ITeacher ptr,itinfo As UINT,lcid As LCID,pptinfo As lpvoid Ptr) As HRESULT
	GetIDsOfNames As Function(pThis As ITeacher ptr,riid As GUID Ptr,rgszNames As BYTE Ptr Ptr,cNames As UINT,lcid As LCID,rgdispid As DISPID Ptr) As HRESULT
	Invoke As Function(pThis As ITeacher ptr,dispidMember As DISPID,riid As GUID Ptr,lcid As LCID,wFlags As USHORT,pdispparams As DISPPARAMS Ptr,byval pvarResult As VARIANT Ptr,pexcepinfo As EXCEPINFO Ptr,puArgErr As UINT Ptr) As HRESULT
	Offset52(23) As Byte
	Construct As Function(pThis As ITeacher ptr, Byval _name As BSTR Ptr, Byval _age As long, Byval _salary As long) As HRESULT     'No help avalaible
	get_salary As Function(pThis As ITeacher ptr, Byval retval As long Ptr) As HRESULT     'No help avalaible
	put_salary As Function(pThis As ITeacher ptr, Byval retval As long) As HRESULT     'No help avalaible
	Tell As Function(pThis As ITeacher ptr) As HRESULT     'No help avalaible
End Type

 
Type IStudentvTbl_  As IStudentvTbl
Type IIStudent
	lpvtbl As IStudentvTbl_ Ptr
End Type

Type IStudentvTbl
	QueryInterface As Function (pThis As IStudent ptr ,riid As GUID ptr,ppvObj As Any ptr) As hResult
	AddRef As Function (pThis As IStudent ptr ) As HRESULT
	Release As Function (pThis As IStudent ptr) As HRESULT
	GetTypeInfoCount As Function(pThis As IStudent ptr,pctinfo As UINT Ptr) As HRESULT
	GetTypeInfo As Function(pThis As IStudent ptr,itinfo As UINT,lcid As LCID,pptinfo As lpvoid Ptr) As HRESULT
	GetIDsOfNames As Function(pThis As IStudent ptr,riid As GUID Ptr,rgszNames As BYTE Ptr Ptr,cNames As UINT,lcid As LCID,rgdispid As DISPID Ptr) As HRESULT
	Invoke As Function(pThis As IStudent ptr,dispidMember As DISPID,riid As GUID Ptr,lcid As LCID,wFlags As USHORT,pdispparams As DISPPARAMS Ptr,byval pvarResult As VARIANT Ptr,pexcepinfo As EXCEPINFO Ptr,puArgErr As UINT Ptr) As HRESULT
	Offset52(23) As Byte
	Construct As Function(pThis As IStudent ptr, Byval _name As BSTR Ptr, Byval _age As long, Byval _marks As long) As HRESULT     'No help avalaible
	get_marks As Function(pThis As IStudent ptr, Byval retval As long Ptr) As HRESULT     'No help avalaible
	put_marks As Function(pThis As IStudent ptr, Byval retval As long) As HRESULT     'No help avalaible
	Tell As Function(pThis As IStudent ptr) As HRESULT     'No help avalaible
End Type

with the first method test is simple, with the second the usage is also simple except the functions implemented on parent interface

Code: Select all

#Include Once "win/ole2.bi"
#Include Once "FBEX6_vtable.bi"


Dim m As ISchoolMember Ptr

Dim t As ITeacher ptr


oleinitialize(NULL)
 m=Create_ISchoolMember()
 
 
 Dim bname As BSTR=StrToBSTR("MEMBER 1")
 
 m->lpvtbl->Init(m,@bname,43) 
 
 sysfreestring(bname)
 m->lpvtbl->Show(m)
 
 t=Create_ITeacher()
 Print t
 bname =StrToBSTR("TEACHER 1")
 't->Init(@bname,45)         
 't->lpvtbl->Offset52(23)->put_Name(Cast(ISchoolMember Ptr,t),bname)
 t->lpvtbl->tell(t)
 t->lpvtbl->Release(t)
 sysfreestring(bname)
 
 m->lpvtbl->Release(m)
 
 
 Print " NORMAL END"
 
 Sleep
 
 oleuninitialize()

I don't see how to call the parents interface methods
't->Init(@bname,45)
't->lpvtbl->Offset52(23)->put_Name(Cast(ISchoolMember Ptr,t),bname)
if somebody have nkowledge about

aloberoger · Post by **aloberoger** » Nov 07, 2015 10:07

powerbasic call vtbl method with offset, can FB do the same?
heare is the update of FBTLBWTR
http://www.2shared.com/file/LrbH1WOm/po ... _2015.html

enjoy

aloberoger · Post by **aloberoger** » Jan 07, 2016 8:51

This Example Show how To :
- use vtbl Class Flexgrid
- Colors
- Events With Vtbl Class

Click On the grid and see what happen

But the things are simpler with the abstract classes

make sure you have 6 files

comhelper.bi

Code: Select all

#Include Once "crt.bi"
#Include Once "win/olectl.bi"

#define W2Ansi(A,W)  WideCharToMultiByte(CP_ACP,0,W,-1,A,2047,0,0)
#define A2Wide(A,W,L)  MultiByteToWideChar(CP_ACP,0,A,-1,W,L)
#define CompareIID(A,B) memcmp (A,B,sizeof (GUID))

type Font as IFontDisp        ' or IFONT
type Picture as IPictureDisp  ' OR IPICTURE 


Declare Function StrToBSTR(cnv_string As String) As BSTR
 

Declare Function OleCreateFontDisp OverLoad (BYVAL szFontName AS STRING,ByVal cySize AS float=10, _      
                                 ByVal fWeight AS INTEGER=FW_NORMAL,BYVAL fCharset AS INTEGER=FALSE,BYVAL fItalic AS LONG=FALSE, BYVAL fUnderline AS Long=FALSE, _   
                                 ByVal fStrikethrough AS LONG=FALSE,ByVal pFont AS IFontDisp Ptr Ptr ) AS HRESULT  

Declare Function OleCreateFontDisp (BYVAL szFontName AS STRING,ByVal cySize AS float=10, _       
                                    ByVal fWeight AS INTEGER=FW_NORMAL,BYVAL fCharset AS INTEGER=FALSE,BYVAL fItalic AS LONG=FALSE, BYVAL fUnderline AS Long=FALSE, _     
                                    ByVal fStrikethrough AS LONG=FALSE) AS IFontDisp Ptr  

Declare FUNCTION OleCreatePictureDisp overload (ByVal hPicHandle AS HANDLE, _             ' __in  Handle of the icon or bitmap
                                       ByVal picType AS UINT, _                  ' __in  Picture type: PICTYPE_BITMAP or PICTYPE_ICON
                                       ByVal fOwn AS INTEGER, _                   ' __in  TRUE or FALSE
                                       ByVAL pPicture AS IPictureDisp Ptr PTR _    ' __out The picture object
                                       ) AS HRESULT  
Declare FUNCTION OleCreatePictureDisp (ByVal hPicHandle AS HANDLE, _ 
                               ByVal picType AS UINT, _    
                               ByVal fOwn AS INTEGER) As IPictureDisp Ptr 
/'********************************************************************************************
 Forward Defines ******************************************************************************************** '/


Dim Shared IsOleInitialized As BOOL=FALSE






'******************************************************************************
' Helper Functions - General
'******************************************************************************

Function StrToBSTR(cnv_string As String) As BSTR
 Dim sb As BSTR
 Dim As Integer n
 n = (MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, StrPtr(cnv_string), -1, NULL, 0))-1
 sb=SysAllocStringLen(sb,n)
 MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED,  StrPtr(cnv_string), -1, sb, n)
 Return sb
End Function



' ========================================================================================
' Creates a standard IFontDisp object
' ========================================================================================
FUNCTION OleCreateFontDisp (BYVAL szFontName AS STRING,ByVal cySize AS float=10, _      
                            ByVal fWeight AS INTEGER=FW_NORMAL,BYVAL fCharset AS INTEGER=FALSE,BYVAL fItalic AS LONG=FALSE, BYVAL fUnderline AS Long=FALSE, _    
                            ByVal fStrikethrough AS LONG=FALSE,ByVal pFont AS IFontDisp Ptr Ptr ) AS HRESULT   
   Dim tf AS FONTDESC
   Dim bstrFontname As BSTR
   bstrFontname=strToBstr(szFontName)
  
   tf.cbSizeOfStruct = SIZEOF(FONTDESC)
   tf.lpstrName =  bstrFontname 
   tf.cySize.int64 = cySize*10000
   tf.sWeight = fWeight
   tf.sCharset = fCharset
   tf.fItalic = fItalic
   tf.fUnderline = fUnderline
   tf.fStrikethrough = fStrikethrough
   FUNCTION = OleCreateFontIndirect(@tf, @IID_IDispatch, pFont)
 sysfreestring(bstrFontname)
END FUNCTION

FUNCTION OleCreateFontDisp (BYVAL szFontName AS STRING,ByVal cySize AS float=10, _    
                            ByVal fWeight AS INTEGER=FW_NORMAL,BYVAL fCharset AS INTEGER=FALSE,BYVAL fItalic AS LONG=FALSE, BYVAL fUnderline AS Long=FALSE, _    
                            ByVal fStrikethrough AS LONG=FALSE) AS IFontDisp Ptr 
  Dim p AS IFontDisp Ptr  
  OleCreateFontDisp (szFontName,cySize,fWeight ,fCharset,fItalic,fUnderline,fStrikethrough,@p) 
   Return P    
END Function


' ========================================================================================
' Creates a standard IPictureDisp object.
' ========================================================================================
FUNCTION OleCreatePictureDisp overload (ByVal hPicHandle AS HANDLE, _        
                               ByVal picType AS UINT, _             
                               ByVal fOwn AS INTEGER, _              
                               ByVAL pPicture AS IPictureDisp Ptr PTR  _ 
                               ) AS HRESULT       
  Dim tpd AS PICTDESC 
  IF hPicHandle = 0 THEN return  E_POINTER  
   SELECT CASE picType
  	CASE  PICTYPE_BITMAP        ' Bitmap
        tpd.bmp.hbitmap = hPicHandle
  	CASE  PICTYPE_ICON          ' Icon
        tpd.icon.hicon = hPicHandle
  	CASE ELSE
        FUNCTION =  E_INVALIDARG
        EXIT FUNCTION
  END SELECT
  tpd.cbSizeOfStruct = SIZEOF(PICTDESC)
  tpd.picType = picType
  IF fOwn THEN fOwn = -1
  FUNCTION = OleCreatePictureIndirect(@tpd, @IID_IDispatch, fOwn, pPicture)
END Function
FUNCTION OleCreatePictureDisp (ByVal hPicHandle AS HANDLE, _ 
                               ByVal picType AS UINT, _    
                               ByVal fOwn AS INTEGER) As IPictureDisp Ptr 
 Dim As IPictureDisp Ptr p
 Dim As HRESULT hr=OleCreatePictureDisp (hPicHandle,picType,fOwn,@p)
 Return p
End Function

aloberoger · Post by **aloberoger** » Jan 07, 2016 8:53

msflxgrd.bi

Code: Select all


' Enumerations'********************************************************************************************
Enum OLEDragConstants
	 flexOLEDragManual = 0
	 flexOLEDragAutomatic = 1
End Enum 
Enum OLEDropConstants
	 flexOLEDropNone = 0
	 flexOLEDropManual = 1
End Enum 
Enum DragOverConstants
	 flexEnter = 0
	 flexLeave = 1
	 flexOver = 2
End Enum 
Enum ClipBoardConstants
	 flexCFText = 1
	 flexCFBitmap = 2
	 flexCFMetafile = 3
	 flexCFDIB = 8
	 flexCFPalette = 9
	 flexCFEMetafile = 14
	 flexCFFiles = 15
	 flexCFRTF = -16639
End Enum 
Enum OLEDropEffectConstants
	 flexOLEDropEffectNone = 0
	 flexOLEDropEffectCopy = 1
	 flexOLEDropEffectMove = 2
	 flexOLEDropEffectScroll = -2147483648
End Enum 
Enum ErrorConstants
	 flexerrIllegaFunctionCall = 5
	 flexerrObjIllegalUse = 425
	 flexerrClipInvalidFormat = 461
	 flexerrDataObjectLocked = 672
	 flexerrExpectedAnArgument = 673
	 flexerrRecursiveOLEDrag = 674
	 flexerrUserFormatNotBinArray = 675
	 flexerrDataNotSetForFormat = 676
	 flexerrUnknownError = 600
	 flexerrSubscript = 381
	 flexerrBadValue = 380
	 flexerrGetNotSupported = 394
	 flexerrSetNotPermitted = 387
	 flexerrOutOfMemory = 7
	 flexerrVB30000 = 30000
	 flexerrVB30001 = 30001
	 flexerrVB30002 = 30002
	 flexerrVB30004 = 30004
	 flexerrVB30005 = 30005
	 flexerrVB30006 = 30006
	 flexerrVB30008 = 30008
	 flexerrVB30009 = 30009
	 flexerrVB30010 = 30010
	 flexerrVB30011 = 30011
	 flexerrVB30013 = 30013
	 flexerrVB30014 = 30014
	 flexerrVB30015 = 30015
	 flexerrVB30016 = 30016
	 flexerrVB30017 = 30017
End Enum 
Enum AppearanceSettings
	 flexFlat = 0
	 flex3D = 1
End Enum 
Enum BorderStyleSettings
	 flexBorderNone = 0
	 flexBorderSingle = 1
End Enum 
Enum FocusRectSettings
	 flexFocusNone = 0
	 flexFocusLight = 1
	 flexFocusHeavy = 2
End Enum 
Enum HighLightSettings
	 flexHighlightNever = 0
	 flexHighlightAlways = 1
	 flexHighlightWithFocus = 2
End Enum 
Enum ScrollBarsSettings
	 flexScrollBarNone = 0
	 flexScrollBarHorizontal = 1
	 flexScrollBarVertical = 2
	 flexScrollBarBoth = 3
End Enum 
Enum TextStyleSettings
	 flexTextFlat = 0
	 flexTextRaised = 1
	 flexTextInset = 2
	 flexTextRaisedLight = 3
	 flexTextInsetLight = 4
End Enum 
Enum FillStyleSettings
	 flexFillSingle = 0
	 flexFillRepeat = 1
End Enum 
Enum GridLineSettings
	 flexGridNone = 0
	 flexGridFlat = 1
	 flexGridInset = 2
	 flexGridRaised = 3
End Enum 
Enum SelectionModeSettings
	 flexSelectionFree = 0
	 flexSelectionByRow = 1
	 flexSelectionByColumn = 2
End Enum 
Enum MergeCellsSettings
	 flexMergeNever = 0
	 flexMergeFree = 1
	 flexMergeRestrictRows = 2
	 flexMergeRestrictColumns = 3
	 flexMergeRestrictAll = 4
End Enum 
Enum PictureTypeSettings
	 flexPictureColor = 0
	 flexPictureMonochrome = 1
End Enum 
Enum AllowUserResizeSettings
	 flexResizeNone = 0
	 flexResizeColumns = 1
	 flexResizeRows = 2
	 flexResizeBoth = 3
End Enum 
Enum MousePointerSettings
	 flexDefault = 0
	 flexArrow = 1
	 flexCross = 2
	 flexIBeam = 3
	 flexIcon = 4
	 flexSize = 5
	 flexSizeNESW = 6
	 flexSizeNS = 7
	 flexSizeNWSE = 8
	 flexSizeEW = 9
	 flexUpArrow = 10
	 flexHourglass = 11
	 flexNoDrop = 12
	 flexArrowHourGlass = 13
	 flexArrowQuestion = 14
	 flexSizeAll = 15
	 flexCustom = 99
End Enum 
Enum SortSettings
	 flexSortNone = 0
	 flexSortGenericAscending = 1
	 flexSortGenericDescending = 2
	 flexSortNumericAscending = 3
	 flexSortNumericDescending = 4
	 flexSortStringNoCaseAscending = 5
	 flexSortStringNoCaseDescending = 6
	 flexSortStringAscending = 7
	 flexSortStringDescending = 8
End Enum 
Enum AlignmentSettings
	 flexAlignLeftTop = 0
	 flexAlignLeftCenter = 1
	 flexAlignLeftBottom = 2
	 flexAlignCenterTop = 3
	 flexAlignCenterCenter = 4
	 flexAlignCenterBottom = 5
	 flexAlignRightTop = 6
	 flexAlignRightCenter = 7
	 flexAlignRightBottom = 8
	 flexAlignGeneral = 9
End Enum 
'********************************************************************************************
' Type defines (Structs)
'********************************************************************************************

type  IIVBDataObject As IVBDataObject
type  IIVBDataObjectFiles As IVBDataObjectFiles
type  IIRowCursor As IRowCursor
type  IIMSFlexGrid As IMSFlexGrid



'********************************************************************************************
' PROGID
'********************************************************************************************

CONST  PROGID_DataObject = ""
CONST  PROGID_DataObjectFiles = ""
CONST  PROGID_MSFlexGrid = "MSFlexGridLib.MSFlexGrid.1"
CONST  PROGID_MSFlexGrid2 = "MSFlexGridLib.MSFlexGrid.1"

'********************************************************************************************
' CLSIDs
'********************************************************************************************

DIM SHARED AS CLSID  CLSID_DataObject = (&h2334D2B2, &h713E, &h11CF, {&h8A, &hE5, &h0, &hAA, &h0, &hC0, &h9, &h5})
DIM SHARED AS CLSID  CLSID_DataObjectFiles = (&h2334D2B4, &h713E, &h11CF, {&h8A, &hE5, &h0, &hAA, &h0, &hC0, &h9, &h5})
DIM SHARED AS CLSID  CLSID_MSFlexGrid = (&h6262D3A0, &h531B, &h11CF, {&h91, &hF6, &hC2, &h86, &h3C, &h38, &h5E, &h30})
DIM SHARED AS CLSID  CLSID_MSFlexGrid2 = (&h74DD2713, &hBA98, &h4D10, {&hA1, &h6E, &h27, &hB, &hBE, &hB9, &hB5, &h55})


'********************************************************************************************
' IIDs
'********************************************************************************************

DIM SHARED AS IID IID_IVBDataObject = (&h2334D2B1, &h713E, &h11CF, {&h8A, &hE5, &h0, &hAA, &h0, &hC0, &h9, &h5})
DIM SHARED AS IID IID_IVBDataObjectFiles = (&h2334D2B3, &h713E, &h11CF, {&h8A, &hE5, &h0, &hAA, &h0, &hC0, &h9, &h5})
DIM SHARED AS IID IID_IRowCursor = (&h9F6AA700, &hD188, &h11CD, {&hAD, &h48, &h0, &hAA, &h0, &h3C, &h9C, &hB6})
DIM SHARED AS IID IID_IMSFlexGrid = (&h5F4DF280, &h531B, &h11CF, {&h91, &hF6, &hC2, &h86, &h3C, &h38, &h5E, &h30})
DIM SHARED AS IID IID_DMSFlexGridEvents = (&h609602E0, &h531B, &h11CF, {&h91, &hF6, &hC2, &h86, &h3C, &h38, &h5E, &h30})


'********************************************************************************************
' Interface VTables
'********************************************************************************************

'********************************************************************************************
' IVBDataObject interface
' IID: {2334D2B1-713E-11CF-8AE5-00AA00C00905}
' Interface flags: &H11D0 [Hidden] [Dual] [Nonextensible] [Oleautomation] [Dispatchable]
' Member identifier: 0
' Number of functions: 5
'********************************************************************************************

type IIVBDataObject As IVBDataObject
type IVBDataObjectVtbl_  As IVBDataObjectVtbl 
type IVBDataObject
     lpVtbl As IVBDataObjectVtbl_ Ptr
end type

type IVBDataObjectVtbl
	QueryInterface As Function (As IVBDataObject PTR,As REFIID,As LPVOID PTR PTR)As HRESULT
	AddRef As Function (As IVBDataObject PTR)As ULONG
	Release As Function (As IVBDataObject PTR)As ULONG
	GetTypeInfoCount As Function (As IVBDataObject PTR,As UINT PTR)As HRESULT
	GetTypeInfo As Function (As IVBDataObject PTR, As UINT,As LCID,As ITypeInfo PTR PTR)As HRESULT
	GetIDsOfNames As Function (As IVBDataObject PTR,As REFIID,As LPOLESTR PTR,As UINT,As LCID,As DISPID PTR)As HRESULT
	Invoke As Function (As IVBDataObject PTR,As DISPID,As REFIID,As LCID,As WORD,As DISPPARAMS PTR,As VARIANT PTR,As EXCEPINFO PTR,As UINT PTR)As HRESULT
	Clear As Function (As IVBDataObject PTR) As HRESULT  'Clears all data and formats in a DataObject object.
	GetData As Function (As IVBDataObject PTR,BYVAL prmsFormat As short,BYVAL prmpvData As VARIANT Ptr) As HRESULT  'Retrieves data of a specified format from a DataObject object.
	GetFormat As Function (As IVBDataObject PTR,BYVAL prmsFormat As short,BYVAL prmpbFormatSupported As VARIANT_BOOL Ptr) As HRESULT  'Determines if a specified clipboard format is supported by the DataObject object.
	SetData As Function (As IVBDataObject PTR,BYVAL varvValue As VARIANT,BYVAL varvFormat As VARIANT) As HRESULT  'Adds a supported format and possibly its data to a DataObject object.
	get_Files As Function (As IVBDataObject PTR,BYVAL prmpFiles As IIVBDataObjectFiles Ptr Ptr) As HRESULT  'A collection of filenames used by the vbCFFiles format.
End type 

#define IVBDataObject_Clear (Pthis)	Pthis->lpVtbl->Clear(Pthis)
#define IVBDataObject_GetData (Pthis,prmsFormat,prmpvData)	Pthis->lpVtbl->GetData(Pthis,prmsFormat,prmpvData)
#define IVBDataObject_GetFormat (Pthis,prmsFormat,prmpbFormatSupported)	Pthis->lpVtbl->GetFormat(Pthis,prmsFormat,prmpbFormatSupported)
#define IVBDataObject_SetData (Pthis,varvValue,varvFormat)	Pthis->lpVtbl->SetData(Pthis,varvValue,varvFormat)
#define IVBDataObject_get_Files (Pthis,prmpFiles)	Pthis->lpVtbl->get_Files(Pthis,prmpFiles)

'********************************************************************************************
' IVBDataObjectFiles interface
' IID: {2334D2B3-713E-11CF-8AE5-00AA00C00905}
' Interface flags: &H11D0 [Hidden] [Dual] [Nonextensible] [Oleautomation] [Dispatchable]
' Member identifier: 2
' Number of functions: 6
'********************************************************************************************

type IIVBDataObjectFiles As IVBDataObjectFiles
type IVBDataObjectFilesVtbl_  As IVBDataObjectFilesVtbl 
type IVBDataObjectFiles
     lpVtbl As IVBDataObjectFilesVtbl_ Ptr
end type

type IVBDataObjectFilesVtbl
	QueryInterface As Function (As IVBDataObjectFiles PTR,As REFIID,As LPVOID PTR PTR)As HRESULT
	AddRef As Function (As IVBDataObjectFiles PTR)As ULONG
	Release As Function (As IVBDataObjectFiles PTR)As ULONG
	GetTypeInfoCount As Function (As IVBDataObjectFiles PTR,As UINT PTR)As HRESULT
	GetTypeInfo As Function (As IVBDataObjectFiles PTR, As UINT,As LCID,As ITypeInfo PTR PTR)As HRESULT
	GetIDsOfNames As Function (As IVBDataObjectFiles PTR,As REFIID,As LPOLESTR PTR,As UINT,As LCID,As DISPID PTR)As HRESULT
	Invoke As Function (As IVBDataObjectFiles PTR,As DISPID,As REFIID,As LCID,As WORD,As DISPPARAMS PTR,As VARIANT PTR,As EXCEPINFO PTR,As UINT PTR)As HRESULT
	get_Item As Function (As IVBDataObjectFiles PTR,BYVAL prmlIndex As long,BYVAL prmbstrItem As BSTR Ptr) As HRESULT  'Returns a specific filename by index from the Files collection of a DataObject object (vbCFFiles format only).
	get_Count As Function (As IVBDataObjectFiles PTR,BYVAL prmplCount As long Ptr) As HRESULT  'Returns the number of filenames in the Files collection of a DataObject object (vbCFFiles format only).
	Add As Function (As IVBDataObjectFiles PTR,BYVAL pbstrbstrFilename As BSTR,BYVAL varvIndex As VARIANT) As HRESULT  'Adds a filename to the Files collection of a DataObject object (vbCFFiles format only).
	Clear As Function (As IVBDataObjectFiles PTR) As HRESULT  'Clears all filenames stored in the Files collection of a DataObject object (vbCFFiles format only).
	Remove As Function (As IVBDataObjectFiles PTR,BYVAL varvIndex As VARIANT) As HRESULT  'Removes a filename from the Files collection of a DataObject object (vbCFFiles format only).
	_NewEnum As Function (As IVBDataObjectFiles PTR,BYVAL prmppUnk As LPUNKNOWN Ptr) As HRESULT  '
End type 

#define IVBDataObjectFiles_get_Item (Pthis,prmlIndex,prmbstrItem)	Pthis->lpVtbl->get_Item(Pthis,prmlIndex,prmbstrItem)
#define IVBDataObjectFiles_get_Count (Pthis,prmplCount)	Pthis->lpVtbl->get_Count(Pthis,prmplCount)
#define IVBDataObjectFiles_Add (Pthis,pbstrbstrFilename,varvIndex)	Pthis->lpVtbl->Add(Pthis,pbstrbstrFilename,varvIndex)
#define IVBDataObjectFiles_Clear (Pthis)	Pthis->lpVtbl->Clear(Pthis)
#define IVBDataObjectFiles_Remove (Pthis,varvIndex)	Pthis->lpVtbl->Remove(Pthis,varvIndex)
#define IVBDataObjectFiles__NewEnum (Pthis,prmppUnk)	Pthis->lpVtbl->_NewEnum(Pthis,prmppUnk)

'********************************************************************************************
' IRowCursor interface
' IID: {9F6AA700-D188-11CD-AD48-00AA003C9CB6}
' Interface flags: &H1150 [Hidden] [Dual] [Oleautomation] [Dispatchable]
' Member identifier: 9
' Number of functions: 0
'********************************************************************************************

type IIRowCursor As IRowCursor
type IRowCursorVtbl_  As IRowCursorVtbl 
type IRowCursor
     lpVtbl As IRowCursorVtbl_ Ptr
end type

type IRowCursorVtbl
	QueryInterface As Function (As IRowCursor PTR,As REFIID,As LPVOID PTR PTR)As HRESULT
	AddRef As Function (As IRowCursor PTR)As ULONG
	Release As Function (As IRowCursor PTR)As ULONG
	GetTypeInfoCount As Function (As IRowCursor PTR,As UINT PTR)As HRESULT
	GetTypeInfo As Function (As IRowCursor PTR, As UINT,As LCID,As ITypeInfo PTR PTR)As HRESULT
	GetIDsOfNames As Function (As IRowCursor PTR,As REFIID,As LPOLESTR PTR,As UINT,As LCID,As DISPID PTR)As HRESULT
	Invoke As Function (As IRowCursor PTR,As DISPID,As REFIID,As LCID,As WORD,As DISPPARAMS PTR,As VARIANT PTR,As EXCEPINFO PTR,As UINT PTR)As HRESULT
End type 


'********************************************************************************************
' IMSFlexGrid interface
' Help context: 366111 (&H5961F)
' Documentation string: Dispatch interface for Microsoft FlexGrid Control
' IID: {5F4DF280-531B-11CF-91F6-C2863C385E30}
' Interface flags: &H11D0 [Hidden] [Dual] [Nonextensible] [Oleautomation] [Dispatchable]
' Member identifier: 26
' Number of functions: 180
'********************************************************************************************

type IIMSFlexGrid As IMSFlexGrid
type IMSFlexGridVtbl_  As IMSFlexGridVtbl 
type IMSFlexGrid
     lpVtbl As IMSFlexGridVtbl_ Ptr
end type

type IMSFlexGridVtbl
	QueryInterface As Function (As IMSFlexGrid PTR,As REFIID,As LPVOID PTR PTR)As HRESULT
	AddRef As Function (As IMSFlexGrid PTR)As ULONG
	Release As Function (As IMSFlexGrid PTR)As ULONG
	GetTypeInfoCount As Function (As IMSFlexGrid PTR,As UINT PTR)As HRESULT
	GetTypeInfo As Function (As IMSFlexGrid PTR, As UINT,As LCID,As ITypeInfo PTR PTR)As HRESULT
	GetIDsOfNames As Function (As IMSFlexGrid PTR,As REFIID,As LPOLESTR PTR,As UINT,As LCID,As DISPID PTR)As HRESULT
	Invoke As Function (As IMSFlexGrid PTR,As DISPID,As REFIID,As LCID,As WORD,As DISPPARAMS PTR,As VARIANT PTR,As EXCEPINFO PTR,As UINT PTR)As HRESULT
	get_Rows As Function (As IMSFlexGrid PTR,BYVAL prmRows As long Ptr) As HRESULT  'Determines the total number of columns or rows in a FlexGrid.
	Put_Rows As Function (As IMSFlexGrid PTR,BYVAL prmRows As long) As HRESULT  'Determines the total number of columns or rows in a FlexGrid.
	get_Cols As Function (As IMSFlexGrid PTR,BYVAL prmCols As long Ptr) As HRESULT  'Determines the total number of columns or rows in a FlexGrid.
	Put_Cols As Function (As IMSFlexGrid PTR,BYVAL prmCols As long) As HRESULT  'Determines the total number of columns or rows in a FlexGrid.
	get_FixedRows As Function (As IMSFlexGrid PTR,BYVAL prmFixedRows As long Ptr) As HRESULT  'Returns/sets the total number of fixed (non-scrollable) columns or rows for a FlexGrid.
	Put_FixedRows As Function (As IMSFlexGrid PTR,BYVAL prmFixedRows As long) As HRESULT  'Returns/sets the total number of fixed (non-scrollable) columns or rows for a FlexGrid.
	get_FixedCols As Function (As IMSFlexGrid PTR,BYVAL prmFixedCols As long Ptr) As HRESULT  'Returns/sets the total number of fixed (non-scrollable) columns or rows for a FlexGrid.
	Put_FixedCols As Function (As IMSFlexGrid PTR,BYVAL prmFixedCols As long) As HRESULT  'Returns/sets the total number of fixed (non-scrollable) columns or rows for a FlexGrid.
	get_Version As Function (As IMSFlexGrid PTR,BYVAL prmVersion As short Ptr) As HRESULT  'Returns the version of the FlexGrid control currently loaded in memory.
	get_FormatString As Function (As IMSFlexGrid PTR,BYVAL prmFormatString As BSTR Ptr) As HRESULT  'Allows you to set up a FlexGrid's column widths, alignments, and fixed row and column text at design time. See the help file for details.
	Put_FormatString As Function (As IMSFlexGrid PTR,BYVAL pbstrFormatString As BSTR) As HRESULT  'Allows you to set up a FlexGrid's column widths, alignments, and fixed row and column text at design time. See the help file for details.
	get_TopRow As Function (As IMSFlexGrid PTR,BYVAL prmTopRow As long Ptr) As HRESULT  'Returns/sets the uppermost row displayed in the FlexGrid. Not available at design time.
	Put_TopRow As Function (As IMSFlexGrid PTR,BYVAL prmTopRow As long) As HRESULT  'Returns/sets the uppermost row displayed in the FlexGrid. Not available at design time.
	get_LeftCol As Function (As IMSFlexGrid PTR,BYVAL prmLeftCol As long Ptr) As HRESULT  'Returns/sets the leftmost visible column (other than a fixed column) in the FlexGrid. Not available at design time.
	Put_LeftCol As Function (As IMSFlexGrid PTR,BYVAL prmLeftCol As long) As HRESULT  'Returns/sets the leftmost visible column (other than a fixed column) in the FlexGrid. Not available at design time.
	get_Row As Function (As IMSFlexGrid PTR,BYVAL prmRow As long Ptr) As HRESULT  'Returns/sets the active cell in a FlexGrid. Not available at design time.
	Put_Row As Function (As IMSFlexGrid PTR,BYVAL prmRow As long) As HRESULT  'Returns/sets the active cell in a FlexGrid. Not available at design time.
	get_Col As Function (As IMSFlexGrid PTR,BYVAL prmCol As long Ptr) As HRESULT  'Returns/sets the active cell in a FlexGrid. Not available at design time.
	Put_Col As Function (As IMSFlexGrid PTR,BYVAL prmCol As long) As HRESULT  'Returns/sets the active cell in a FlexGrid. Not available at design time.
	get_RowSel As Function (As IMSFlexGrid PTR,BYVAL prmRowSel As long Ptr) As HRESULT  'Determines the starting or ending row or column for a range of cells. Not available at design time.
	Put_RowSel As Function (As IMSFlexGrid PTR,BYVAL prmRowSel As long) As HRESULT  'Determines the starting or ending row or column for a range of cells. Not available at design time.
	get_ColSel As Function (As IMSFlexGrid PTR,BYVAL prmColSel As long Ptr) As HRESULT  'Determines the starting or ending row or column for a range of cells. Not available at design time.
	Put_ColSel As Function (As IMSFlexGrid PTR,BYVAL prmColSel As long) As HRESULT  'Determines the starting or ending row or column for a range of cells. Not available at design time.
	get_Text As Function (As IMSFlexGrid PTR,BYVAL prmText As BSTR Ptr) As HRESULT  'Returns/sets the text contents of a cell or range of cells.
	Put_Text As Function (As IMSFlexGrid PTR,BYVAL pbstrText As BSTR) As HRESULT  'Returns/sets the text contents of a cell or range of cells.
	get_BackColor As Function (As IMSFlexGrid PTR,BYVAL prmBackColor As OLE_COLOR Ptr) As HRESULT  'Returns/sets the background color of various elements of the FlexGrid.
	Put_BackColor As Function (As IMSFlexGrid PTR,BYVAL prmBackColor As OLE_COLOR) As HRESULT  'Returns/sets the background color of various elements of the FlexGrid.
	get_ForeColor As Function (As IMSFlexGrid PTR,BYVAL prmForeColor As OLE_COLOR Ptr) As HRESULT  'Determines the color used to draw text on each part of the FlexGrid.
	Put_ForeColor As Function (As IMSFlexGrid PTR,BYVAL prmForeColor As OLE_COLOR) As HRESULT  'Determines the color used to draw text on each part of the FlexGrid.
	get_BackColorFixed As Function (As IMSFlexGrid PTR,BYVAL prmBackColorFixed As OLE_COLOR Ptr) As HRESULT  'Returns/sets the background color of various elements of the FlexGrid.
	Put_BackColorFixed As Function (As IMSFlexGrid PTR,BYVAL prmBackColorFixed As OLE_COLOR) As HRESULT  'Returns/sets the background color of various elements of the FlexGrid.
	get_ForeColorFixed As Function (As IMSFlexGrid PTR,BYVAL prmForeColorFixed As OLE_COLOR Ptr) As HRESULT  'Determines the color used to draw text on each part of the FlexGrid.
	Put_ForeColorFixed As Function (As IMSFlexGrid PTR,BYVAL prmForeColorFixed As OLE_COLOR) As HRESULT  'Determines the color used to draw text on each part of the FlexGrid.
	get_BackColorSel As Function (As IMSFlexGrid PTR,BYVAL prmBackColorSel As OLE_COLOR Ptr) As HRESULT  'Returns/sets the background color of various elements of the FlexGrid.
	Put_BackColorSel As Function (As IMSFlexGrid PTR,BYVAL prmBackColorSel As OLE_COLOR) As HRESULT  'Returns/sets the background color of various elements of the FlexGrid.
	get_ForeColorSel As Function (As IMSFlexGrid PTR,BYVAL prmForeColorSel As OLE_COLOR Ptr) As HRESULT  'Determines the color used to draw text on each part of the FlexGrid.
	Put_ForeColorSel As Function (As IMSFlexGrid PTR,BYVAL prmForeColorSel As OLE_COLOR) As HRESULT  'Determines the color used to draw text on each part of the FlexGrid.
	get_BackColorBkg As Function (As IMSFlexGrid PTR,BYVAL prmBackColorBkg As OLE_COLOR Ptr) As HRESULT  'Returns/sets the background color of various elements of the FlexGrid.
	Put_BackColorBkg As Function (As IMSFlexGrid PTR,BYVAL prmBackColorBkg As OLE_COLOR) As HRESULT  'Returns/sets the background color of various elements of the FlexGrid.
	get_WordWrap As Function (As IMSFlexGrid PTR,BYVAL prmWordWrap As VARIANT_BOOL Ptr) As HRESULT  'Returns/sets whether text within a cell should be allowed to wrap.
	Put_WordWrap As Function (As IMSFlexGrid PTR,BYVAL tWordWrap As VARIANT_BOOL) As HRESULT  'Returns/sets whether text within a cell should be allowed to wrap.
	get_Font As Function (As IMSFlexGrid PTR,BYVAL prmFont As IFontDisp Ptr Ptr) As HRESULT  'Returns/sets the default font or the font for individual cells.
	PutRef_Font As Function (As IMSFlexGrid PTR,BYVAL prmFont As IFontDisp Ptr) As HRESULT  'Returns/sets the default font or the font for individual cells.
	get_FontWidth As Function (As IMSFlexGrid PTR,BYVAL prmFontWidth As float Ptr) As HRESULT  'Returns or sets the width, in points, of the font to be used for text displayed.
	Put_FontWidth As Function (As IMSFlexGrid PTR,BYVAL prmFontWidth As float) As HRESULT  'Returns or sets the width, in points, of the font to be used for text displayed.
	get_CellFontName As Function (As IMSFlexGrid PTR,BYVAL prmCellFontName As BSTR Ptr) As HRESULT  'Returns/sets the font to be used for individual cells or ranges of cells.
	Put_CellFontName As Function (As IMSFlexGrid PTR,BYVAL pbstrCellFontName As BSTR) As HRESULT  'Returns/sets the font to be used for individual cells or ranges of cells.
	get_CellFontSize As Function (As IMSFlexGrid PTR,BYVAL prmCellFontSize As float Ptr) As HRESULT  'Returns or sets the size, in points, for the current cell text.
	Put_CellFontSize As Function (As IMSFlexGrid PTR,BYVAL prmCellFontSize As float) As HRESULT  'Returns or sets the size, in points, for the current cell text.
	get_CellFontBold As Function (As IMSFlexGrid PTR,BYVAL prmCellFontBold As VARIANT_BOOL Ptr) As HRESULT  'Returns or sets the bold style for the current cell text.
	Put_CellFontBold As Function (As IMSFlexGrid PTR,BYVAL tCellFontBold As VARIANT_BOOL) As HRESULT  'Returns or sets the bold style for the current cell text.
	get_CellFontItalic As Function (As IMSFlexGrid PTR,BYVAL prmCellFontItalic As VARIANT_BOOL Ptr) As HRESULT  'Returns or sets the italic style for the current cell text.
	Put_CellFontItalic As Function (As IMSFlexGrid PTR,BYVAL tCellFontItalic As VARIANT_BOOL) As HRESULT  'Returns or sets the italic style for the current cell text.
	get_CellFontUnderline As Function (As IMSFlexGrid PTR,BYVAL prmCellFontUnderline As VARIANT_BOOL Ptr) As HRESULT  'Returns or sets the underline style for the current cell text.
	Put_CellFontUnderline As Function (As IMSFlexGrid PTR,BYVAL tCellFontUnderline As VARIANT_BOOL) As HRESULT  'Returns or sets the underline style for the current cell text.
	get_CellFontStrikeThrough As Function (As IMSFlexGrid PTR,BYVAL prmCellFontStrikeThrough As VARIANT_BOOL Ptr) As HRESULT  'Returns or sets the strikethrough style for the current cell text.
	Put_CellFontStrikeThrough As Function (As IMSFlexGrid PTR,BYVAL tCellFontStrikeThrough As VARIANT_BOOL) As HRESULT  'Returns or sets the strikethrough style for the current cell text.
	get_CellFontWidth As Function (As IMSFlexGrid PTR,BYVAL prmCellFontWidth As float Ptr) As HRESULT  'Returns or sets the font width for the current cell text.
	Put_CellFontWidth As Function (As IMSFlexGrid PTR,BYVAL prmCellFontWidth As float) As HRESULT  'Returns or sets the font width for the current cell text.
	get_TextStyle As Function (As IMSFlexGrid PTR,BYVAL prmTextStyle As TextStyleSettings Ptr) As HRESULT  'Returns/sets 3D effects for displaying text.
	Put_TextStyle As Function (As IMSFlexGrid PTR,BYVAL prmTextStyle As TextStyleSettings) As HRESULT  'Returns/sets 3D effects for displaying text.
	get_TextStyleFixed As Function (As IMSFlexGrid PTR,BYVAL prmTextStyleFixed As TextStyleSettings Ptr) As HRESULT  'Returns/sets 3D effects for displaying text.
	Put_TextStyleFixed As Function (As IMSFlexGrid PTR,BYVAL prmTextStyleFixed As TextStyleSettings) As HRESULT  'Returns/sets 3D effects for displaying text.
	get_ScrollTrack As Function (As IMSFlexGrid PTR,BYVAL prmScrollTrack As VARIANT_BOOL Ptr) As HRESULT  'Returns/sets whether FlexGrid should scroll its contents while the user moves the scroll box along the scroll bars.
	Put_ScrollTrack As Function (As IMSFlexGrid PTR,BYVAL tScrollTrack As VARIANT_BOOL) As HRESULT  'Returns/sets whether FlexGrid should scroll its contents while the user moves the scroll box along the scroll bars.
	get_FocusRect As Function (As IMSFlexGrid PTR,BYVAL prmFocusRect As FocusRectSettings Ptr) As HRESULT  'Determines whether the FlexGrid control should draw a focus rectangle around the current cell.
	Put_FocusRect As Function (As IMSFlexGrid PTR,BYVAL prmFocusRect As FocusRectSettings) As HRESULT  'Determines whether the FlexGrid control should draw a focus rectangle around the current cell.
	get_HighLight As Function (As IMSFlexGrid PTR,BYVAL prmHighLight As HighLightSettings Ptr) As HRESULT  'Returns/sets whether selected cells appear highlighted.
	Put_HighLight As Function (As IMSFlexGrid PTR,BYVAL prmHighLight As HighLightSettings) As HRESULT  'Returns/sets whether selected cells appear highlighted.
	get_Redraw As Function (As IMSFlexGrid PTR,BYVAL prmRedraw As VARIANT_BOOL Ptr) As HRESULT  'Enables or disables redrawing of the FlexGrid control.
	Put_Redraw As Function (As IMSFlexGrid PTR,BYVAL tRedraw As VARIANT_BOOL) As HRESULT  'Enables or disables redrawing of the FlexGrid control.
	get_ScrollBars As Function (As IMSFlexGrid PTR,BYVAL prmScrollBars As ScrollBarsSettings Ptr) As HRESULT  'Returns/sets whether a FlexGrid has horizontal or vertical scroll bars.
	Put_ScrollBars As Function (As IMSFlexGrid PTR,BYVAL prmScrollBars As ScrollBarsSettings) As HRESULT  'Returns/sets whether a FlexGrid has horizontal or vertical scroll bars.
	get_MouseRow As Function (As IMSFlexGrid PTR,BYVAL prmMouseRow As long Ptr) As HRESULT  'Returns/sets over which row (column) the mouse pointer is. Not available at design time.
	get_MouseCol As Function (As IMSFlexGrid PTR,BYVAL prmMouseCol As long Ptr) As HRESULT  'Returns/sets over which row (column) the mouse pointer is. Not available at design time.
	get_CellLeft As Function (As IMSFlexGrid PTR,BYVAL prmCellLeft As long Ptr) As HRESULT  'Returns the left position of the current cell, in twips
	get_CellTop As Function (As IMSFlexGrid PTR,BYVAL prmCellTop As long Ptr) As HRESULT  'Returns or sets the top position of the current cell, in twips
	get_CellWidth As Function (As IMSFlexGrid PTR,BYVAL prmCellWidth As long Ptr) As HRESULT  'Returns the width of the current cell, in twips
	get_CellHeight As Function (As IMSFlexGrid PTR,BYVAL prmCellHeight As long Ptr) As HRESULT  'Returns the height of the current cell, in Twips.
	get_RowHeightMin As Function (As IMSFlexGrid PTR,BYVAL prmRowHeightMin As long Ptr) As HRESULT  'Returns/sets a minimum row height for the entire control, in Twips.
	Put_RowHeightMin As Function (As IMSFlexGrid PTR,BYVAL prmRowHeightMin As long) As HRESULT  'Returns/sets a minimum row height for the entire control, in Twips.
	get_FillStyle As Function (As IMSFlexGrid PTR,BYVAL prmFillStyle As FillStyleSettings Ptr) As HRESULT  'Determines whether setting the Text property or one of the Cell formatting properties of a FlexGrid applies the change to all selected cells.
	Put_FillStyle As Function (As IMSFlexGrid PTR,BYVAL prmFillStyle As FillStyleSettings) As HRESULT  'Determines whether setting the Text property or one of the Cell formatting properties of a FlexGrid applies the change to all selected cells.
	get_GridLines As Function (As IMSFlexGrid PTR,BYVAL prmGridLines As GridLineSettings Ptr) As HRESULT  'Returns/sets the type of lines that should be drawn between cells.
	Put_GridLines As Function (As IMSFlexGrid PTR,BYVAL prmGridLines As GridLineSettings) As HRESULT  'Returns/sets the type of lines that should be drawn between cells.
	get_GridLinesFixed As Function (As IMSFlexGrid PTR,BYVAL prmGridLinesFixed As GridLineSettings Ptr) As HRESULT  'Returns/sets the type of lines that should be drawn between cells.
	Put_GridLinesFixed As Function (As IMSFlexGrid PTR,BYVAL prmGridLinesFixed As GridLineSettings) As HRESULT  'Returns/sets the type of lines that should be drawn between cells.
	get_GridColor As Function (As IMSFlexGrid PTR,BYVAL prmGridColor As OLE_COLOR Ptr) As HRESULT  'Returns/sets the color used to draw the lines between FlexGrid cells.
	Put_GridColor As Function (As IMSFlexGrid PTR,BYVAL prmGridColor As OLE_COLOR) As HRESULT  'Returns/sets the color used to draw the lines between FlexGrid cells.
	get_GridColorFixed As Function (As IMSFlexGrid PTR,BYVAL prmGridColorFixed As OLE_COLOR Ptr) As HRESULT  'Returns/sets the color used to draw the lines between FlexGrid cells.
	Put_GridColorFixed As Function (As IMSFlexGrid PTR,BYVAL prmGridColorFixed As OLE_COLOR) As HRESULT  'Returns/sets the color used to draw the lines between FlexGrid cells.
	get_CellBackColor As Function (As IMSFlexGrid PTR,BYVAL prmCellBackColor As OLE_COLOR Ptr) As HRESULT  'Returns/sets the background and foreground colors of individual cells or ranges of cells.
	Put_CellBackColor As Function (As IMSFlexGrid PTR,BYVAL prmCellBackColor As OLE_COLOR) As HRESULT  'Returns/sets the background and foreground colors of individual cells or ranges of cells.
	get_CellForeColor As Function (As IMSFlexGrid PTR,BYVAL prmCellForeColor As OLE_COLOR Ptr) As HRESULT  'Returns/sets the background and foreground colors of individual cells or ranges of cells.
	Put_CellForeColor As Function (As IMSFlexGrid PTR,BYVAL prmCellForeColor As OLE_COLOR) As HRESULT  'Returns/sets the background and foreground colors of individual cells or ranges of cells.
	get_CellAlignment As Function (As IMSFlexGrid PTR,BYVAL prmCellAlignment As short Ptr) As HRESULT  'Returns/sets the alignment of data in a cell or range of selected cells. Not available at design time.
	Put_CellAlignment As Function (As IMSFlexGrid PTR,BYVAL prmCellAlignment As short) As HRESULT  'Returns/sets the alignment of data in a cell or range of selected cells. Not available at design time.
	get_CellTextStyle As Function (As IMSFlexGrid PTR,BYVAL prmCellTextStyle As TextStyleSettings Ptr) As HRESULT  'Returns/sets 3D effects for text on a specific cell or range of cells.
	Put_CellTextStyle As Function (As IMSFlexGrid PTR,BYVAL prmCellTextStyle As TextStyleSettings) As HRESULT  'Returns/sets 3D effects for text on a specific cell or range of cells.
	get_CellPictureAlignment As Function (As IMSFlexGrid PTR,BYVAL prmCellPictureAlignment As short Ptr) As HRESULT  'Returns/sets the alignment of pictures in a cell or range of selected cells. Not available at design time.
	Put_CellPictureAlignment As Function (As IMSFlexGrid PTR,BYVAL prmCellPictureAlignment As short) As HRESULT  'Returns/sets the alignment of pictures in a cell or range of selected cells. Not available at design time.
	get_Clip As Function (As IMSFlexGrid PTR,BYVAL prmClip As BSTR Ptr) As HRESULT  'Returns/sets the contents of the cells in a FlexGrid's selected region. Not available at design time.
	Put_Clip As Function (As IMSFlexGrid PTR,BYVAL pbstrClip As BSTR) As HRESULT  'Returns/sets the contents of the cells in a FlexGrid's selected region. Not available at design time.
	Put_Sort As Function (As IMSFlexGrid PTR,BYVAL prmClip As short) As HRESULT  'Action-type property that sorts selected rows according to selected criteria. Not available at design-time, write-only at run time.
	get_SelectionMode As Function (As IMSFlexGrid PTR,BYVAL prmSelectionMode As SelectionModeSettings Ptr) As HRESULT  'Returns/sets whether a FlexGrid should allow regular cell selection, selection by rows, or selection by columns.
	Put_SelectionMode As Function (As IMSFlexGrid PTR,BYVAL prmSelectionMode As SelectionModeSettings) As HRESULT  'Returns/sets whether a FlexGrid should allow regular cell selection, selection by rows, or selection by columns.
	get_MergeCells As Function (As IMSFlexGrid PTR,BYVAL prmMergeCells As MergeCellsSettings Ptr) As HRESULT  'Returns/sets whether cells with the same contents should be grouped in a single cell spanning multiple rows or columns.
	Put_MergeCells As Function (As IMSFlexGrid PTR,BYVAL prmMergeCells As MergeCellsSettings) As HRESULT  'Returns/sets whether cells with the same contents should be grouped in a single cell spanning multiple rows or columns.
	get_AllowBigSelection As Function (As IMSFlexGrid PTR,BYVAL prmAllowBigSelection As VARIANT_BOOL Ptr) As HRESULT  'Returns/sets whether clicking on a column or row header should cause the entire column or row to be selected.
	Put_AllowBigSelection As Function (As IMSFlexGrid PTR,BYVAL tAllowBigSelection As VARIANT_BOOL) As HRESULT  'Returns/sets whether clicking on a column or row header should cause the entire column or row to be selected.
	get_AllowUserResizing As Function (As IMSFlexGrid PTR,BYVAL prmAllowUserResizing As AllowUserResizeSettings Ptr) As HRESULT  'Returns/sets whether the user should be allowed to resize rows and columns with the mouse.
	Put_AllowUserResizing As Function (As IMSFlexGrid PTR,BYVAL prmAllowUserResizing As AllowUserResizeSettings) As HRESULT  'Returns/sets whether the user should be allowed to resize rows and columns with the mouse.
	get_BorderStyle As Function (As IMSFlexGrid PTR,BYVAL prmBorderStyle As BorderStyleSettings Ptr) As HRESULT  'Returns/sets the border style for an object.
	Put_BorderStyle As Function (As IMSFlexGrid PTR,BYVAL prmBorderStyle As BorderStyleSettings) As HRESULT  'Returns/sets the border style for an object.
	get_hWnd As Function (As IMSFlexGrid PTR,BYVAL prmhWnd As long Ptr) As HRESULT  'Returns a handle to a form or control.
	get_Enabled As Function (As IMSFlexGrid PTR,BYVAL prmEnabled As VARIANT_BOOL Ptr) As HRESULT  'Returns/sets a value that determines whether a form or control can respond to user-generated events.
	Put_Enabled As Function (As IMSFlexGrid PTR,BYVAL tEnabled As VARIANT_BOOL) As HRESULT  'Returns/sets a value that determines whether a form or control can respond to user-generated events.
	get_Appearance As Function (As IMSFlexGrid PTR,BYVAL prmAppearance As AppearanceSettings Ptr) As HRESULT  'Returns/sets whether a control should be painted with 3-D effects.
	Put_Appearance As Function (As IMSFlexGrid PTR,BYVAL prmAppearance As AppearanceSettings) As HRESULT  'Returns/sets whether a control should be painted with 3-D effects.
	get_MousePointer As Function (As IMSFlexGrid PTR,BYVAL prmMousePointer As MousePointerSettings Ptr) As HRESULT  'Returns/sets the type of mouse pointer displayed when over part of an object.
	Put_MousePointer As Function (As IMSFlexGrid PTR,BYVAL prmMousePointer As MousePointerSettings) As HRESULT  'Returns/sets the type of mouse pointer displayed when over part of an object.
	get_MouseIcon As Function (As IMSFlexGrid PTR,BYVAL prmMouseIcon As IPictureDisp Ptr Ptr) As HRESULT  'Returns/sets a custom mouse icon.
	PutRef_MouseIcon As Function (As IMSFlexGrid PTR,BYVAL prmMouseIcon As IPictureDisp Ptr) As HRESULT  'Returns/sets a custom mouse icon.
	get_PictureType As Function (As IMSFlexGrid PTR,BYVAL prmPictureType As PictureTypeSettings Ptr) As HRESULT  'Returns/sets the type of picture that should be generated by the Picture property.
	Put_PictureType As Function (As IMSFlexGrid PTR,BYVAL prmPictureType As PictureTypeSettings) As HRESULT  'Returns/sets the type of picture that should be generated by the Picture property.
	get_Picture As Function (As IMSFlexGrid PTR,BYVAL prmPicture As IPictureDisp Ptr Ptr) As HRESULT  'Returns a picture of the FlexGrid control, suitable for printing, saving to disk, copying to the clipboard, or assigning to a different control.
	get_CellPicture As Function (As IMSFlexGrid PTR,BYVAL prmCellPicture As IPictureDisp Ptr Ptr) As HRESULT  'Returns/sets an image to be displayed in the current cell or in a range of cells.
	PutRef_CellPicture As Function (As IMSFlexGrid PTR,BYVAL prmCellPicture As IPictureDisp Ptr) As HRESULT  'Returns/sets an image to be displayed in the current cell or in a range of cells.
	AboutBox As Sub (As IMSFlexGrid PTR)         'Displays an About box with version and copyright information.
	get_TextArray As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmTextArray As BSTR Ptr) As HRESULT  'Returns/sets the text contents of an arbitrary cell (single subscript).
	Put_TextArray As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL pbstrTextArray As BSTR) As HRESULT  'Returns/sets the text contents of an arbitrary cell (single subscript).
	get_ColAlignment As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmColAlignment As short Ptr) As HRESULT  'Returns/sets the alignment of data in a column. Not available at design time (except indirectly through the FormatString property).
	Put_ColAlignment As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmColAlignment As short) As HRESULT  'Returns/sets the alignment of data in a column. Not available at design time (except indirectly through the FormatString property).
	get_ColWidth As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmColWidth As long Ptr) As HRESULT  'Determines the width of the specified column in Twips. Not available at design time.
	Put_ColWidth As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmColWidth As long) As HRESULT  'Determines the width of the specified column in Twips. Not available at design time.
	get_RowHeight As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmRowHeight As long Ptr) As HRESULT  'Returns/sets the height of the specified row in Twips. Not available at design time.
	Put_RowHeight As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmRowHeight As long) As HRESULT  'Returns/sets the height of the specified row in Twips. Not available at design time.
	get_MergeRow As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmMergeRow As VARIANT_BOOL Ptr) As HRESULT  'Returns/sets which rows (columns) should have their contents merged when the MergeCells property is set to a value other than 0 - Never.
	Put_MergeRow As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL tMergeRow As VARIANT_BOOL) As HRESULT  'Returns/sets which rows (columns) should have their contents merged when the MergeCells property is set to a value other than 0 - Never.
	get_MergeCol As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmMergeCol As VARIANT_BOOL Ptr) As HRESULT  'Returns/sets which rows (columns) should have their contents merged when the MergeCells property is set to a value other than 0 - Never.
	Put_MergeCol As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL tMergeCol As VARIANT_BOOL) As HRESULT  'Returns/sets which rows (columns) should have their contents merged when the MergeCells property is set to a value other than 0 - Never.
	Put_RowPosition As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmMergeCol As long) As HRESULT  'Returns the distance in Twips between the upper-left corner of the control and the upper-left corner of a specified row.
	Put_ColPosition As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmMergeCol As long) As HRESULT  'Returns the distance in Twips between the upper-left corner of the control and the upper-left corner of a specified column.
	get_RowData As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmRowData As long Ptr) As HRESULT  'Array of long integer values with one item for each row (RowData) and for each column (ColData) of the FlexGrid. Not available at design time.
	Put_RowData As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmRowData As long) As HRESULT  'Array of long integer values with one item for each row (RowData) and for each column (ColData) of the FlexGrid. Not available at design time.
	get_ColData As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmColData As long Ptr) As HRESULT  'Array of long integer values with one item for each row (RowData) and for each column (ColData) of the FlexGrid. Not available at design time.
	Put_ColData As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmColData As long) As HRESULT  'Array of long integer values with one item for each row (RowData) and for each column (ColData) of the FlexGrid. Not available at design time.
	get_TextMatrix As Function (As IMSFlexGrid PTR,BYVAL prmRow As long,BYVAL prmCol As long,BYVAL prmTextMatrix As BSTR Ptr) As HRESULT  'Returns/sets the text contents of an arbitrary cell (row/col subscripts).
	Put_TextMatrix As Function (As IMSFlexGrid PTR,BYVAL prmRow As long,BYVAL prmCol As long,BYVAL pbstrTextMatrix As BSTR) As HRESULT  'Returns/sets the text contents of an arbitrary cell (row/col subscripts).
	AddItem As Function (As IMSFlexGrid PTR,BYVAL pbstrItem As BSTR,BYVAL varindex As VARIANT) As HRESULT  'Adds a new row to a FlexGrid control at run time.
	RemoveItem As Function (As IMSFlexGrid PTR,BYVAL prmindex As long) As HRESULT  'Removes a row from a FlexGrid control at run time
	Clear As Sub (As IMSFlexGrid PTR)         'Clears the contents of the FlexGrid. This includes all text, pictures, and cell formatting.
	Refresh As Sub (As IMSFlexGrid PTR)         'Forces a complete repaint of a form or control.
	get_DataSource As Function (As IMSFlexGrid PTR,BYVAL prmDataSource As IRowCursor Ptr Ptr) As HRESULT  'Returns/sets the data source for the control.
	Put_DataSource As Function (As IMSFlexGrid PTR,BYVAL prmDataSource As IRowCursor Ptr) As HRESULT  'Returns/sets the data source for the control.
	get_RowIsVisible As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmRowIsVisible As VARIANT_BOOL Ptr) As HRESULT  'Returns True if the specified row is visible.
	get_ColIsVisible As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmColIsVisible As VARIANT_BOOL Ptr) As HRESULT  'Returns True if the specified column is visible.
	get_RowPos As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmRowPos As long Ptr) As HRESULT  'Returns the distance in Twips between the upper-left corner of the control and the upper-left corner of a specified row.
	get_ColPos As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmColPos As long Ptr) As HRESULT  'Returns the distance in Twips between the upper-left corner of the control and the upper-left corner of a specified column.
	get_GridLineWidth As Function (As IMSFlexGrid PTR,BYVAL prmGridLineWidth As short Ptr) As HRESULT  'Returns/sets the width in Pixels of the gridlines for the control.
	Put_GridLineWidth As Function (As IMSFlexGrid PTR,BYVAL prmGridLineWidth As short) As HRESULT  'Returns/sets the width in Pixels of the gridlines for the control.
	get_FixedAlignment As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmFixedAlignment As short Ptr) As HRESULT  'Returns/sets the alignment of data in the fixed cells of a column.
	Put_FixedAlignment As Function (As IMSFlexGrid PTR,BYVAL prmindex As long,BYVAL prmFixedAlignment As short) As HRESULT  'Returns/sets the alignment of data in the fixed cells of a column.
	get_FontName As Function (As IMSFlexGrid PTR,BYVAL prmFontName As BSTR Ptr) As HRESULT  '
	Put_FontName As Function (As IMSFlexGrid PTR,BYVAL pbstrFontName As BSTR) As HRESULT  '
	get_FontSize As Function (As IMSFlexGrid PTR,BYVAL prmFontSize As float Ptr) As HRESULT  '
	Put_FontSize As Function (As IMSFlexGrid PTR,BYVAL prmFontSize As float) As HRESULT  '
	get_FontBold As Function (As IMSFlexGrid PTR,BYVAL prmFontBold As VARIANT_BOOL Ptr) As HRESULT  '
	Put_FontBold As Function (As IMSFlexGrid PTR,BYVAL tFontBold As VARIANT_BOOL) As HRESULT  '
	get_FontItalic As Function (As IMSFlexGrid PTR,BYVAL prmFontItalic As VARIANT_BOOL Ptr) As HRESULT  '
	Put_FontItalic As Function (As IMSFlexGrid PTR,BYVAL tFontItalic As VARIANT_BOOL) As HRESULT  '
	get_FontStrikethru As Function (As IMSFlexGrid PTR,BYVAL prmFontStrikethru As VARIANT_BOOL Ptr) As HRESULT  '
	Put_FontStrikethru As Function (As IMSFlexGrid PTR,BYVAL tFontStrikethru As VARIANT_BOOL) As HRESULT  '
	get_FontUnderline As Function (As IMSFlexGrid PTR,BYVAL prmFontUnderline As VARIANT_BOOL Ptr) As HRESULT  '
	Put_FontUnderline As Function (As IMSFlexGrid PTR,BYVAL tFontUnderline As VARIANT_BOOL) As HRESULT  '
	get_RightToLeft As Function (As IMSFlexGrid PTR,BYVAL prmRightToLeft As VARIANT_BOOL Ptr) As HRESULT  'Determines text display direction and control visual appearance on a bidirectional system.
	Put_RightToLeft As Function (As IMSFlexGrid PTR,BYVAL tRightToLeft As VARIANT_BOOL) As HRESULT  'Determines text display direction and control visual appearance on a bidirectional system.
	get_OLEDropMode As Function (As IMSFlexGrid PTR,BYVAL prmpsOLEDropMode As OLEDropConstants Ptr) As HRESULT  'Returns/Sets whether this control can act as an OLE drop target.
	Put_OLEDropMode As Function (As IMSFlexGrid PTR,BYVAL prmpsOLEDropMode As OLEDropConstants) As HRESULT  'Returns/Sets whether this control can act as an OLE drop target.
	OLEDrag As Function (As IMSFlexGrid PTR) As HRESULT  'Starts an OLE drag/drop event with the given control as the source.
End type 

'******************************************************************************
' Helper Functions - Interface Creation
'******************************************************************************

FUNCTION Create_IVBDataObject() As IVBDataObject Ptr
dim hr As HRESULT
If IsOleInitialized=FALSE then OleInitialize(NULL):IsOleInitialized=TRUE: ENDIF
Dim pobj As IVBDataObject Ptr
  hr=CoCreateInstance(@CLSID_DataObject, NULL, CLSCTX_SERVER, @IID_IVBDataObject,cast(LPVOID ptr,@pobj))
if hr=S_OK then 
   Return pobj
else
   MessageBox NULL,"Error number hr=" & hr,"Can't create IVBDataObject",0
   Return NULL
END IF
END FUNCTION


FUNCTION Create_IVBDataObjectFiles() As IVBDataObjectFiles Ptr
dim hr As HRESULT
If IsOleInitialized=FALSE then OleInitialize(NULL):IsOleInitialized=TRUE: ENDIF
Dim pobj As IVBDataObjectFiles Ptr
  hr=CoCreateInstance(@CLSID_DataObjectFiles, NULL, CLSCTX_SERVER, @IID_IVBDataObjectFiles,cast(LPVOID ptr,@pobj))
if hr=S_OK then 
   Return pobj
else
   MessageBox NULL,"Error number hr=" & hr,"Can't create IVBDataObjectFiles",0
   Return NULL
END IF
END FUNCTION


FUNCTION Create_IMSFlexGrid() As IMSFlexGrid Ptr
dim hr As HRESULT
If IsOleInitialized=FALSE then OleInitialize(NULL):IsOleInitialized=TRUE: ENDIF
Dim pobj As IMSFlexGrid Ptr
  hr=CoCreateInstance(@CLSID_MSFlexGrid, NULL, CLSCTX_SERVER, @IID_IMSFlexGrid,cast(LPVOID ptr,@pobj))
if hr=S_OK then 
   Return pobj
else
   MessageBox NULL,"Error number hr=" & hr,"Can't create IMSFlexGrid",0
   Return NULL
END IF
END FUNCTION

INSIDE ACTIVEX WITH FREEBASIC

Re: INSIDE ACTIVEX WITH FREEBASIC

Re: INSIDE ACTIVEX WITH FREEBASIC

Re: INSIDE ACTIVEX WITH FREEBASIC

Re: INSIDE ACTIVEX WITH FREEBASIC

Re: INSIDE ACTIVEX WITH FREEBASIC

Re: INSIDE ACTIVEX WITH FREEBASIC

Re: INSIDE ACTIVEX WITH FREEBASIC

Re: INSIDE ACTIVEX WITH FREEBASIC

Re: INSIDE ACTIVEX WITH FREEBASIC

Re: INSIDE ACTIVEX WITH FREEBASIC

Re: INSIDE ACTIVEX WITH FREEBASIC

Re: INSIDE ACTIVEX WITH FREEBASIC

Re: INSIDE ACTIVEX WITH FREEBASIC

Re: INSIDE ACTIVEX WITH FREEBASIC

Re: INSIDE ACTIVEX WITH FREEBASIC