EjemplosDuoc.es.tl
  BD Postgres ADO
 
 

Para Realizar esta coneccion, primero se debe agregar una referencia.
Esto se hace en la opcion "Proyecto", luego "Referencia" y la opcion
"Microsoft Activex Data Object 2.8 library" o cualquier version superior.

Los codigos para la coneccion son los siguientes:

Dim Cn As ADODB.Connection
Dim Rs As ADODB.Recordset
   
    Set Cn = New ADODB.Connection
    With Cn
        .ConnectionString = "DRIVER={PostgreSQL UNICODE};" _
                          & "SERVER=127.0.0.1;" _
                          & "PORT=5432;" _
                          & "DATABASE=NombreBd;" _
                          & "UID=usuario;" _
                          & "PWD=clave;"

        .CursorLocation = adUseClient
        .Open
    End With
   
    Set Rs = New ADODB.Recordset
    With Rs
        .ActiveConnection = Cn
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Open "select * from Tabla"
    End With
    ' Enlazamos el cursor a la grilla
    Set Grilla.DataSource = Rs
    ' Cerramos el cursor
    Rs.Close
    Set Rs = Nothing

para connectionString se puede utilizar una constante:

Global Const G_STRINGCONNECTION = "DRIVER={PostgreSQL UNICODE};" _
                          & "SERVER=127.0.0.1;" _
                          & "PORT=5432;" _
                          & "DATABASE=NOMBRE_BASE_DATO;" _
                          & "UID=postgres;" _
                          & "PWD=admin;"

Funcion para Grabar

Public Function F_Grabar(ByRef SqlString As String) As Boolean
    On Error GoTo Ocurrio_Error
    F_Grabar = False
    Dim Cm As New ADODB.Command
    Dim Cnn As ADODB.Connection
   
    Set Cnn = New ADODB.Connection
    With Cnn
        .ConnectionString = G_STRINGCONNECTION
        .CursorLocation = adUseClient
        .Open
    End With
   
    With Cm
        .ActiveConnection = Cnn
        .CommandText = UCase(SqlString)
        .Execute
    End With
    F_Grabar = True
    Cnn.Close
    Exit Function
Ocurrio_Error:
        MsgBox "Ocurrio un Error en Proc. F_Grabar: " & _
                Err.Description, vbCritical, "ERROR EN GRABAR"
End Function

Funcion para llenar Grilla

Public Function F_Llena_Grilla(ByRef Grilla As MSHFlexGrid, ByRef SqlString As String) As Boolean
On Error GoTo Ocurrio_Error

Dim CnLoc As ADODB.Connection
Dim RsLoc As ADODB.Recordset

Set CnLoc = New ADODB.Connection
With CnLoc
    .ConnectionString = G_STRINGCONNECTION
    .CursorLocation = adUseClient
    .Open
End With

Set RsLoc = New ADODB.Recordset
With RsLoc
    .ActiveConnection = CnLoc
    .CursorType = adOpenStatic
    .LockType = adLockReadOnly
    .Open UCase(SqlString)
End With

If Not RsLoc.BOF And Not RsLoc.EOF Then
    Set Grilla.DataSource = RsLoc
    F_Llena_Grilla = True
End If
' Cerramos el cursor
RsLoc.Close
CnLoc.Close
Set RsLoc = Nothing

Exit Function
Ocurrio_Error:
    MsgBox "Ocurrio un Error en Proc. F_Llena_Grilla: " & _
            Err.Description, vbCritical, "ERROR EN BUSQUEDA"
End Function

Funcion para llenar Combobox por medio del itemdata
Public Sub S_Llena_Combos(ByRef Tabla As String, ByRef Combo As ComboBox, ByRef NumeroColumna As Integer)
On Error GoTo Ocurrio_Error
Dim SqlString As String
Dim CnLoc As ADODB.Connection
Dim RsLoc As ADODB.Recordset

    SqlString = " SELECT * FROM " & Tabla
   
    Set CnLoc = New ADODB.Connection
    With CnLoc
        .ConnectionString = G_STRINGCONNECTION
        .CursorLocation = adUseClient
        .Open
    End With
   
    Set RsLoc = New ADODB.Recordset
    With RsLoc
        .ActiveConnection = CnLoc
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Open UCase(SqlString)
    End With
   
    If Not RsLoc.BOF And Not RsLoc.EOF Then
        With Combo
            .Clear
            .AddItem ""
            .ItemData(.NewIndex) = 0
            Do While Not RsLoc.EOF
                .AddItem RsLoc.Fields(NumeroColumna)
                .ItemData(.NewIndex) = RsLoc.Fields(0)
                RsLoc.MoveNext
            Loop
        End With
    End If
    ' Cerramos el cursor
    RsLoc.Close
    Set RsLoc = Nothing
Exit Sub
Ocurrio_Error:
    MsgBox "Ocurrio un Error en Proc. S_Llena_Combos: " & _
            Err.Description, vbCritical, "ERROR EN BUSQUEDA"
End Sub

Procedimiento generico para realizar consultas sobre la BD.

Private Function F_Ejecutar_Busqueda(ByRef SqlString As String, ByRef NombreFunction As String)
    Dim Retorno As Boolean
    Dim RsLoc As ADODB.Recordset
    Set CnLoc = New ADODB.Connection
   
    Retorno = False
   
    With CnLoc
        .ConnectionString = G_STRINGCONNECTION
        .CursorLocation = adUseClient
        .Open
    End With
'
    Set RsLoc = New ADODB.Recordset
    With RsLoc
        .ActiveConnection = CnLoc
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Open UCase(SqlString)
    End With
   
    If Not RsLoc.BOF And Not RsLoc.EOF Then
        If RsLoc!Cuenta > 0 Then
            Retorno = True
        End If
    End If
    ' Cerramos el cursor y coneccion local
    RsLoc.Close
    CnLoc.Close
    Set RsLoc = Nothing
    F_Ejecutar_Busqueda = Retorno
    Exit Function
Ocurrio_Error:
    MsgBox "Ocurrio un Error en Proc. " & NombreFunction & ": " & _
            Err.Description, vbCritical, "ERROR EN BUSQUEDA"
End Function

 
   
 
Este sitio web fue creado de forma gratuita con PaginaWebGratis.es. ¿Quieres también tu sitio web propio?
Registrarse gratis