Re: ADO connection state and object destruction Problem/Question

From: Michael D. Long (michael.d.long-nospam_at_comcast.net)
Date: 08/23/04 

Date: Mon, 23 Aug 2004 19:46:28 -0400

You're close. I make it a habit to provide one and only one exit path.
Also, I've found that explicitly cleaning up object state prior to releasing
the objects (ADO in particular) greatly reduces resource leaks even under
extreme system loads.

Note: The code was written on the fly in OE, so check it before running.

Public Function FindEmployees(ByVal Name As String, ByVal EmpID As String) _
        As ADODB.Recordset
  ' Local declarations for example; may also be module level
  Dim lngErr As Long
  Dim strDesc As String
  Dim strSrc As String

  On Error GoTo ehProc

  ClearErrorInfo lngErr, strDesc, strSrc

  Dim rs As ADODB.Recordset
  Set rs = New ADODB.Recordset
  Dim conn As ADODB.Connection
  Set conn = New ADODB.Connection

  ' Rest of procedure removed for clarity

exProc:
  On Error Resume Next
  ' Perform object cleanup here
  DisconnectRS rs
  ReleaseCN conn

  ' Check for error and bubble up accordingly
  If lngErr <> 0 Then
    On Error GoTo 0
    Err.Raise lngErr, strSrc, strDesc
  End If
  Exit Function

ehProc:
  SaveErrorInfo lngErr, strDesc, strSrc
  Resume exProc
End Function

' ***
' Following functions to be placed in .BAS module(s)
' ***
Public Sub ClearErrorInfo(ByRef lngErr As Long, ByRef strDesc As String, _
        Optional ByRef strSrc As String = vbNullString)
  On Error Resume Next
  lngErr = 0
  strDesc = vbNullString
  strSrc = vbNullString
End Sub

Public Sub SaveErrorInfo(ByRef lngErr As Long, ByRef strDesc As String, _
        ByRef strSrc As String = vbNullString, Optional ByRef strSrcAlt As
String = vbNullString)
  ' NEVER enable error handling in this procedure as it would clear the
error object.
  lngErr = Err.Number
  strDesc = Err.Description
  strSrc = App.Exename & "." & IIF(strSrcAlt = vbNullString, Err.Source,
strSrcAlt)
End Sub

Public Sub DisconnectRS(ByRef rs As ADODB.RecordSet)
  If Not rs Is Nothing Then Set rs.ActiveConnection = Nothing
End Sub

Public Sub ReleaseCN(ByRef cn As ADODB.Connection)
  If Not cn Is Nothing Then
    ' Check state and explicitly close before releasing connection object.
    ' Note: Implicit cleanup will leak connection handles when stressed.
    If cn.State <> adStateClosed Then cn.Close
    Set cn = Nothing
  End If
End Sub 

-- 
Michael D. Long
Microsoft MVP - Windows SDK
"Eric" <Eric@discussions.microsoft.com> wrote in message
news:C5E4633F-D89D-40F4-A199-C013540F9C23@microsoft.com...
> Greetings:
> I have a function(in a module) that  returns an ADO recorset. I call this
> function from a windows form. How do I control the connection state of the
> CONN object and recordset objects when I close the forms. I wish to avoid
any
> memory leaks and be sure that I close and destroy and objects when the
> application exits.  Here is how I call the function from a button and the
> function itself is just below. Thanks all.
> Private Sub CmsSearch_Click()
> Set DataGridEmp.DataSource = FindEmployees(txtSearchName.Text,
> TxtEmpCode.Text)
> End Sub
>
> Public Function FindEmployees(ByVal Name As String, ByVal EmpID As String)
> As ADODB.Recordset
>  Dim rs As ADODB.Recordset
>       Set rs = New ADODB.Recordset
>       Dim conn As ADODB.Connection
>       Set conn = New ADODB.Connection
>       conn.Open "PROVIDER=MSDASQL;driver={SQL
> Server};server=CMSOPEN;uid=User1;pwd=;database=CMSOPEN;"
>
>       SQL2 = SQL2 & "SELECT     HBM_PERSNL.EMPLOYEE_CODE AS [Employee
Code],
> HBM_PERSNL.EMPLOYEE_NAME AS Name, HBM_PERSNL.PHONE_NO AS Extension,"
>       SQL2 = SQL2 & "HBL_OFFICE.OFFC_DESC AS Office FROM HBM_PERSNL INNER
> JOIN "
>       SQL2 = SQL2 & "HBL_OFFICE ON HBM_PERSNL.OFFC = HBL_OFFICE.OFFC_CODE
"
>  SQL2 = SQL2 & "WHERE     (HBM_PERSNL.INACTIVE = 'n') AND "
>
>  If Name = "" Then
>   SQL2 = SQL2 & "(HBM_PERSNL.EMPLOYEE_NAME = HBM_PERSNL.EMPLOYEE_NAME) AND
"
>   Else
>   SQL2 = SQL2 & "(HBM_PERSNL.EMPLOYEE_NAME LIKE '%" & Name & "%') AND "
>   End If
>   If EmpID = "" Then
>   SQL2 = SQL2 & "(HBM_PERSNL.EMPLOYEE_CODE = HBM_PERSNL.EMPLOYEE_CODE) "
>   Else
>    SQL2 = SQL2 & "(HBM_PERSNL.EMPLOYEE_CODE LIKE '%" & EmpID & "%') "
>   End If
>
>       SQL2 = SQL2 & " ORDER BY HBM_PERSNL.EMPLOYEE_NAME"
>
>       rs.Open SQL2, conn, adOpenStatic, _
>                   adLockReadOnly, adCmdText
>
>    If rs.RecordCount > 0 Then
>        Set FindEmployees = rs
>           Else
>                MsgBox "Your request returned zero records", vbInformation
>           Exit Function
>       End If
>
>       Set rs = Nothing
>       Set conn = Nothing
> End Function
>