All,
I have attached the Type Library DLL file, which can give you the complete structure of VBA (all Office programs) as well as the resources located in most DLL's, OCX's, and OLB files. It can also give the structure of most installed applications and their executable files.
I personally find this to be extremely helpful, and at this point I've even made my own VBA help system out of it for assistance in writing code. If you're interested, below are the codes that I used to make an Access data structure out of the resources located in system32 DLL's as well as all Microsoft Office libraries. The relevant translations to the VBA language (some are useless) data types from the resulting ''vartypes'' table are:
Code:
vname vvalue vreturndatatype
VT_BOOL 11 Boolean
VT_UI1 17 Byte
VT_CY 6 Currency
VT_DATE 7 Date
VT_R8 5 Double
VT_I2 2 Integer
VT_UI4 19 Long
VT_INT 22 Long
VT_I4 3 Long
VT_NULL 1 NULL
VT_R4 4 Single
VT_BSTR 8 String
VT_VARIANT 12 Variant
The entire operation for these 3 sample directories takes about 30 seconds to execute on a Vista 64-bit machine with a 2.8 GHz dual processor .
Primary Function:
Code:
Public Function ListFiles2() 'This is the only function to be run directly
On Error Resume Next
Call MakeTablesALL
Dim aPaths As Variant
'Office folder, System32 and Common files for installed programs
aPaths = Array( _
"C:\Program Files (x86)\Microsoft Office\Office12\", _
"C:\Windows\System32\", _
"C:\Program Files (x86)\Common Files\")
Dim i As Long
Dim j As Long
Dim strFileSpec As String
Dim bIncludeSubfolders As Boolean
bIncludeSubfolders = True
strFileSpec = ""
Dim colDirList As New Collection
Dim varItem As Variant
For j = LBound(aPaths) To UBound(aPaths)
Call FillDir2(colDirList, aPaths(j), strFileSpec, bIncludeSubfolders)
For Each varItem In colDirList
If UCase(CStr(Right(varItem, 3))) = "DLL" Or _
UCase(CStr(Right(varItem, 3))) = "OCX" Or _
UCase(CStr(Right(varItem, 3))) = "OLB" Or _
UCase(CStr(Right(varItem, 3))) = "EXE" Then
Call CrawlLib(CStr(varItem))
End If
Next
Set colDirList = Nothing
Next j
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & err.Number & ": " & err.Description
Resume Exit_Handler
End Function
Called Functions:
Code:
Function MakeTablesALL()
On Error Resume Next
Dim tbl As DAO.TableDef
For Each tbl In CurrentDb.TableDefs
If Not tbl.Name = "vartypes" Then
If Not tbl.Name Like "msys*" Then
CurrentDb.TableDefs.Delete (tbl.Name)
End If
End If
Next tbl
Dim t As Variant
Dim i As Long
'TABLE NAMES
t = Array("library", "enum", _
"coclass", "method", _
"property", , "parameter", _
"vartypes")
Dim db As DAO.Database
Set db = CurrentDb
For i = LBound(t) To UBound(t)
Set tbl = db.CreateTableDef(t(i))
With tbl
Select Case t(i)
Case "enum"
.Fields.Append .CreateField("lid", dbLong) 'FK FOR LIBRARY ID
.Fields.Append .CreateField("eid", dbLong) 'UNIQUE
.Fields.Append .CreateField("etype", dbText, 255)
.Fields.Append .CreateField("etypenumber", dbLong) 'TYPE IDENTIFIER IN LIBRARY
.Fields.Append .CreateField("emember", dbText, 255)
.Fields.Append .CreateField("evalue", dbText, 255)
.Fields("eid").Attributes = .Fields("eid").Attributes + dbAutoIncrField
db.TableDefs.Append tbl
strSql = "CREATE INDEX id ON enum " & _
"(eid) WITH PRIMARY;"
db.Execute strSql, dbFailOnError
Case "coclass"
.Fields.Append .CreateField("lid", dbLong) 'FK FOR LIBRARY ID
.Fields.Append .CreateField("cid", dbLong) 'UNIQUE
.Fields.Append .CreateField("ctype", dbText, 255)
.Fields.Append .CreateField("ctypenumber", dbText, 255)
.Fields("cid").Attributes = .Fields("cid").Attributes + dbAutoIncrField
db.TableDefs.Append tbl
strSql = "CREATE INDEX id ON coclass " & _
"(cid) WITH PRIMARY;"
db.Execute strSql, dbFailOnError
Case "method"
.Fields.Append .CreateField("cid", dbLong) 'FK FOR CLASS ID
.Fields.Append .CreateField("methodid", dbLong) 'UNIQUE
.Fields.Append .CreateField("mname", dbText, 255)
.Fields.Append .CreateField("mreturntype", dbText, 255) 'RETURN TYPE
.Fields.Append .CreateField("mreturntypenumber", dbText, 255) 'RETURN TYPE NUMBER
.Fields.Append .CreateField("mreturndatatype", dbText, 255) 'RETURN DATA TYPE, IF APPLICABLE
.Fields("methodid").Attributes = .Fields("methodid").Attributes + dbAutoIncrField
db.TableDefs.Append tbl
strSql = "CREATE INDEX id ON method " & _
"(methodid) WITH PRIMARY;"
db.Execute strSql, dbFailOnError
Case "property"
.Fields.Append .CreateField("cid", dbLong) 'FK FOR CLASS ID
.Fields.Append .CreateField("propid", dbLong) 'UNIQUE
.Fields.Append .CreateField("pname", dbText, 255)
.Fields.Append .CreateField("preturntype", dbText, 255) 'RETURN TYPE
.Fields.Append .CreateField("preturntypenumber", dbText, 255) 'RETURN TYPE NUMBER
.Fields.Append .CreateField("preturndatatype", dbText, 255) 'RETURN DATA TYPE, IF APPLICABLE
.Fields("propid").Attributes = .Fields("propid").Attributes + dbAutoIncrField
db.TableDefs.Append tbl
strSql = "CREATE INDEX id ON property " & _
"(propid) WITH PRIMARY;"
db.Execute strSql, dbFailOnError
Case "parameter"
.Fields.Append .CreateField("methodid", dbLong) 'FK FOR METHOD ID
.Fields.Append .CreateField("paramid", dbLong) 'UNIQUE
.Fields.Append .CreateField("pname", dbText, 255)
.Fields.Append .CreateField("poptional", dbBoolean)
.Fields.Append .CreateField("pflags", dbText, 255)
.Fields.Append .CreateField("pdatatype", dbText, 255)
.Fields.Append .CreateField("ptype", dbText, 255)
.Fields.Append .CreateField("ptypenumber", dbText, 255)
.Fields("paramid").Attributes = .Fields("paramid").Attributes + dbAutoIncrField
db.TableDefs.Append tbl
strSql = "CREATE INDEX id ON parameter " & _
"(paramid) WITH PRIMARY;"
db.Execute strSql, dbFailOnError
Case "library"
.Fields.Append .CreateField("lid", dbLong) 'UNIQUE
.Fields.Append .CreateField("lfile", dbText, 255)
.Fields.Append .CreateField("lname", dbText, 255)
.Fields("lid").Attributes = .Fields("lid").Attributes + dbAutoIncrField
db.TableDefs.Append tbl
strSql = "CREATE INDEX id ON library " & _
"(lid) WITH PRIMARY;"
db.Execute strSql, dbFailOnError
Case "vartypes"
.Fields.Append .CreateField("vid", dbLong) 'UNIQUE
.Fields.Append .CreateField("vname", dbText, 255)
.Fields.Append .CreateField("vvalue", dbText, 255)
.Fields("vid").Attributes = .Fields("vid").Attributes + dbAutoIncrField
Case Else
'DO NOTHING
End Select
End With
Next i
db.Close
Set db = Nothing
Set tbl = Nothing
RefreshDatabaseWindow
End Function
Public Function FillDir2(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _
bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
strFolder = TrailingSlash2(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colDirList.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
For Each vFolderName In colFolders
Call FillDir2(colDirList, strFolder & TrailingSlash2(vFolderName), strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash2(varIn As Variant) As String
If Len(varIn) > 0& Then
If Right(varIn, 1&) = "\" Then
TrailingSlash2 = varIn
Else
TrailingSlash2 = varIn & "\"
End If
End If
End Function
Library Crawler Routine:
Code:
Sub CrawlLib(fn As String)
Dim i As Long
Dim temp As String
Dim x As TLI.TypeLibInfo
Dim minfo As TLI.MemberInfo
Dim pinfo As TLI.ParameterInfo
Dim iinfo As TLI.InterfaceInfo
Dim tinfo As TLI.TypeInfo
Dim lid As Long
Dim cid As Long
Dim did As Long
Dim methodid As Long
Dim rs As DAO.Recordset
Dim rsmethods As DAO.Recordset
Dim rsparameters As DAO.Recordset
Dim rsproperties As DAO.Recordset
Set x = TypeLibInfoFromFile(fn)
Set rsmethods = CurrentDb.OpenRecordset("method")
Set rsproperties = CurrentDb.OpenRecordset("property")
Set rsparameters = CurrentDb.OpenRecordset("parameter")
On Error GoTo ExitProc
temp = x.TypeInfos(1).Parent 'IF ERROR, SKIP WRITE PROCESS (no types)
On Error Resume Next
Set rs = CurrentDb.OpenRecordset("library") 'LIB RECORD
rs.AddNew
rs!lfile = x.ContainingFile
rs!lName = x.TypeInfos(1).Parent
lid = rs!lid
rs.Update
rs.Close
For Each tinfo In x.TypeInfos
Select Case tinfo.TypeKindString
Case "enum" 'ENUMERATION TYPE
Set rs = CurrentDb.OpenRecordset("enum")
For Each minfo In tinfo.Members
rs.AddNew
rs!lid = lid
rs![etype] = tinfo.Name
rs![etypenumber] = tinfo.TypeInfoNumber
rs![emember] = minfo.Name
rs![evalue] = minfo.Value
rs.Update
Next minfo
rs.Close
Case "coclass" 'COCLASS TYPE
If Left(tinfo.Name, 1) <> "_" Then
Set rs = CurrentDb.OpenRecordset("coclass")
rs.AddNew
rs!lid = lid
rs!ctype = tinfo.Name
rs!ctypenumber = tinfo.TypeInfoNumber
cid = rs!cid
rs.Update
rs.Close
For Each iinfo In tinfo.Interfaces
For Each minfo In iinfo.Members
If minfo.InvokeKind = 2 Then 'PROPERTY
rsproperties.AddNew
rsproperties!cid = cid
rsproperties![pName] = minfo
rsproperties![preturntype] = minfo.ReturnType.TypeInfo.TypeKindString
rsproperties![preturntypenumber] = IIf(minfo.ReturnType.TypeInfoNumber = -1, _
Null, _
minfo.ReturnType.TypeInfoNumber)
rsproperties![preturndatatype] = IIf(minfo.ReturnType.TypeInfoNumber = -1, _
minfo.ReturnType.VarType, _
Null)
rsproperties.Update
ElseIf minfo.InvokeKind = 1 Then 'METHOD
rsmethods.AddNew
rsmethods!cid = cid
rsmethods![mname] = minfo.Name
rsmethods![mreturntype] = minfo.ReturnType.TypeInfo.TypeKindString
rsmethods![mreturntypenumber] = IIf(minfo.ReturnType.TypeInfoNumber = -1, _
Null, _
minfo.ReturnType.TypeInfoNumber)
rsmethods![mreturndatatype] = IIf(minfo.ReturnType.TypeInfoNumber = -1, _
minfo.ReturnType.VarType, _
Null)
methodid = rsmethods!methodid
rsmethods.Update
For Each pinfo In minfo.Parameters
rsparameters.AddNew
rsparameters!methodid = methodid
rsparameters![pName] = pinfo.Name
rsparameters![poptional] = pinfo.Optional
rsparameters![pflags] = pinfo.Flags
rsparameters![pdatatype] = IIf(pinfo.VarTypeInfo.VarType = 0, _
Null, _
pinfo.VarTypeInfo.VarType)
rsparameters![pType] = IIf(pinfo.VarTypeInfo.VarType = 0, _
pinfo.VarTypeInfo.TypeInfo.TypeKindString, _
Null)
rsparameters![ptypenumber] = IIf(pinfo.VarTypeInfo.VarType = 0, _
pinfo.VarTypeInfo.TypeInfoNumber, _
Null)
rsparameters.Update
Next pinfo
End If
Next minfo
Next iinfo
End If
Case "dispinterface" 'DISPATCH INTERFACE TYPE (use COCLASS table)
If Left(tinfo.Name, 1) <> "_" Then
Set rs = CurrentDb.OpenRecordset("coclass")
rs.AddNew
rs!lid = lid
rs!ctype = tinfo.Name
rs!ctypenumber = tinfo.TypeInfoNumber
cid = rs!cid
rs.Update
rs.Close
For Each iinfo In tinfo.Interfaces
For Each minfo In iinfo.Members
If minfo.InvokeKind = 2 Then 'PROPERTY
rsproperties.AddNew
rsproperties!cid = cid
rsproperties![pName] = minfo.Name
rsproperties![preturntype] = minfo.ReturnType.TypeInfo.TypeKindString
rsproperties![preturntypenumber] = IIf(minfo.ReturnType.TypeInfoNumber = -1, _
Null, _
minfo.ReturnType.TypeInfoNumber)
rsproperties![preturndatatype] = IIf(minfo.ReturnType.TypeInfoNumber = -1, _
minfo.ReturnType.VarType, _
Null)
rsproperties.Update
ElseIf minfo.InvokeKind = 1 Then 'METHOD
rsmethods.AddNew
rsmethods!cid = cid
rsmethods![mname] = minfo.Name
rsmethods![mreturntype] = minfo.ReturnType.TypeInfo.TypeKindString
rsmethods![mreturntypenumber] = IIf(minfo.ReturnType.TypeInfoNumber = -1, _
Null, _
minfo.ReturnType.TypeInfoNumber)
rsmethods![mreturndatatype] = IIf(minfo.ReturnType.TypeInfoNumber = -1, _
minfo.ReturnType.VarType, _
Null)
methodid = rsmethods!methodid
rsmethods.Update
For Each pinfo In minfo.Parameters
rsparameters.AddNew
rsparameters!methodid = methodid
rsparameters![pName] = pinfo.Name
rsparameters![poptional] = pinfo.Optional
rsparameters![pflags] = pinfo.Flags
rsparameters![pdatatype] = IIf(pinfo.VarTypeInfo.VarType = 0, _
Null, _
pinfo.VarTypeInfo.VarType)
rsparameters![pType] = IIf(pinfo.VarTypeInfo.VarType = 0, _
pinfo.VarTypeInfo.TypeInfo.TypeKindString, _
Null)
rsparameters![ptypenumber] = IIf(pinfo.VarTypeInfo.VarType = 0, _
pinfo.VarTypeInfo.TypeInfoNumber, _
Null)
rsparameters.Update
Next pinfo
End If
Next minfo
Next iinfo
End If
Case Else
'DO NOTHING
End Select
Next tinfo
ExitProc:
rsproperties.Close
rsmethods.Close
rsparameters.Close
Set rs = Nothing
Set rsproperties = Nothing
Set rsmethods = Nothing
Set rsparameters = Nothing
Set x = Nothing
Exit Sub
End Sub