Option Compare Database
Option Explicit
 
Function SetSeed(strTable As String, strAutoNum As String, lngID As Long) As Boolean
    'Amaç:   ADOX kullanarak otomatik sayıyı sıfırlamak.
    Dim cat As New ADOX.Catalog
 
    Set cat.ActiveConnection = CurrentProject.Connection
    cat.Tables(strTable).Columns(strAutoNum).Properties("Seed") = lngID
    Set cat = Nothing
    SetSeed = True
End Function
 
Function ShowAllTables(Optional bShowFieldsToo As Boolean)
    'Amaç:   ADOX ile tabloları listeler.
    Dim cat As New ADOX.Catalog 'ADOX un kök nesnesi.
    Dim tbl As ADOX.Table       'Tablolar içinde her tablo.
    Dim col As ADOX.Column      'Tablo içindeki her sütun.
 
    'Hâlihazırdaki veritabanının listesini işaretliyoruz.
    Set cat.ActiveConnection = CurrentProject.Connection
 
    'Tüm tablolar üstünde döngü.
    For Each tbl In cat.Tables
        Debug.Print tbl.Name, tbl.Type
        If bShowFieldsToo Then
        'Tüm sütunlar üstünde döngü.
        For Each col In tbl.Columns
            Debug.Print , col.Name, col.Type
        Next
        Debug.Print "--------------------------------"
        'Stop
        End If
    Next
 
    'Hafızadaki bilgileri temizleme
    Set col = Nothing
    Set tbl = Nothing
    Set cat = Nothing
End Function
 
Function ShowPropsADOX(strTable As String, Optional bShowPropertiesToo As Boolean)
    'Amaç:   ADOX ile tüm sütunları ve istenirse özelliklerini gösterme.
    Dim cat As New ADOX.Catalog 'ADOX un kök nesnesi.
    Dim tbl As ADOX.Table       'Tablolar içinde her tablo.
    Dim col As ADOX.Column      'Tablodaki her sütun.
    Dim prp As ADOX.Property
 
    'Hâlihazırdaki veritabanının listesini işaretliyoruz.
    Set cat.ActiveConnection = CurrentProject.Connection
    Set tbl = cat.Tables(strTable)
 
    For Each col In tbl.Columns
        Debug.Print col.Name        ', col.Properties("Fixed length"), col.Type
        If bShowPropertiesToo Then
            For Each prp In col.Properties
                Debug.Print , prp.Name, prp.Type, prp.Value
            Next
            Debug.Print "--------------------------------"
            'Stop
        End If
    Next
 
    'Hafızadaki bilgileri temizleme
    Set prp = Nothing
    Set col = Nothing
    Set tbl = Nothing
    Set cat = Nothing
End Function
 
Function CreateTableAdox()
    'Amaç:   ADOX kullanarak veritabanı oluşturmak.
    Dim cat As New ADOX.Catalog
    Dim tbl As ADOX.Table
 
    Set cat.ActiveConnection = CurrentProject.Connection
    'Tablo oluşturucuya ulaşma.
    Set tbl = New ADOX.Table
    tbl.Name = "tblAdoxContractor"
 
    'Sütunları oluşturma
    With tbl.Columns
        .Append "ContractorID", adInteger   'Number (Long Integer)
        .Append "Surname", adVarWChar, 30   'Text (30 max)
        .Append "FirstName", adVarWChar, 20 'Text (20 max)
        .Append "Inactive", adBoolean       'Yes/No
        .Append "HourlyFee", adCurrency     'Currency
        .Append "PenaltyRate", adDouble     'Number (Double)
        .Append "BirthDate", adDate         'Date/Time
        .Append "Notes", adLongVarWChar     'Memo
        .Append "Web", adLongVarWChar       'Memo (for hyperlink)
 
        'Sütun özelliklerini oluşturma.
        'Otomatik sayı
        With !ContractorID
            Set .ParentCatalog = cat
 
            .Properties("Autoincrement") = True     'Otomatik sayı
            .Properties("Description") = "Automatically " & _
                "generated unique identifier for this record."
        End With
 
        'Gerekli alan
        With !Surname
            Set .ParentCatalog = cat
            .Properties("Nullable") = False         'Gerekli.
            .Properties("Jet OLEDB:Allow Zero Length") = False
        End With
 
        'Set a validation rule.
        With !BirthDate
            Set .ParentCatalog = cat
            .Properties("Jet OLEDB:Column Validation Rule") = _
                "Is Null Or <=Date()"
            .Properties("Jet OLEDB:Column Validation Text") = _
                "Birth date cannot be future."
        End With
 
        'Hyperlink alanı.
        With !Web
            Set .ParentCatalog = cat
            .Properties("Jet OLEDB:Hyperlink") = True 'Hyperlink.
        End With
    End With
 
    'Yeni tabloyu kataloga kaydetme.
    cat.Tables.Append tbl
    Debug.Print "tblAdoxContractor created."
    Set tbl = Nothing
 
    'Yeni tabloya ulaşma
    Set tbl = New ADOX.Table
    tbl.Name = "tblAdoxBooking"
 
    'Sütunlara ulaşma.
    With tbl.Columns
        .Append "BookingID", adInteger
        .Append "BookingDate", adDate
        .Append "ContractorID", adInteger
        .Append "BookingFee", adCurrency
        .Append "BookingNote", adWChar, 255
 
        'Alan özelliklerini oluşturma.
        With !BookingID                             'Otomatik sayı.
            .ParentCatalog = cat
            .Properties("Autoincrement") = True
        End With
        With !BookingNote                           'Gerekli.
            .ParentCatalog = cat
            .Properties("Nullable") = False
            .Properties("Jet OLEDB:Allow Zero Length") = False
        End With
    End With
 
    'Yeni tabloyu kaydetme.
    cat.Tables.Append tbl
    Debug.Print "tblAdoxBooking created."
 
        ‘Hafızadaki bilgileri temizleme
    Set tbl = Nothing
    Set cat = Nothing
End Function
 
Function ModifyTableAdox()
    'Amaç:   ADOX ile alan ekleme ve silme.
    Dim cat As New ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim col As New ADOX.Column
 
    'Ulaşma
    cat.ActiveConnection = CurrentProject.Connection
    Set tbl = cat.Tables("tblAdoxContractor")
 
    'Yeni sütun ekleme
    With col
        .Name = "MyDecimal"
        .Type = adNumeric   'ondalık tip.
        .Precision = 28     '28 basamaklı.
        .NumericScale = 8   '8 ondalıklı.
    End With
    tbl.Columns.Append col
    Set col = Nothing
    Debug.Print "Column added."
 
    'Sütun silme.
    tbl.Columns.Delete "MyDecimal"
    Debug.Print "Column deleted."
 
        ‘Hafızadaki bilgileri temizleme
    Set col = Nothing
    Set tbl = Nothing
    Set cat = Nothing
End Function
 
Function ModifyFieldPropAdox()
    'Amaç:   ADOX ile sütun özelliklerini değiştirme.
    'Not:      Alan boyutunu değiştiremezsiniz.
    Dim cat As New ADOX.Catalog
    Dim col As ADOX.Column
    Dim prp As ADOX.Property
 
    cat.ActiveConnection = CurrentProject.Connection
    Set col = cat.Tables("MyTable").Columns("MyField")
    'col.ParentCatalog = cat
    Set prp = col.Properties("Nullable")
    'Özelliği okumak
    Debug.Print prp.Name, prp.Value, (prp.Type = adBoolean)
    'Özelliği değiştirmek
    prp.Value = Not prp.Value
 
        'Hafızadaki bilgileri temizleme
    Set prp = Nothing
    Set col = Nothing
    Set cat = Nothing
End Function
 
Function DeleteTableAdox()
    'Amaç:   ADOX ile tablo silmek.
    Dim cat As New ADOX.Catalog
 
    cat.ActiveConnection = CurrentProject.Connection
    cat.Tables.Delete "MyTable"
    Set cat = Nothing
End Function
 
Function CreateIndexesAdox()
    'Amaç:   ADOX ile indexleme yapmak.
    Dim cat As New ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim ind As ADOX.Index
 
    'Ulaşma
    Set cat.ActiveConnection = CurrentProject.Connection
    Set tbl = cat.Tables("tblAdoxContractor")
 
    'Anahtar alan oluşturmak
    Set ind = New ADOX.Index
    ind.Name = "PrimaryKey"
    ind.PrimaryKey = True
    ind.Columns.Append "ContractorID"
    tbl.Indexes.Append ind
    Set ind = Nothing
 
    'Bir sütuna index oluşturma.
    Set ind = New ADOX.Index
    ind.Name = "Inactive"
    ind.Columns.Append "Inactive"
    tbl.Indexes.Append ind
    Set ind = Nothing
 
    'Çoklu alanı indexleme.
    Set ind = New ADOX.Index
    ind.Name = "FullName"
    With ind.Columns
        .Append "Surname"
        .Append "FirstName"
    End With
    tbl.Indexes.Append ind
 
        'Hafızadaki bilgileri temizleme
    Set ind = Nothing
    Set tbl = Nothing
    Set cat = Nothing
    Debug.Print "tblAdoxContractor indexes created."
End Function
 
Function DeleteIndexAdox()
    'Amaç:   ADOX ile indexleri silmek.
    Dim cat As New ADOX.Catalog
    cat.ActiveConnection = CurrentProject.Connection
    cat.Tables("tblAdoxContractor").Indexes.Delete "Inactive"
    Set cat = Nothing
End Function
 
Function CreateKeyAdox()
    'Amaç:   ADOX ile ilişkilendirme oluşturma.
    Dim cat As New ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim ky As New ADOX.Key
 
    Set cat.ActiveConnection = CurrentProject.Connection
    Set tbl = cat.Tables("tblAdoxBooking")
 
    ' tblAdoxContractor.ContractorID alanına yabancı anahtar oluşturmak
    With ky
        .Type = adKeyForeign
        .Name = "tblAdoxContractortblAdoxBooking"
        .RelatedTable = "tblAdoxContractor"
        .Columns.Append "ContractorID"      'Tek alan.
        .Columns("ContractorID").RelatedColumn = "ContractorID"
        .DeleteRule = adRISetNull   
    End With
    tbl.Keys.Append ky
 
    Set ky = Nothing
    Set tbl = Nothing
    Set cat = Nothing
    Debug.Print "Key created."
End Function
 
Function ShowKeyAdox(strTableName As String)
    'Amaç:   ADOX ile ilişkileri gösterme.
    Dim cat As New ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim ky As ADOX.Key
    Dim strRIName As String
 
    Set cat.ActiveConnection = CurrentProject.Connection
    Set tbl = cat.Tables(strTableName)
 
    For Each ky In tbl.Keys
        With ky
            Select Case .DeleteRule
            Case adRINone
                strRIName = "No delete rule"
            Case adRICascade
                strRIName = "Cascade delete"
            Case adRISetNull
                strRIName = "Cascade to null"
            Case adRISetDefault
                strRIName = "Cascade to default"
            Case Else
                strRIName = "DeleteRule of " & .DeleteRule & " unknown."
            End Select
            Debug.Print "Key: " & .Name & ", to table: " & .RelatedTable & ", with: " & strRIName
        End With
    Next
 
    Set ky = Nothing
    Set tbl = Nothing
    Set cat = Nothing
End Function
 
Function DeleteKeyAdox()
    'Amaç:   ADOX ile ilişkileri silme.
    Dim cat As New ADOX.Catalog
    Dim tbl As ADOX.Table
 
    Set cat.ActiveConnection = CurrentProject.Connection
    cat.Tables("tblAdoxBooking").Keys.Delete "tblAdoxContractortblAdoxBooking"
 
    Set cat = Nothing
    Debug.Print "Key deleted."
End Function
 
Function CreateViewAdox()
    'Amaç:   ADOX ile sorgu oluşturma.
    Dim cat As New ADOX.Catalog
    Dim cmd As New ADODB.Command
    Dim strSql As String
 
    'Ulaşma.
    cat.ActiveConnection = CurrentProject.Connection
 
    'Komut cümlesi özelliğine sql cümlesi yükleme
    strSql = "SELECT BookingID, BookingDate FROM tblDaoBooking;"
    cmd.CommandText = strSql
 
    'Komutu koleksiyon listesine ekleme.
    cat.Views.Append "qryAdoxBooking", cmd
 
        'Hafızadaki bilgileri temizleme.
    Set cmd = Nothing
    Set cat = Nothing
    Debug.Print "View created."
End Function
 
Function CreateProcedureAdox()
    'Amaç:   ADOX parametre veya fonksiyon sorgusu oluşturma.
    Dim cat As New ADOX.Catalog
    Dim cmd As New ADODB.Command
    Dim strSql As String
 
    'Ulaşma.
    cat.ActiveConnection = CurrentProject.Connection
 
    'SQL cümlesini Komut cümlesi özelliğine atama.
    strSql = "PARAMETERS StartDate DateTime, EndDate DateTime; " & _
        "DELETE FROM tblAdoxBooking " & _
        "WHERE BookingDate Between StartDate And EndDate;"
    cmd.CommandText = strSql
 
	'Komutu koleksiyon listesine ekleme.
    cat.Procedures.Append "qryAdoxDeleteBooking", cmd
 
        ‘Hafızadaki bilgileri temizleme.
    Set cmd = Nothing
    Set cat = Nothing
    Debug.Print "Procedure created."
End Function
 
Function ShowProx()
    'Amaç:   ADOX ile sorguları listeleme.
    Dim cat As New ADOX.Catalog
    Dim proc As ADOX.Procedure
    Dim vw As ADOX.View
 
    cat.ActiveConnection = CurrentProject.Connection
 
    Debug.Print "Procedures: " & cat.Procedures.Count
    For Each proc In cat.Procedures
        Debug.Print proc.Name
    Next
    Debug.Print cat.Procedures.Count & " procedure(s)"
    Debug.Print
 
    Debug.Print "Views " & cat.Views.Count
    For Each vw In cat.Views
        Debug.Print vw.Name
    Next
 
    Set cat = Nothing
End Function
 
Function ExecuteProcedureAdox()
    'Amaç:   ADOX ile parametre sorgusu çalıştırma.
    Dim cat As New ADOX.Catalog
    Dim cmd As ADODB.Command
    Dim lngCount As Long
 
    'Ulaşma.
    cat.ActiveConnection = CurrentProject.Connection
    Set cmd = cat.Procedures("qryAdoxDeleteBooking").Command
 
    'Parametreleri oluşturma
    cmd.Parameters("StartDate") = #1/1/2004#
    cmd.Parameters("EndDate") = #12/31/2004#
 
    'Olayı çalıştırma
    cmd.Execute lngCount
    Debug.Print lngCount & " record(s) deleted."
 
    'Alternatif: parametreleri matrisle verme.
    'cmd.Execute , Array(#1/1/2004#, #12/31/2004#)
 
        'Hafızadaki bilgileri temizleme.
    Set cmd = Nothing
    Set cat = Nothing
End Function
 
Function DeleteProcedureAdox()
    'Amaç:   ADOX ile sorgu silme.
    Dim cat As New ADOX.Catalog
    Dim cmd As ADODB.Command
    Dim lngCount As Long
 
    'Ulaşma.
    cat.ActiveConnection = CurrentProject.Connection
    cat.Procedures.Delete "qryAdoxDeleteBooking"
    Set cat = Nothing
End Function
 
Function CreateDatabaseAdox()
    'Amaç:   ADOX ile veritabanı oluşturma.
    Dim cat As New ADOX.Catalog
    Dim strFile As String
 
    strFile = "C:\SampleADOX.mdb"
    cat.Create "Provider='Microsoft.Jet.OLEDB.4.0';" & _
        "Data Source='" & strFile & "'"
    Set cat = Nothing
    Debug.Print strFile & " created."
End Function
 
Function DeleteAllAndResetAutoNum(strTable As String) As Boolean
    'Amaç:   ADOX ile tüm verileri silme ve otomatik sayıyı sıfırlama.
    '           Otomatik sayı alanına nasıl ulaşışldığını gösterme.
    'Argüman:  Tablo adını değiştirme.
    'Geriye dönen:    İşlem tamam ise doğru.
    Dim cat As New ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim col As ADOX.Column
    Dim strSql As String
 
    'Tüm verileri silme.
    strSql = "DELETE FROM [" & strTable & "];"
    CurrentProject.Connection.Execute strSql
 
    'Tüm otomatik sayılı alanları bulup sıfırlama.
    cat.ActiveConnection = CurrentProject.Connection
    Set tbl = cat.Tables(strTable)
    For Each col In tbl.Columns
        If col.Properties("Autoincrement") Then
            col.Properties("Seed") = 1
            DeleteAllAndResetAutoNum = True
        End If
    Next
End Function
 
Function GetSeedADOX(strTable As String, Optional ByRef strCol As String) As Long
    'Amaç:   Otomatik sayı kökünü okuma.
    'Arguman: strTable kontrol edilen tablo.
    '           strCol = Alan adı. Eğer var ise kod onu bulup çıkarıyor.
    'Geriye dönen:    Kök sayısı.
    Dim cat As New ADOX.Catalog 'ADOX un kök nesnesi.
    Dim tbl As ADOX.Table       'Tablo içindeki her tablo.
    Dim col As ADOX.Column      'Tablo içindeki her sütun.
 
    'Hâlihazırdaki veritabanının listesini işaretliyoruz.
    Set cat.ActiveConnection = CurrentProject.Connection
    Set tbl = cat.Tables(strTable)
 
    'Otomatik sayılı alanı bulana kadar dön.
    For Each col In tbl.Columns
        If col.Properties("Autoincrement") Then
            strCol = col.Name
            GetSeedADOX = col.Properties("Seed")
            Exit For    'There can be only one AutoNum.
        End If
    Next
 
        'Hafızadaki bilgileri temizleme
    Set col = Nothing
    Set tbl = Nothing
    Set cat = Nothing
End Function
 
Function ResetSeed(strTable As String) As String
    'Amaç:   ADOX ile otomatik sayı kökünü sıfırlama.
    Dim strAutoNum As String    'Otomatik sayı tipli alan adı.
    Dim lngSeed As Long         'Kökün halıhazırdaki değeri.
    Dim lngNext As Long         'Kullanılmayın sonraki değer.
    Dim strSql As String
    Dim strResult As String
 
    lngSeed = GetSeedADOX(strTable, strAutoNum)
    If strAutoNum = vbNullString Then
        strResult = "AutoNumber not found."
    Else
        lngNext = Nz(DMax(strAutoNum, strTable), 0) + 1
        If lngSeed = lngNext Then
            strResult = strAutoNum & " already correctly set to " & lngSeed & "."
        Else
            Debug.Print lngNext, lngSeed
            strSql = "ALTER TABLE [" & strTable & "] ALTER COLUMN [" & strAutoNum & "] COUNTER(" & lngNext & ", 1);"
            Debug.Print strSql
            CurrentProject.Connection.Execute strSql
            strResult = strAutoNum & " reset from " & lngSeed & " to " & lngNext
        End If
    End If
    ResetSeed = strResult
End Function

Sub CreateRelationship(strDBPath As String,_
 strForeignTbl As String, strRelName As String,_
 strFTKey As String,strRelatedTbl As String, strRTKey As String)
   Dim catDB As ADOX.Catalog
   Dim tbl As ADOX.Table
   Dim key As ADOX.Key
 
   Set catDB = New ADOX.Catalog
   ' Open the catalog.
   catDB.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
      "Data Source =" & strDBPath
 
   Set key = New ADOX.Key
   ' Create the foreign key to define the relationship.
   With Key
      ' Specify name for the relationship in the Keys collection.
      .Name = strRelName
      ' Specify the related table's name.
      .RelatedTable = strRelatedTbl
      .Type = adKeyForeign
      ' Add the foreign key field to the Columns collection.
      .Columns.Append strFTKey
      ' Specify the field the foreign key is related to.
      .Columns(strFTKey).RelatedColumn = strRTKey
   End With
 
   Set tbl = New ADOX.Table
   ' Open the table and add the foreign key.
   Set tbl = catDB.Tables(strForeignTbl)
   tbl.Keys.Append key
 
   Set catDB = Nothing
End Sub