Attribute VB_Name = "MDescriptions"
Option Explicit

Const sSrcPath = "f:\temp\VBCCR\Builds\"

Type type_Descr
   File        As String
   Path        As String
   Sub         As String
   TypeOfSub   As String
   Description As String
   FileId      As Long
   TypeId      As Long
End Type

Type type_File
   File        As String
   Path        As String
End Type

Sub Main()
'   On Error Resume Next
     
   Dim aDirs()    As String         'Directories of controls
   Dim D          As Integer        'Directories counter
   Dim sCurDir    As String         'Current directory
   
   Dim aFiles()   As type_File      'cls, ctl and pag files
   Dim F          As Integer        'Files counter
   Dim sCurFile   As String         'Current file
   
   Dim aStrings() As type_Descr     'Strings with descriptions
   Dim S          As Integer        'Strings counter
   Dim sCurString As String         'Current string of file
   Dim sCurSub    As String         'Current sub
   Dim sCurType   As String         'Current type of sub
   
   Dim sMainDB    As String         'Database path
   Dim oDBEngine  As Object         'DAO.DBEngine
   Dim oWorkspase As Object         'DAO.Workspace
   Dim oBase      As Object         'DAO.Database
   Dim t_FILES    As Object         'DAO.Recordset
   Dim t_TYPES    As Object         'DAO.Recordset
   Dim t_SUBS     As Object         'DAO.Recordset
   
   Dim adoCN      As Object         'ADODB.Connection
   Dim adxCT      As Object         'ADOX.Catalog
   Dim sConn      As String         'Connection string
   Dim SQL        As New Collection 'DDL queries
   Dim vSQL       As Variant        'Current DDL
   
   ReDim aDirs(1 To 100)
   sCurDir = Dir(sSrcPath, vbDirectory)
   D = 1
   Do While LenB(sCurDir)                         'Filling aDirs array
      If sCurDir <> "." And sCurDir <> ".." Then
         If (GetAttr(sSrcPath & sCurDir) And vbDirectory) = vbDirectory Then
            aDirs(D) = sSrcPath & sCurDir
            D = D + 1
         End If
      End If
      sCurDir = Dir
   Loop
   If D > 1 Then ReDim Preserve aDirs(1 To D - 1)
   
   ReDim aFiles(1 To 300)
   F = 1
   For D = LBound(aDirs) To UBound(aDirs)         'Filling aFiles array
      sCurFile = Dir(aDirs(D) & "\*")
      Do While LenB(sCurFile)
         If sCurFile Like "*.[c][lt][sl]" Then
            aFiles(F).File = sCurFile
            aFiles(F).Path = aDirs(D) & "\"
            F = F + 1
         End If
         sCurFile = Dir
      Loop
   Next
   aFiles(F).Path = sSrcPath
   aFiles(F).File = "CommonDialog.cls"
   If F > 1 Then ReDim Preserve aFiles(1 To F)
   ReDim aDirs(0)
   
   ReDim aStrings(1 To 6000)
   S = 1
   For F = LBound(aFiles) To UBound(aFiles)       'Filling aStrings array
      Open aFiles(F).Path & aFiles(F).File For Input As #F
         Do While Not EOF(F)
            Line Input #F, sCurString
            If sCurString Like "*Public *(*)*" Then
               sCurString = Right$(sCurString, Len(sCurString) - 7)
               sCurString = Left$(sCurString, InStr(1, sCurString, "(") - 1)
               aStrings(S).TypeOfSub = Left$(sCurString, InStrRev(sCurString, " ") - 1)
               aStrings(S).Sub = Right$(sCurString, Len(sCurString) - InStrRev(sCurString, " "))
               aStrings(S).File = aFiles(F).File
               aStrings(S).Path = aFiles(F).Path
            ElseIf sCurString Like "*.VB_Description*" _
            And sCurString Like "*Attribute " & aStrings(S).Sub & ".VB_Description =*" Then
               sCurString = Right$(sCurString, Len(sCurString) - InStr(1, sCurString, ".VB_Description =") - 18)
               aStrings(S).Description = Left$(sCurString, Len(sCurString) - 1)
               S = S + 1
            End If
         Loop
      Close #F
   Next
   If S > 1 Then ReDim Preserve aStrings(1 To S - 1)
   ReDim aFiles(0)
   
   sMainDB = App.Path & "\vbccr.mdb"              'Creating database
   If LenB(Dir(sMainDB)) = 0 Then
      SQL.Add "Create Table t_FILES (" & vbCrLf & _
              "   FILE_ID counter(1,1) not null," & vbCrLf & _
              "   FILE_NAME varchar(50) with compression not null," & vbCrLf & _
              "   FILE_PATH varchar(255) with compression not null," & vbCrLf & _
              "   Constraint PrimaryKey Primary Key (FILE_ID)" & vbCrLf & _
              ")"
      SQL.Add "Create Unique Index FILE_PATH_NAME On t_FILES (FILE_PATH, FILE_NAME) With Disallow Null"
      
      SQL.Add "Create Table t_TYPES (" & vbCrLf & _
              "   TYPE_ID counter(1,1) not null," & vbCrLf & _
              "   TYPE_NAME varchar(50) with compression not null," & vbCrLf & _
              "   Constraint PrimaryKey Primary Key (TYPE_ID)" & vbCrLf & _
              ")"
      SQL.Add "Create Unique Index TYPE_NAME On t_TYPES (TYPE_NAME) With Disallow Null"
      
      SQL.Add "Create Table t_SUBS (" & vbCrLf & _
              "   SUB_ID counter(1,1) not null," & vbCrLf & _
              "   SUB_NAME varchar(60) with compression not null," & vbCrLf & _
              "   FILE_ID long not null," & vbCrLf & _
              "   TYPE_ID long not null," & vbCrLf & _
              "   SUB_DESCR varchar(255) with compression not null," & vbCrLf & _
              "   Constraint PrimaryKey Primary Key (SUB_ID), " & vbCrLf & _
              "   Constraint SUBS_FILE_ID Foreign Key (FILE_ID)" & vbCrLf & _
              "      References t_FILES (FILE_ID)" & vbCrLf & _
              "      On Update Cascade On Delete Cascade, " & vbCrLf & _
              "   Constraint SUBS_TYPE_ID Foreign Key (TYPE_ID)" & vbCrLf & _
              "      References t_TYPES (TYPE_ID)" & vbCrLf & _
              "      On Update Cascade On Delete Cascade" & vbCrLf & _
              ")"
      SQL.Add "Create Unique Index TRIO_KEY On t_SUBS (SUB_NAME, FILE_ID, TYPE_ID) With Disallow Null"
      SQL.Add "Create Index FILE_ID On t_SUBS (FILE_ID) With Disallow Null"
      SQL.Add "Create Index TYPE_ID On t_SUBS (TYPE_ID) With Disallow Null"
      
      sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Engine Type=5;"
      sConn = sConn & "Data Source=" & sMainDB & ";"
      Set adxCT = CreateObject("ADOX.Catalog")
      Set adoCN = adxCT.Create(sConn)
      
      With adoCN
         For Each vSQL In SQL
            .Execute vSQL
         Next
        .Close
      End With
      
      'Set oDBEngine = New DAO.DBEngine
      Set oDBEngine = CreateObject("DAO.DBEngine.36")
      Set oWorkspase = oDBEngine.Workspaces(0)
      Set oBase = oWorkspase.OpenDatabase(sMainDB, True)
      
      Dim TBL     As String                       'Adding comboboxes in t_SUBS
      Dim FLD     As String
      Dim SRC     As String
      SRC = "SELECT FILE_ID, FILE_NAME FROM t_FILES;"
      TBL = "t_SUBS":       FLD = "FILE_ID":       GoSub AppendProperties
      SRC = "SELECT TYPE_ID, TYPE_NAME FROM t_TYPES;"
      TBL = "t_SUBS":       FLD = "TYPE_ID":       GoSub AppendProperties
   Else
      'Set oDBEngine = New DAO.DBEngine
      Set oDBEngine = CreateObject("DAO.DBEngine.36")
      Set oWorkspase = oDBEngine.Workspaces(0)
      Set oBase = oWorkspase.OpenDatabase(sMainDB, True)
   End If
   
   Set t_FILES = oBase.OpenRecordset("t_FILES")
   Set t_TYPES = oBase.OpenRecordset("t_TYPES")
   Set t_SUBS = oBase.OpenRecordset("t_SUBS")
   
   For S = LBound(aStrings) To UBound(aStrings)   'Filling database
      
      oWorkspase.BeginTrans
      
      With t_FILES
         .Index = "FILE_PATH_NAME"
         .Seek "=", aStrings(S).Path, aStrings(S).File
         If .NoMatch Then
            .AddNew
            !FILE_NAME = aStrings(S).File
            !FILE_PATH = aStrings(S).Path
            aStrings(S).FileId = !FILE_ID
            .Update
         Else
            aStrings(S).FileId = !FILE_ID
         End If
      End With
      
      With t_TYPES
         .Index = "TYPE_NAME"
         .Seek "=", aStrings(S).TypeOfSub
         If .NoMatch Then
            .AddNew
            !TYPE_NAME = aStrings(S).TypeOfSub
            aStrings(S).TypeId = !TYPE_ID
            .Update
         Else
            aStrings(S).TypeId = !TYPE_ID
         End If
      End With
      
      With t_SUBS
         .Index = "TRIO_KEY"
         .Seek "=", aStrings(S).Sub, aStrings(S).FileId, aStrings(S).TypeId
         If .NoMatch Then
            .AddNew
            !SUB_NAME = aStrings(S).Sub
            !FILE_ID = aStrings(S).FileId
            !TYPE_ID = aStrings(S).TypeId
            !SUB_DESCR = aStrings(S).Description
            .Update
         Else
            If !SUB_DESCR <> aStrings(S).Description Then
               .Edit
               !SUB_DESCR = aStrings(S).Description
               .Update
            End If
         End If
      End With
      
      oWorkspase.CommitTrans
   Next
   
   t_FILES.Close                                  'Closing database
   t_TYPES.Close
   t_SUBS.Close
   Set t_FILES = Nothing
   Set t_TYPES = Nothing
   Set t_SUBS = Nothing
   oBase.Close
   Set oBase = Nothing
   oWorkspase.Close
   Set oWorkspase = Nothing
   Set oDBEngine = Nothing
   Set SQL = Nothing
   Set adoCN = Nothing
   Set adxCT = Nothing
   
   Exit Sub
   
AppendProperties:                                 'Adding comboboxes in t_SUBS
   With oBase.TableDefs(TBL).Fields(FLD)
      .Properties.Append .CreateProperty("ColumnWidth", 3, -1)
      .Properties.Append .CreateProperty("ColumnOrder", 3, 0)
      .Properties.Append .CreateProperty("ColumnHidden", 1, False)
      .Properties.Append .CreateProperty("DecimalPlaces", 2, 2)
      .Properties.Append .CreateProperty("DisplayControl", 3, 111)
      .Properties.Append .CreateProperty("RowSourceType", 10, "Table/Query")
      .Properties.Append .CreateProperty("RowSource", 12, SRC)
      .Properties.Append .CreateProperty("BoundColumn", 3, 1)
      .Properties.Append .CreateProperty("ColumnCount", 3, 2)
      .Properties.Append .CreateProperty("ColumnHeads", 1, False)
      .Properties.Append .CreateProperty("ColumnWidths", 10, "0;1701")
      .Properties.Append .CreateProperty("ListRows", 3, 16)
      .Properties.Append .CreateProperty("ListWidth", 10, "0twip")
      .Properties.Append .CreateProperty("LimitToList", 1, True)
      .Properties.Append .CreateProperty("TextAlign", 2, 0)
      .Properties.Append .CreateProperty("AllowValueListEdits", 1, False)
      .Properties.Append .CreateProperty("AggregateType", 4, -1)
      .Properties.Append .CreateProperty("ShowOnlyRowSourceValues", 1, True)
      .Properties.Append .CreateProperty("ResultType", 2, 0)
      .Properties.Append .CreateProperty("CurrencyLCID", 4, 0)
   End With
   Return

End Sub