Tricks of the Windows Gam…ming Gurus (2nd Edition)/Disc2.iso/msdn_vcb/samples/vc98/sdk/com/oleaut/browseh/vb.frm

Visual Basic Form | 1996-04-30 | 11.1 KB | 351 lines

VERSION 4.00
Begin VB.Form Form1
   Appearance      =   0  'Flat
   BackColor       =   &H80000005&
   Caption         =   "Header file generator"
   ClientHeight    =   2010
   ClientLeft      =   4110
   ClientTop       =   2640
   ClientWidth     =   5370
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   0
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   Height          =   2415
   Left            =   4050
   LinkTopic       =   "Form1"
   ScaleHeight     =   2010
   ScaleWidth      =   5370
   Top             =   2295
   Width           =   5490
   Begin VB.CommandButton ChooseTypeLibrary
      Caption         =   "Choose Type Library"
      Height          =   495
      Left            =   1560
      TabIndex        =   0
      Top             =   360
      Width           =   2415
   End
   Begin MSComDlg.CommonDialog SaveOutputDialog
      Left            =   120
      Top             =   1080
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
      DialogTitle     =   "Save Output As"
      Filter          =   "(*.h)|*.h"
   End
   Begin MSComDlg.CommonDialog ChooseTlibDialog
      Left            =   120
      Top             =   480
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
      DialogTitle     =   "Choose Type Library"
      Filter          =   "Type Libraries |*.tlb;*.olb;*.dll;*.exe"
   End
Attribute VB_Name = "Form1"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
'TYPEKIND constants
Const TKIND_ENUM = 0
Const TKIND_RECORD = 1
Const TKIND_MODULE = 2
Const TKIND_INTERFACE = 3
Const TKIND_DISPATCH = 4
Const TKIND_COCLASS = 5
Const TKIND_ALIAS = 6
Const TKIND_UNION = 7
'INVOKEKIND constants
Const INVOKE_FUNC = 1
Const INVOKE_PROPERTYGET = 2
Const INVOKE_PROPERTYPUT = 4
Const INVOKE_PROPERTYPUTREF = 8
'VARENUM constants
Const VT_I2 = 2
Const VT_I4 = 3
Const VT_R4 = 4
Const VT_R8 = 5
Const VT_CY = 6
Const VT_DATE = 7
Const VT_BSTR = 8
Const VT_DISPATCH = 9
Const VT_ERROR = 10
Const VT_BOOL = 11
Const VT_VARIANT = 12
Const VT_UNKNOWN = 13
Const VT_I1 = 16
Const VT_UI1 = 17
Const VT_UI2 = 18
Const VT_UI4 = 19
Const VT_I8 = 20
Const VT_UI8 = 21
Const VT_INT = 22
Const VT_UINT = 23
Const VT_VOID = 24
Const VT_HRESULT = 25
Const VT_PTR = 26
Const VT_SAFEARRAY = 27
Const VT_CARRAY = 28
Const VT_USERDEFINED = 29
Const VT_LPSTR = 30
Const VT_LPWSTR = 31
' TYPEFLAGS
Const TYPEFLAG_FDUAL = &H40
Private Sub ChooseTypeLibrary_Click()
Dim browser As Object
Dim tlib As Object
Dim tinfos As Object
Dim tinfo As Object
Dim funcs As Object
Dim func As Object
Dim params As Object
Dim param As Object
Dim element As Object
Dim elements As Object
Dim member As Object
Dim members As Object
Dim tinfoBase As Object
' Get name of input type library
On Error GoTo DialogCancel
ChooseTlibDialog.CancelError = True
ChooseTlibDialog.ShowOpen
' Create Browse Helper (BROWSEH sample)
Set browser = CreateObject("BrowseHelper.Browser")
Set tlib = browser.BrowseTypeLibrary(ChooseTlibDialog.filename)
Set tinfos = tlib.TypeInfos
' Get name of output header file
On Error GoTo DialogCancel
SaveOutputDialog.CancelError = True
SaveOutputDialog.ShowSave
Open SaveOutputDialog.filename For Output As 1
Print #1, "DEFINE_GUID(LIBID_"; tlib.Name; ","; FormatGUID(tlib.GUIDAsString); ");"
Print #1,
' Enumerate typeinfos in the type library
For i = 0 To tinfos.Count - 1
  Set tinfo = tinfos.Item(i)
  ' Output header file contents depending on the TYPEKIND of the typeinfo
  Select Case tinfo.TypeInfoKind
     Case TKIND_ENUM     'Enum
        Print #1, "typedef enum{"
        Set elements = tinfo.elements
        For j = 0 To elements.Count - 1
            Set element = elements.Item(j)
            Print #1, Tab(1); element.Name; " = "; element.Value;
            If j < elements.Count - 1 Then
                    Print #1, ",";
            End If
        Next j
        Print #1,
        Print #1, "} "; tinfo.Name; ";"

    Case TKIND_RECORD     'Struct
        Print #1, "typedef struct{"
        Set members = tinfo.members
        For j = 0 To members.Count - 1
            Set member = members.Item(j)
            Print #1, Tab(1); TypeToString(member.Type); " "; member.Name; ";"
        Next j
        Print #1, "} "; tinfo.Name; ";"

    Case TKIND_UNION     'Union
        Print #1, "typedef union{"
        Set members = tinfo.members
        For j = 0 To members.Count - 1
            Set member = members.Item(j)
            Print #1, Tab(1); TypeToString(member.Type); " "; member.Name; ";"
        Next j
        Print #1, "} "; tinfo.Name; ";"

     Case TKIND_INTERFACE     'Interface
        Print #1, "DEFINE_GUID(IID_"; tinfo.Name; ","; FormatGUID(tinfo.GUIDAsString); ");"
        On Error Resume Next
        Set tinfoBase = tinfo.BaseInterface
        If Err.Number > 0 Then 'If there is no base interface
           Print #1, "DECLARE_INTERFACE("; tinfo.Name; ")"
        Else
           Print #1, "DECLARE_INTERFACE_("; tinfo.Name; ", "; tinfoBase.Name; ")"
        End If
        Print #1, "{"

        ' Output the functions in the interface
        Set funcs = tinfo.Functions
        For j = 0 To funcs.Count - 1
            Set func = funcs.Item(j)
            Print #1, Tab(2); "STDMETHOD_("; TypeToString(func.ReturnType); ", ";
            Select Case func.InvocationKind
                Case INVOKE_PROPERTYGET
                   Print #1, "get_";
                Case INVOKE_PROPERTYPUT
                   Print #1, "put_";
                Case INVOKE_PROPERTYPUTREF
                   Print #1, "putref_";
            End Select
            Set params = func.Parameters
            If params.Count = 0 Then
               Print #1, func.Name; ")(THIS";
            Else
              Print #1, func.Name; ")(THIS_ ";
            End If

            ' Ouput the parameters of the function
            For k = 0 To params.Count - 1
                Set param = params.Item(k)
                Print #1, TypeToString(param.Type); " ";
                Print #1, param.Name;
                If k < params.Count - 1 Then
                    Print #1, ", ";
                End If
            Next k
            Print #1, ") PURE;";
            Print #1,
        Next j
        Print #1, "};"

    Case TKIND_DISPATCH 'dispinterface or dual interface
        TypeFlags = tinfo.TypeFlags()
        ' Check if this is the dispinterface component of
        ' a dual interface. If so get the interface component of the dual interface
        If TypeFlags And TYPEFLAG_FDUAL Then
            Set tinfo = tinfo.Interface
            Set tinfoBase = tinfo.BaseInterface
            Print #1, "DEFINE_GUID(IID_"; tinfo.Name; ","; FormatGUID(tinfo.GUIDAsString); ");"
            Print #1, "DECLARE_INTERFACE_("; tinfo.Name; ", "; tinfoBase.Name; ")"
            Print #1, "{"

            ' Output the functions in the interface
            Set funcs = tinfo.Functions
            For j = 0 To funcs.Count - 1
                Set func = funcs.Item(j)
                Print #1, Tab(2); "STDMETHOD_("; TypeToString(func.ReturnType); ", ";
                Select Case func.InvocationKind
                    Case INVOKE_PROPERTYGET
                       Print #1, "get_";
                    Case INVOKE_PROPERTYPUT
                       Print #1, "put_";
                    Case INVOKE_PROPERTYPUTREF
                      Print #1, "putref_";
                End Select
                Set params = func.Parameters
                If params.Count = 0 Then
                    Print #1, func.Name; ")(THIS";
                Else
                     Print #1, func.Name; ")(THIS_ ";
                End If

                ' Ouput the parameters of the function
                For k = 0 To params.Count - 1
                    Set param = params.Item(k)
                    Print #1, TypeToString(param.Type); " ";
                    Print #1, param.Name;
                    If k < params.Count - 1 Then
                        Print #1, ", ";
                    End If
                Next k
                Print #1, ") PURE;";
                Print #1,
            Next j
            Print #1, "};"
        End If

    Case TKIND_ALIAS     'Alias
        Print #1, "typedef "; TypeToString(tinfo.BaseType); " "; tinfo.Name; ";"

    Case TKIND_COCLASS  'CoClass
         Print #1, "DEFINE_GUID(CLSID_"; tinfo.Name; ","; FormatGUID(tinfo.GUIDAsString); ");"
  End Select
  Print #1,
Next i
Close #1
MsgBox SaveOutputDialog.filename + " has been generated", , "Header File Generator"
DialogCancel:   'User cancelled the dialog
End Sub
' Convert a type to a string
Private Function TypeToString(typeObj As Object) As String
  Dim s As String
  Dim p As Object
  Dim u As Object
  t = typeObj.Type
  Select Case t
     Case VT_I2
         s = "short"
     Case VT_I4
         s = "long"
     Case VT_R4
         s = "float"
     Case VT_R8
         s = "double"
     Case VT_CY
         s = "CURRENCY"
     Case VT_DATE
         s = "DATE"
     Case VT_BSTR
         s = "BSTR"
     Case VT_DISPATCH
         s = "IDispatch FAR*"
     Case VT_ERROR
         s = "SCODE"
     Case VT_BOOL
         s = "VARIANT_BOOL"
     Case VT_VARIANT
         s = "VARIANT"
     Case VT_UNKNOWN
         s = "IUnknown FAR*"
     Case VT_I1
         s = "char"
     Case VT_UI1
         s = "unsigned char"
     Case VT_UI2
         s = "unsigned short"
     Case VT_UI4
         s = "unsigned long"
     Case VT_I8
         s = "64-bit int"
     Case VT_UI8
         s = "unsigned 64-bit int"
     Case VT_INT
         s = "int"
     Case VT_UINT
         s = "unsigned int"
     Case VT_VOID
         s = "void"
     Case VT_HRESULT
         s = "HRESULT"
     Case VT_PTR
         Set p = typeObj.PointerDesc
         s = TypeToString(p) + " FAR*"
     Case VT_SAFEARRAY
         s = "SAFEARRAY FAR*"
     Case VT_USERDEFINED
         Set u = typeObj.UserDefinedDesc
         s = u.Name
     Case VT_LPSTR
         s = "char FAR*"
     Case VT_LPWSTR
         s = "WCHAR FAR*"

  End Select
  If t And &H2000 Then
     s = "SAFEARRAY(" + s + ")"
  End If
  TypeToString = s
End Function
'Return a formatted GUID
Private Function FormatGUID(guid As String) As String
s1 = "0x" + Mid(guid, 2, 8) + "L,"
s2 = "0x" + Mid(guid, 11, 4) + "," + "0x" + Mid(guid, 16, 4) + ","
s3 = "0x" + Mid(guid, 21, 2) + "," + "0x" + Mid(guid, 23, 2) + ","
s4 = "0x" + Mid(guid, 26, 2) + "," + "0x" + Mid(guid, 28, 2) + ","
s5 = "0x" + Mid(guid, 30, 2) + "," + "0x" + Mid(guid, 32, 2) + ","
s6 = "0x" + Mid(guid, 34, 2) + "," + "0x" + Mid(guid, 36, 2)
FormatGUID = s1 + s2 + s3 + s4 + s5 + s6
End Function