USUÁRIO:      SENHA:        SALVAR LOGIN ?    Adicione o VBWEB na sua lista de favoritos   Fale conosco 

 

  Dicas

  Visual Basic    (Strings de Conexões)

Título da Dica:  Biblioteca de Acesso a Dados
Postada em 17/1/2004 por Mateus            
'REFERENCIAS:
'Microsoft Activex Data Objects 2.X Library
'Microsoft Activex Data Objects  Recordset 2.X Library
'Microsoft ADO ext. 2.X for DDL and Security

'FUNÇÕES EM ADO USANDO O JET4.0


'---------------------------------------CÓDIGO ------------------------------------

'JET OLEDB CONSTANTES

' Jet Engine Versions; used with the
' Jet OLEDB:Engine Type property.
Public Enum opgJetEngineType
    UNKNOWN = 0
    JET10 = 1
    JET11 = 2
    JET20 = 3
    JET3X = 4
    JET4X = 5
    DBASE3 = 10
    DBASE4 = 11
    DBASE5 = 12
    EXCEL30 = 20
    EXCEL40 = 21
    EXCEL50 = 22
    EXCEL80 = 23
    EXCEL90 = 24
    EXCHANGE4 = 30
    LOTUSWK1 = 40
    LOTUSWK3 = 41
    LOTUSWK4 = 42
    PARADOX3X = 50
    PARADOX4X = 51
    PARADOX5X = 52
    PARADOX7X = 53
    TEXT1X = 60
    HTML1X = 70
End Enum
' Bulk; used with the Jet OLEDB:Global Partial Bulk Ops and
' Jet OLEDB:Partial Bulk Ops properties.
Public Enum opgBulkOps
    BULKOPS_DEFAULT = 0
    PARTIAL = 1 ' Allow partial completion of the bulk                       ' operation. Could result in inconsistent                       ' changes since operations on some rows could                       ' succeed and others could fail.     NOPARTIAL = 2     ' Fail the bulk operation on a single error. End Enum
                      ' operation. Could result in inconsistent                       ' changes since operations on some rows could
                      ' succeed and others could fail.
    NOPARTIAL = 2     ' Fail the bulk operation on a single error.
End Enum

' Database locking mode; used with the
' Jet OLEDB:Database Locking Mode property.
Public Enum opgDBLockMode
    LOCK_PAGE = 0
    LOCK_ROW = 1
End Enum
' Connection shutdown mode; used with the
' Jet OLEDB:Connection Control property.
Public Enum opgShutdownMode
    PASSIVESHUTDOWN = 1
    Normal = 2
End Enum
' Security GUIDS for Access objects.
Global Const SECURE_FORMS = "{c49c842e-9dcb-11d1-9f0a-00c04fc2c2e0}"
Global Const SECURE_REPORTS = "{c49c8430-9dcb-11d1-9f0a-00c04fc2c2e0}"
Global Const SECURE_MACROS = "{c49c842f-9dcb-11d1-9f0a-00c04fc2c2e0}"
Global Const SECURE_MODULES = "{c49c8432-9dcb-11d1-9f0a-00c04fc2c2e0}"
' Jet OLE DB provider-defined schema rowsets.
Global Const REPLPARTIALFILTERLIST = "{e2082df0-54ac-11d1-bdbb-00c04fb92675}"
Global Const REPLCONFLICTTABLES = "{e2082df2-54ac-11d1-bdbb-00c04fb92675}"
Global Const USERROSTER = "{947bb102-5d43-11d1-bdbf-00c04fb92675}"
Global Const ISAMStats = "{8703b612-5d43-11d1-bdbf-00c04fb92675}"

' ABERTURA DE BASES DE DADOS ADO

'ABRIR BASE DE DADOS COMO SHARED
Sub OpenDBShared(strDBPath As String)
    Dim cnnDB As ADODB.Connection
        ' Initialize Connection object.
        Set cnnDB = New ADODB.Connection
        ' Specify the Microsoft Jet 4.0 provider and then open the
        ' database specified in the strDBPath variable.
        With cnnDB
            .Provider = "Microsoft.Jet.OLEDB.4.0"
            .Open strDBPath         ' Add your own code to work with database here.
        End With     ' Close Connection object and destroy object variable.
        cnnDB.Close
        Set cnnDB = Nothing
End Sub

' ABRIR BASE DE DADOS COMO READ-ONLY
Sub OpenDBReadOnly(strDBPath As String)
    Dim cnnDB As ADODB.Connection
    Set cnnDB = New ADODB.Connection
    With cnnDB
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Mode = adModeRead
        .Open strDBPath
    ' Add your own code to work with database here.
    End With
    cnnDB.Close
    Set cnnDB = Nothing
End Sub

' ABRIR CONEXAO JET
Function GetJetConnection(strDBPath As String, _
    lngMode As ADODB.ConnectModeEnum, _
    Optional strDBPwd As String, _
    Optional strSysDBPath As String, _
    Optional strUserID As String, _
    Optional strUserPwd As String, _
    Optional lngEngineType As opgJetEngineType) _
    As ADODB.Connection
    Dim cnnDB As ADODB.Connection
        Set cnnDB = New ADODB.Connection
        With cnnDB
            .Provider = "Microsoft.Jet.OLEDB.4.0"
            .Mode = lngMode
            .Properties("Jet OLEDB:Database Password") = strDBPwd
            .Properties("Jet OLEDB:System Database") = strSysDBPath
            .Properties("Jet OLEDB:Engine Type") = lngEngineType
            .Open ConnectionString:=strDBPath, _
            UserID:=strUserID, _
            Password:=strUserPwd
        End With
        Set GetJetConnection = cnnDB
  End Function
  
' IMPRIMIR A STRING DE CONEXAO CORRENTE
Sub PrintCurrentConnectString()
    Dim cnnDB As ADODB.Connection
        Set cnnDB = New ADODB.Connection
        ' Get connection to current database.
        'Set cnnDB = CurrentProject.Connection
        Debug.Print cnnDB.ConnectionString
        Set cnnDB = Nothing
End Sub

' ABRIR BASE DE DADOS EXCEL
Sub OpenExcelDatabase(strDBPath As String)
    Dim cnnDB As ADODB.Connection
        Set cnnDB = New ADODB.Connection
        ' Specify Excel 8.0 by using the Extended Properties
        ' property, and then open the Excel file specified
        ' by strDBPath.
        With cnnDB
            .Provider = "Microsoft.Jet.OLEDB.4.0"
            .Properties("Extended Properties") = "Excel 8.0"
            .Open strDBPath
            Debug.Print .ConnectionString
            .Close
        End With
        Set cnnDB = Nothing
End Sub

' ABRIR BASE DE DADOS HTML
Sub OpenHTMLDatabase(strHTMLPath As String)
    Dim cnnDB As ADODB.Connection
        Set cnnDB = New ADODB.Connection
        With cnnDB
            .Provider = "Microsoft.Jet.OLEDB.4.0"
            .Properties("Extended Properties") = "HTML Import"
            .Open "DATABASE=" & strHTMLPath & ";HDR=YES"
            Debug.Print .ConnectionString
            .Close
        End With
        Set cnnDB = Nothing
End Sub

' ABRIR DATA LINK
Sub OpenDataLink(strUDLPath As String)
    Dim cnnDB As ADODB.Connection
        Set cnnDB = New ADODB.Connection
        With cnnDB
            .Open "File Name=" & strUDLPath
            Debug.Print cnnDB.ConnectionString
            .Close
        End With
        Set cnnDB = Nothing
End Sub

' CRIAR E MODIFICAR BASES DE DADOS

' CRIAR BASE DE DADOS ACCESS
Sub CreateAccessDatabase(strDBPath As String)
    Dim catNewDB As ADOX.Catalog
        Set catNewDB = New ADOX.Catalog
        catNewDB.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & strDBPath
        Debug.Print catNewDB.ActiveConnection
        Set catNewDB = Nothing
End Sub

' CRIAR UMA BASE DE DADOS DE SISTEMA
Sub CreateSystemDatabase(strDBPath As String)
    Dim catNewDB As ADOX.Catalog
        Set catNewDB = New ADOX.Catalog
        catNewDB.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Jet OLEDB:Create System Database=True;" & _
        "Data Source=" & strDBPath
        Debug.Print catNewDB.ActiveConnection
    Set catNewDB = Nothing
End Sub

' LISTAR TABELAS ACCESS 1
Sub ListAccessTables(strDBPath As String)
    Dim catDB   As ADOX.Catalog
    Dim tblList As ADOX.Table
        Set catDB = New ADOX.Catalog
        ' Open the Catalog object.
        catDB.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & strDBPath
        ' Loop through all the tables, but not queries, and
        ' print their names and types.
        For Each tblList In catDB.Tables
            If tblList.Type <> "VIEW" Then
                Debug.Print tblList.Name & vbTab & tblList.Type
            End If
        Next
        Set catDB = Nothing
End Sub

' LISTAR TABELAS ACCESS 2
Sub ListAccessTables2(strDBPath As String)
    Dim cnnDB   As ADODB.Connection
    Dim rstList As ADODB.Recordset
        Set cnnDB = New ADODB.Connection
        ' Open the Connection object.
        With cnnDB
            .Provider = "Microsoft.Jet.OLEDB.4.0"
            .Open strDBPath
        End With
        ' Open the tables schema Recordset object.
        Set rstList = cnnDB.OpenSchema(adSchemaTables)
        ' Loop through the recordset and print the names
        ' and types in the Immediate pane.
        With rstList
            Do While Not .EOF
                If .Fields("TABLE_TYPE") <> "VIEW" Then
                    Debug.Print .Fields("TABLE_NAME") & vbTab & _
                    .Fields("TABLE_TYPE")
                End If
            .MoveNext
            Loop
        End With
    cnnDB.Close
    Set cnnDB = Nothing
End Sub

' CRIAR TABELA ACCESS
Sub CreateAccessTable(strDBPath As String)
    Dim catDB  As ADOX.Catalog
    Dim tblNew As ADOX.Table
        Set catDB = New ADOX.Catalog
        ' Open the Catalog object.
        catDB.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & strDBPath
        Set tblNew = New ADOX.Table
        ' Create a new Table object.
        With tblNew
            .Name = "Contacts"
            ' Create fields and append them to the Columns
            ' collection of the new Table object.
            With .Columns
                .Append "FirstName", adVarWChar
                .Append "LastName", adVarWChar
                .Append "Phone", adVarWChar
                .Append "Notes", adLongVarWChar
            End With
        End With
    ' Create the new table by adding the Table object
    ' to the Tables collection of the database.
    catDB.Tables.Append tblNew
    Set catDB = Nothing
End Sub

' CRIAR CAMPO AUTONUMERACAO
Sub CreateAutoNumberField(strDBPath As String)
    Dim catDB As ADOX.Catalog
    Dim tbl   As ADOX.Table
        Set catDB = New ADOX.Catalog
        ' Open the Catalog object.
        catDB.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & strDBPath
        Set tbl = New ADOX.Table
        With tbl
            .Name = "ContactsWithID"
            Set .ParentCatalog = catDB
            ' Create fields and append them to the
            ' Columns collection of the new Table object.
            With .Columns
                .Append "ContactId", adInteger
                ' Make the ContactId field auto-incrementing.
                .Item("ContactId").Properties("AutoIncrement") = True
                .Append "CustomerID", adVarWChar
                .Append "FirstName", adVarWChar
                .Append "LastName", adVarWChar
                .Append "Phone", adVarWChar, 20
                .Append "Notes", adLongVarWChar
            End With
        End With
    ' Create the new table by adding the Table object
    ' to the Tables collection of the database
    catDB.Tables.Append tbl
    Set catDB = Nothing
End Sub

' CRIAR TABELA COM UMA REGRA DE VALIDACAO
Sub CreateTableWithValidationRule(strDBPath As String)
    Dim catDB  As ADOX.Catalog
    Dim tblNew As ADOX.Table
        Set catDB = New ADOX.Catalog
        ' Open the Catalog object.
        catDB.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & strDBPath
        Set tblNew = New ADOX.Table
        ' Create a new Table object.
        With tblNew
            .Name = "ContactsWithRule"
            ' Create fields and append them to the
            ' Columns collection of the new Table object.
            With .Columns
                .Append "FirstName", adVarWChar
                .Append "LastName", adVarWChar
                .Append "Phone", adVarWChar
                .Append "FirstContact", adDate
                .Append "LastContact", adDate
                .Append "Notes", adLongVarWChar
            End With
            ' Create the new table by adding the Table object
            ' to the Tables collection of the database.
            catDB.Tables.Append tblNew
            ' Set a validation rule and text for the new table.
            .Properties("Jet OLEDB:Table Validation Rule") = _
            "LastContact >= FirstContact"
            .Properties("Jet OLEDB:Table Validation Text") = _
            "LastContact must be greater than or equal to FirstContact"
        End With
        Set catDB = Nothing
        End Sub
        
' LIGAR TABELA EXTERNA
Sub CreateLinkedExternalTable(strTargetDB As String, _
strProviderString As String, _
strSourceTbl As String, _
strLinkTblName As String)
    Dim catDB   As ADOX.Catalog
    Dim tblLink As ADOX.Table
        Set catDB = New ADOX.Catalog
        ' Open a Catalog object on the database
        ' in which to create the link.
        catDB.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & strTargetDB
        Set tblLink = New ADOX.Table
        With tblLink
            ' Name the new table and set its ParentCatalog
            ' property to the open Catalog to allow access
            ' to the Properties collection.
            .Name = strLinkTblName
            Set .ParentCatalog = catDB
            ' Set the properties to create the link.
            .Properties("Jet OLEDB:Create Link") = True
            .Properties("Jet OLEDB:Link Provider String") = strProviderString
            .Properties("Jet OLEDB:Remote Table Name") = strSourceTbl
        End With
        ' Create the new linked table by adding the
        ' Table object to the Tables collection.
        catDB.Tables.Append tblLink
        Set catDB = Nothing
End Sub

' REFRESCAR AS LIGAÇÕES DAS TABELAS
Sub RefreshLinks(strDBLinkFrom As String, _
strDBLinkSource As String)
    Dim catDB   As ADOX.Catalog
    Dim tblLink As ADOX.Table
        Set catDB = New ADOX.Catalog
        ' Open a Catalog object on the database in which to refresh links.
        catDB.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & strDBLinkFrom
        For Each tblLink In catDB.Tables
            ' Check to make sure table is a linked table.
            If tblLink.Type = "LINK" Then
                tblLink.Properties("Jet OLEDB:Link Datasource") = strDBLinkSource
            End If
        Next
        Set catDB = Nothing
End Sub

'CRIAR UM INDICE
Sub CreateIndex(strDBPath As String, _
strTblToIdx As String, _
strIdxName As String, _
strIdxField As String, _
lngIndexNulls As ADOX.AllowNullsEnum, _
lngSortOrder As ADOX.SortOrderEnum)
    Dim catDB As ADOX.Catalog
    Dim tbl   As ADOX.Table
    Dim idx   As ADOX.Index
        Set catDB = New ADOX.Catalog
        ' Open a Catalog object on the database in which to create the index.
        catDB.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & strDBPath
        Set tbl = New ADOX.Table
        Set tbl = catDB.Tables(strTblToIdx)
        ' Create Index object and append table columns to it.
        Set idx = New ADOX.Index
        With idx
            .Name = strIdxName
            .IndexNulls = lngIndexNulls
            .Columns.Append strIdxField
            .Columns(strIdxField).SortOrder = lngSortOrder
        End With
        ' Append the Index object to the Indexes
        ' collection of the Table object.
        tbl.Indexes.Append idx
        Set catDB = Nothing
End Sub

'CRIAR UMA RELAÇÃO
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
        ' Note that VB "enforces" the lowercasing of
        ' "key" in ADOX.key.
        Set catDB = New ADOX.Catalog
        ' Open the Catalog object.
        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

' CRIAR UMA QUERY
Sub CreateQuery(strDBPath As String, _
strSQL As String, _
strQryName As String)
' Note: Queries that are created or modified using ADOX aren't visible
' in the Access database window.
    Dim catDB As ADOX.Catalog
    Dim cmd   As ADODB.Command
        Set catDB = New ADOX.Catalog
        ' Open the Catalog object.
        catDB.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & strDBPath
        Set cmd = New ADODB.Command
        ' Define a Command object to contain the query's SQL
        ' statement, and then save it to the database's
        ' Views collection. strSQL must contain only a
        ' SELECT statement.
        cmd.CommandText = strSQL
        catDB.Views.Append strQryName, cmd
        Set catDB = Nothing
End Sub

' MODIFICAR UMA QUERY
Sub ModifyQuery(strDBPath As String, _
strQryName As String, _
strSQL As String)
' Note: Queries that are created or modified using ADOX aren't visible
' in the Access database window. For more information, see ADOCreateQueries.doc
' in the Appendixes folder on the companion CD-ROM.
    Dim catDB As ADOX.Catalog
    Dim cmd   As ADODB.Command
    Set catDB = New ADOX.Catalog
    ' Open the Catalog object.
    catDB.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" & strDBPath
    Set cmd = New ADODB.Command
    ' Get the query from the Procedures collection.
    Set cmd = catDB.Procedures(strQryName).Command
    ' Update the query's SQL statement.
    cmd.CommandText = strSQL
    'Save the updated query.
    Set catDB.Procedures(strQryName).Command = cmd
    Set catDB = Nothing
End Sub

' CORRER UM COMANDO SQL
Sub RunSQLCommand(strDBPath As String, _
strSQL As String)
    Dim cmd        As ADODB.Command
    Dim strConnect As String
    strConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBPath
    Set cmd = New ADODB.Command
    With cmd
        .CommandText = strSQL
        .ActiveConnection = strConnect
        .Execute
    End With
    Set cmd = Nothing
End Sub

Sub RunSQLConnection(strDBPath As String, _
strSQL As String)
    Dim cnn        As ADODB.Connection
    Dim strConnect As String
    strConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" & strDBPath
        Set cnn = New ADODB.Connection
        With cnn
            .Open strConnect
            .Execute strSQL
            .Close
        End With
    Set cnn = Nothing
End Sub
 


CyberWEB Network Ltda.    © Copyright 2000-2017   -   Todos os direitos reservados.
Powered by HostingZone - A melhor hospedagem para seu site
Topo da página