Wednesday 29 January 2014

VBA: Prototype Class than connects to oracle and checks if connection is up. Plus VBA singleton pattern

Here some prototyping code of a class that is able to connect to Oracle through OleDB and to check if the connection is up before doing some application logic. Class name is TUploadHelper.
Private m_conn As Object

Private Function GetConn_() As Object
    If m_conn Is Nothing Then
        Set m_conn = CreateObject("ADODB.Connection")
    End If
    Set GetConn_ = m_conn
End Function

Private Function Connected_() As Boolean
    Dim recordSet As Object
    Dim value As Long
    Dim errCode As Variant
    Dim errMsg As Variant

    If Not PopErrors() Then On Error GoTo L_ERR_HANDLER
    
    value = 0
    Connected_ = False
    
    Set recordSet = CreateObject("ADODB.Recordset")
    
    Set recordSet.ActiveConnection = GetConn_()
    
    recordSet.Open "select 1 as value_ from dual"
    While Not recordSet.EOF
        value = recordSet.Fields(0)
        If 1 = value Then
            Connected_ = True
            GoTo L_CLEANUP
        End If
    Wend
    ' не вернулось ни одной записи
L_ERR_HANDLER:
    errCode = Err.Number
    errMsg = Err.Description
L_CLEANUP:
    On Error GoTo 0
    If 1 = recordSet.State Then
        recordSet.Close
    End If
    Set recordSet = Nothing
End Function


Private Sub Class_Deinitialize()
    If Not m_conn Is Nothing Then
        If 1 = m_conn.State Then
            m_conn.Close
        End If
        Set m_conn = Nothing
    End If
End Sub

Private Function Authorized_() As Boolean
    Authorized_ = False
End Function

Private Sub Connect_()
'    Dim state_ As Variant
    m_conn.Open "Provider=OraOLEDB.Oracle;Data Source=your_server.world;User ID=your_user;Password=your_pass;PLSQLRSet=1;"
'    state_ = m_conn.State
End Sub

Public Sub Ut()
    If Not Connected_ Then
        Connect_
        If Not Connected_ Then
        End If
    End If
End Sub
And here is module code that implements singleton pattern for TUploadHelper object.
'Singleton pattern
Private g_uploadHelper As TUploadHelper
Public Property Get GetUploadHelper() As TUploadHelper
    If g_uploadHelper Is Nothing Then
        Set g_uploadHelper = New TUploadHelper
    End If
    Set GetUploadHelper = g_uploadHelper
End Property

No comments:

Post a Comment