frmmainexe.frm

很好用的Access工具

        End If
        sText = sText & vbCrLf
        iCount = 0
        Do While iCount <= qDB.Indexes - 1
            With qlIndex(iCount)
                If .Table = iTable Then
                    'sText = sText & "Set diIndex = dtTable.CreateIndex(""" & .Name & """)" & vbCrLf
                    'sText = sText & "Set dfField = diIndex.CreateField(""" & qlField(.FieldIndex).Name & """, " & qFType(qlField(.FieldIndex).Type).Code
                    'If qlField(.FieldIndex).Type = dbText Then
                    'sText = sText & ", " & qlField(.FieldIndex).Size & ")" & vbCrLf
                    'Else
                    'sText = sText & ")" & vbCrLf
                    'End If
                    'If .Sort Then
                    'sText = sText & "dfField.Attributes = dbDescending" & vbCrLf
                    'End If
                    '
                    'sText = sText & vbCrLf & "With diIndex" & vbCrLf
                    'sText = sText & "    .Fields.Append dfField" & vbCrLf
                    'sText = sText & "    .Primary = " & qlIndex(iCount).Primary & vbCrLf
                    'sText = sText & "    .Unique = " & qlIndex(iCount).Unique & vbCrLf
                    'sText = sText & "End With" & vbCrLf
                    'sText = sText & "dtTable.Indexes.Append diIndex" & vbCrLf & vbCrLf
                    
                    sText = sText & "Index_Create dtTable, """ & .Name & """, """ & qlField(.FieldIndex).Name & """," _
                                  & qFType(qlField(.FieldIndex).Type).Code
                    sBack = ""
                    If qlIndex(iCount).Unique Then sBack = ", True"
                    If qlIndex(iCount).Primary Then
                        sBack = ", True" & sBack
                    ElseIf sBack > "" Then
                        sBack = ", " & sBack
                    End If
                    If qlIndex(iCount).Sort Then
                        sBack = ", True" & sBack
                    ElseIf sBack > "" Then
                        sBack = ", " & sBack
                    End If
                    If qlField(.FieldIndex).Type = dbText Then
                        sBack = ", " & qlField(.FieldIndex).Size & sBack
                    ElseIf sBack > "" Then
                        sBack = ", " & sBack
                    End If
                    
                    sText = sText & sBack & vbCrLf
                End If
            End With
            iCount = iCount + 1
        Loop
        
        sText = sText & "' Create field"
        If qlTable(iTable).Fields > 1 Then sText = sText & "s"
        sText = sText & vbCrLf
        iCount = 0
        Do While iCount <= qDB.Fields - 1
            If qlField(iCount).Table <> iTable Then 'Or qlField(iCount).Index Then
                GoTo DC_Field_Complete
            End If
            
            'sText = sText & "Set dfField = dtTable.CreateField(""" & qlField(iCount).Name & """, " & qFType(qlField(iCount).Type).Code
            'If qlField(iCount).Type = dbText Then
            '   sText = sText & ", " & qlField(iCount).Size & ")" & vbCrLf
            'Else
            '   sText = sText & ")" & vbCrLf
            'End If
            'sText = sText & "With dfField" & vbCrLf
            'If qlField(iCount).Attributes > "" Then sText = sText & "    .Attributes = " & qlField(iCount).Attributes & vbCrLf
            'sText = sText & "    .Required = " & qlField(iCount).Required & vbCrLf
            'If qlField(iCount).DefaultValue > "" Then sText = sText & "    .DefaultValue = """ & qlField(iCount).DefaultValue & """" & vbCrLf
            'sText = sText & "End With" & vbCrLf
            'sText = sText & "dtTable.Fields.Append dfField" & vbCrLf & vbCrLf
            sBack = ""
            sText = sText & "Field_Create dtTable, """ & qlField(iCount).Name & """, " _
                          & qFType(qlField(iCount).Type).Code
            If qlField(iCount).DefaultValue > "" Then sBack = ", """ & qlField(iCount).DefaultValue
            If qlField(iCount).Required = True Then
                sBack = ", True" & sBack
            ElseIf sBack > "" Then
                sBack = ", " & sBack
            End If
            If qlField(iCount).Attributes > "" Then
                sBack = ", " & qlField(iCount).Attributes & sBack
            ElseIf sBack > "" Then
                sBack = ", " & sBack
            End If
            If qlField(iCount).Type = dbText Then
                sBack = ", " & qlField(iCount).Size & sBack
            ElseIf sBack > "" Then
                sBack = ", " & sBack
            End If
            sText = sText & sBack & vbCrLf
DC_Field_Complete:
                iCount = iCount + 1
            Loop
            sText = sText & "dbData.TableDefs.Append dtTable" & vbCrLf & vbCrLf
DC_Table_Complete:
        iTable = iTable + 1
    Loop

    If qDB.Relations > 1 Then
        sText = sText & vbCrLf & "' Create Relations"
    ElseIf qDB.Relations = 1 Then
        sText = sText & vbCrLf & "' Create Relation"
    End If
    sText = sText & vbCrLf

    iCount = 0
    Do While iCount <= qDB.Relations - 1
        With qlRelation(iCount)
            sText = sText & "Relation_Create """ & .Name & """, """ & qlTable(.Table).Name _
                          & """, """ & qlTable(.ForeignTable).Name & """, """ _
                          & qlField(.Field).Name & """, """ & qlField(.ForeignField).Name & """"
            If .Attributes > "" Then sText = sText & ", " & .Attributes
        End With
        sText = sText & vbCrLf
        iCount = iCount + 1
    Loop

    If qDB.Tables > 0 Then sText = sText & "Set dtTable = Nothing" & vbCrLf
    
    'If qDB.Relations > 0 Then sText = sText & "Set drRelation = Nothing" & vbCrLf
    'If qDB.Indexes > 0 Then sText = sText & "Set diIndex = Nothing" & vbCrLf
    'If qDB.Fields > 0 Then sText = sText & "Set dfField = Nothing" & vbCrLf
    If qDB.Queries > 0 Then
        sText = sText & "' Set up queries" & vbCrLf
        sText = sText & "Query_Definition" & vbCrLf
    End If
    
    sText = sText & "Set dbData = Nothing" & vbCrLf & vbCrLf
    
    sText = sText & "' Creation Successful" & vbCrLf
    sText = sText & "Database_Create = True" & vbCrLf
    sText = sText & "Exit Function" & vbCrLf & vbCrLf
    sText = sText & "' Whoops an error occured" & vbCrLf
    sText = sText & "Database_Create_Error:" & vbCrLf
    sText = sText & "' #Add code to trap for errors" & vbCrLf
    sText = sText & "Database_Create = False" & vbCrLf
    sText = sText & "End Function" & vbCrLf & vbCrLf
    sSubText = Add_Subroutines(iSubOption)
    
    sText = sText & sSubText
    
    ' Set up Query Information
    sQuery = "Private Sub Query_Definition()" & vbCrLf & vbCrLf
    sQuery = sQuery & "Dim sSQLText As String" & vbCrLf
    sQuery = sQuery & "Dim dqQuery As QueryDef" & vbCrLf & vbCrLf
    
    iCount = 0
    Do While iCount < qDB.Queries
        sQuery = sQuery & "' QUERY: " & qlQuery(iCount).Name & vbCrLf
        sQuery = sQuery & qlQuery(iCount).SQLText
        sQuery = sQuery & "set dqQuery = dbData.CreateQueryDef(""" & qlQuery(iCount).Name & """, sSQLText)" & vbCrLf
        iCount = iCount + 1
    Loop
    sQuery = sQuery & vbCrLf & "End Sub" & vbCrLf
    Database_Compile = True
    Exit Function
Database_CompileErr:
    MsgBox "An error occured while analysing the Database." & vbCrLf & "Error: " & Err.Description
    Database_Compile = False
End Function


Private Function Add_Subroutines(ByVal iOptions As Integer) As String
    Dim sSub As String

    If iOptions And 1 = 1 Then
        sSub = sSub & "Private Sub Field_Create(dtTable as TableDef, _" & vbCrLf
        sSub = sSub & "                         Name As String, _" & vbCrLf
        sSub = sSub & "                         FieldType As Integer, _" & vbCrLf
        sSub = sSub & "                         Optional Size As Integer = 0, _" & vbCrLf
        sSub = sSub & "                         Optional Attributes As Long = 0, _" & vbCrLf
        sSub = sSub & "                         Optional Required As Boolean = False, _" & vbCrLf
        sSub = sSub & "                         Optional DefaultValue As String = """")" & vbCrLf
        sSub = sSub & "Dim dfField As Field" & vbCrLf & vbCrLf
        sSub = sSub & "On Error Goto Field_Create_Err" & vbCrLf & vbCrLf
        sSub = sSub & "' Create Field in Table: dtTable" & vbCrLf & vbCrLf
        sSub = sSub & "If FieldType = dbText Then" & vbCrLf
        sSub = sSub & "  Set dfField = dtTable.CreateField(Name, FieldType, Size)" & vbCrLf
        sSub = sSub & "Else" & vbCrLf
        sSub = sSub & "  Set dfField = dtTable.CreateField(Name, FieldType)" & vbCrLf
        sSub = sSub & "End If" & vbCrLf & vbCrLf
        sSub = sSub & "dfField.Attributes = Attributes" & vbCrLf
        sSub = sSub & "dfField.Required = Required" & vbCrLf
        sSub = sSub & "dfField.DefaultValue = DefaultValue" & vbCrLf & vbCrLf
        sSub = sSub & "dtTable.Fields.Append dfField" & vbCrLf & vbCrLf
        sSub = sSub & "Set dfField = Nothing" & vbCrLf
        sSub = sSub & "Exit Sub" & vbCrLf
        sSub = sSub & "Field_Create_Err:" & vbCrLf
        sSub = sSub & "' Whoops an error occured" & vbCrLf
        sSub = sSub & "' #Add code to trap for errors" & vbCrLf
        sSub = sSub & "Set dfField = Nothing" & vbCrLf
        sSub = sSub & "End Sub" & vbCrLf
    End If
    If iOptions And 2 = 2 Then
        sSub = sSub & "Private Sub Index_Create(dtTable As TableDef, _" & vbCrLf
        sSub = sSub & "                         Name As String, _" & vbCrLf
        sSub = sSub & "                         FieldName As String, _" & vbCrLf
        sSub = sSub & "                         FieldType As DataTypeEnum, _" & vbCrLf
        sSub = sSub & "                         Optional Size As Integer = 0, _" & vbCrLf
        sSub = sSub & "                         Optional Sort As Boolean = False, _" & vbCrLf
        sSub = sSub & "                         Optional Primary As Boolean = False, _" & vbCrLf
        sSub = sSub & "                         Optional Unique As Boolean = False)" & vbCrLf & vbCrLf
        sSub = sSub & "On Error GoTo Index_Create_Err" & vbCrLf & vbCrLf
        sSub = sSub & "Dim diIndex As Index" & vbCrLf
        sSub = sSub & "Dim dfField As Field" & vbCrLf & vbCrLf
        sSub = sSub & "Set diIndex = dtTable.CreateIndex(Name)" & vbCrLf
        sSub = sSub & "Set dfField = diIndex.CreateField(FieldName, FieldType)" & vbCrLf & vbCrLf
        sSub = sSub & "If FieldType = dbText Then" & vbCrLf
        sSub = sSub & "dfField.Size = Size" & vbCrLf
        sSub = sSub & "End If" & vbCrLf & vbCrLf
        sSub = sSub & "If Sort Then" & vbCrLf
        sSub = sSub & "dfField.Attributes = dbDescending" & vbCrLf
        sSub = sSub & "End If" & vbCrLf & vbCrLf
        sSub = sSub & "With diIndex" & vbCrLf
        sSub = sSub & "  .Fields.Append dfField" & vbCrLf
        sSub = sSub & "  .Primary = Primary" & vbCrLf
        sSub = sSub & "  .Unique = Unique" & vbCrLf
        sSub = sSub & "End With" & vbCrLf & vbCrLf
        sSub = sSub & "dtTable.Indexes.Append diIndex" & vbCrLf & vbCrLf
        sSub = sSub & "Set diIndex = Nothing" & vbCrLf
        sSub = sSub & "Set dfField = Nothing" & vbCrLf
        sSub = sSub & "Exit Sub" & vbCrLf & vbCrLf
        sSub = sSub & "Index_Create_Err:" & vbCrLf
        sSub = sSub & "' Whoops an error occured" & vbCrLf
        sSub = sSub & "' #Add code to trap for errors" & vbCrLf
        sSub = sSub & "Set diIndex = Nothing" & vbCrLf
        sSub = sSub & "Set dfField = Nothing" & vbCrLf & vbCrLf
        sSub = sSub & "End Sub" & vbCrLf
    End If
    If iOptions And 4 = 4 Then
        sSub = sSub & "Private Sub Relation_Create(Name As String, _" & vbCrLf
        sSub = sSub & "                            Table As String, _" & vbCrLf
        sSub = sSub & "                            ForeignTable As String, _" & vbCrLf
        sSub = sSub & "                            Field As String, _" & vbCrLf
        sSub = sSub & "                            ForeignField As String, _" & vbCrLf
        sSub = sSub & "                            Optional Attributes As Long = 0)" & vbCrLf & vbCrLf
        sSub = sSub & "On Error GoTo Relation_Create_Err" & vbCrLf & vbCrLf
        sSub = sSub & "Dim drRelation As Relation" & vbCrLf
        sSub = sSub & "Dim dfField As Field" & vbCrLf
        sSub = sSub & "Set drRelation = dbdata.CreateRelation(Name, Table, ForeignTable, Attributes)" & vbCrLf
        sSub = sSub & "drRelation.Fields.Append drRelation.CreateField(Field)" & vbCrLf
        sSub = sSub & "drRelation.Fields(Field).ForeignName = ForeignField" & vbCrLf
        sSub = sSub & "dbdata.Relations.Append drRelation" & vbCrLf & vbCrLf
        sSub = sSub & "Set dfField = Nothing" & vbCrLf
        sSub = sSub & "Set drRelation = Nothing" & vbCrLf & vbCrLf
        sSub = sSub & "Exit Sub" & vbCrLf
        sSub = sSub & "Relation_Create_Err:" & vbCrLf
        sSub = sSub & "' Whoops an error occured" & vbCrLf
        sSub = sSub & "' #Add code to trap for errors" & vbCrLf
        sSub = sSub & "Set dfField = Nothing" & vbCrLf
        sSub = sSub & "Set drRelation = Nothing" & vbCrLf & vbCrLf
        sSub = sSub & "End Sub" & vbCrLf
    End If
    Add_Subroutines = sSub
End Function

Private Function Information_SQL(ByVal SQLText As String) As String
    Dim iCount As Integer
    Dim sChar As String
    Dim sLine As String
    Dim bQuote As Boolean
    Dim bEnd As Boolean
    Dim sReturn As String
    Dim iLineItems As Integer
    
    ' Replace quotes
    sReturn = ""
    sLine = "sSQLText = " & Chr$(34)
    iLineItems = 0
    bQuote = True
    iCount = 1
    Do While iCount < Len(SQLText)
        sChar = Mid$(SQLText, iCount, 1)
        Select Case sChar
            Case vbCr
                bEnd = True
                sChar = " & vbCrLf"
                If bQuote Then sChar = Chr$(34) & sChar
                bQuote = False
            Case vbLf
                bEnd = True
                sChar = ""
            Case Chr$(34)
                sChar = " & Chr$(34)"
                If bQuote Then sChar = Chr$(34) & sChar
                bQuote = False
            Case Else
                If UCase(sChar) Like "[A-Z]" Then
                    bEnd = False
                Else
                    bEnd = True
                End If
                If Not bQuote Then sChar = " & " & Chr$(34) & sChar
                bQuote = True
        End Select
        sLine = sLine & sChar
        iLineItems = iLineItems + Len(sChar)
        If (Len(sLine) > 90 And bEnd) Or Len(sLine) > 110 Then
            'Debug.Print sLine
            If bQuote Then sLine = sLine & Chr$(34)
            sReturn = sReturn & sLine & vbCrLf
            sLine = "sSQLText = sSQLText & " & Chr$(34)
            iLineItems = 0
            bQuote = True
        End If
        iCount = iCount + 1
    Loop
    If iLineItems > 0 Then
        If bQuote Then sLine = sLine & Chr$(34)
        sReturn = sReturn & sLine & vbCrLf
    End If
    Information_SQL = sReturn
End Function