[AccessD] My first use of the Listview Control

Wed Oct 29 16:26:23 CDT 2008

Here ya go Fred.  Mind you, there is custom error handling in this,
which is part of the rest of the system, and the isfeDatabase is a
global object that handles the database connection, so that just needs
to be replaced with a standard ADO Connection initializing.

Drew (And the resize event is what makes that form look that way color
wise).

Private Sub RunSQL()
On Error GoTo ErrorHandler
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strSQL As String
Dim i As Long
Dim itmX As ListItem
strSQL = Me.txtSQL
isfeDatabase.ISFEDBConnect cnn
Me.lstResults.ListItems.Clear
If UCase(Left(strSQL, 6)) = "SELECT" Then
    Set rs = New ADODB.Recordset
    rs.Open strSQL, cnn, adOpenForwardOnly, adLockReadOnly
    Me.lstResults.ColumnHeaders.Clear
    For i = 1 To rs.Fields.Count
        Me.lstResults.ColumnHeaders.Add i, rs.Fields(i - 1).Name,
rs.Fields(i - 1).Name, rs.Fields(i - 1).ActualSize * 20
    Next i
    If rs.EOF = False Then rs.MoveFirst
    Do Until rs.EOF = True
        Set itmX = Me.lstResults.ListItems.Add(, , rs.Fields(0).Value)
        For i = 1 To rs.Fields.Count - 1
            If Not IsNull(rs.Fields(i).Value) Then itmX.SubItems(i) =
rs.Fields(i).Value
        Next i
        rs.MoveNext
    Loop
    rs.Close
    Set rs = Nothing
Else
    cnn.Execute strSQL, i
    Me.lstResults.ColumnHeaders.Clear
    Me.lstResults.ColumnHeaders.Add , , "Number of affected Records: " &
i, 300
End If
isfeDatabase.ReleaseISFEDBConnection
Set cnn = Nothing
Exit Sub

ErrorHandler:

MsgBox Err.Number & " - " & Err.Description
Err.Clear
End Sub
Private Sub cmdExecute_Click()
RunSQL
End Sub
Private Sub Form_Load()
On Error GoTo ErrorHandler
BuildTableList
Exit Sub

ErrorHandler:

isfeErrorHandler.Module = "frmSQLWindow"
isfeErrorHandler.Procedure = "Form_Load"
isfeErrorHandler.ErrorDescription = Err.Description
isfeErrorHandler.ErrorNumber = Err.Number
isfeErrorHandler.RaiseError
Err.Clear
End Sub
Private Sub Form_Resize()
On Error GoTo ErrorHandler
Dim y As Long
AutoRedraw = True
ScaleMode = vbPixels
For y = 0 To ScaleHeight
    Line (-1, y - 1)-(ScaleWidth, y + 1), RGB(isfeFormGradientRed,
isfeFormGradientGreen, isfeFormGradientBlue - (y * isfeFormGradientBlue)
\ ScaleHeight), B
Next y
Exit Sub

ErrorHandler:

isfeErrorHandler.Module = "frmSQLWindow"
isfeErrorHandler.Procedure = "Form_Resize"
isfeErrorHandler.ErrorDescription = Err.Description
isfeErrorHandler.ErrorNumber = Err.Number
isfeErrorHandler.RaiseError
Err.Clear
End Sub
Private Function BuildTableList()
On Error GoTo ErrorHandler
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Me.lstTables.Clear
isfeDatabase.ISFEDBConnect cnn
Set rs = cnn.OpenSchema(adSchemaTables)
If rs.EOF = False Then rs.MoveFirst
Do Until rs.EOF = True
    If rs.Fields("TABLE_TYPE").Value = "TABLE" Then
        Me.lstTables.AddItem rs.Fields("TABLE_NAME").Value
    End If
    rs.MoveNext
Loop
rs.Close
Set rs = Nothing
isfeDatabase.ReleaseISFEDBConnection
Set cnn = Nothing
Exit Function

ErrorHandler:

isfeErrorHandler.Module = "frmSQLWindow"
isfeErrorHandler.Procedure = "BuildTableList"
isfeErrorHandler.ErrorDescription = Err.Description
isfeErrorHandler.ErrorNumber = Err.Number
isfeErrorHandler.RaiseError
Err.Clear
End Function

Private Sub lstTables_Click()
On Error GoTo ErrorHandler
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim i As Long
isfeDatabase.ISFEDBConnect cnn
Set rs = New ADODB.Recordset
rs.Open Me.lstTables.List(Me.lstTables.ListIndex), cnn,
adOpenForwardOnly, adLockReadOnly, adCmdTableDirect
Me.lstFields.Clear
For i = 0 To rs.Fields.Count - 1
    Me.lstFields.AddItem rs.Fields(i).Name
Next i
rs.Close
Set rs = Nothing
isfeDatabase.ReleaseISFEDBConnection
Set cnn = Nothing
If Me.chkTableSQL Then Me.txtSQL = "SELECT * FROM " &
Me.lstTables.List(Me.lstTables.ListIndex)
Exit Sub

ErrorHandler:

isfeErrorHandler.Module = "frmSQLWindow"
isfeErrorHandler.Procedure = "lstTables_Click"
isfeErrorHandler.ErrorDescription = Err.Description
isfeErrorHandler.ErrorNumber = Err.Number
isfeErrorHandler.RaiseError
Err.Clear
End Sub
Private Function ExcelColumn(intColumn As Long) As String
Dim intTemp As Long
Dim intPart As Long
If intColumn <= 26 Then
    ExcelColumn = Chr(64 + intColumn)
Else
    intTemp = Fix(intColumn / 26)
    intPart = intColumn - (intTemp * 26)
    ExcelColumn = Chr(64 + intTemp) & Chr(65 + intPart)
End If
End Function
Private Sub mnuDumpToExcel_Click()
On Error GoTo ErrorHandler
Dim ExlApp As Excel.Application
Dim ExlWrkSht As Excel.Worksheet
Dim i As Long
Dim j As Long
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
If UCase(Left(Me.txtSQL, 6)) <> "SELECT" Then Exit Sub
isfeDatabase.ISFEDBConnect cnn
Set rs = New ADODB.Recordset
rs.Open CStr(Me.txtSQL), cnn, adOpenForwardOnly, adLockReadOnly
If rs.EOF = False Then rs.MoveFirst
Set ExlApp = CreateObject("Excel.Application")
Screen.MousePointer = vbHourglass
ExlApp.Workbooks.Add
ExlApp.Visible = True
For i = 0 To ExlApp.Sheets.Count - 1
    If i = 1 Then
        Set ExlWrkSht = ExlApp.Sheets(i)
        ExlWrkSht.Name = "ISFE SQL Dump"
    Else
        ExlApp.Sheets(2).Delete
    End If
Next i
For i = 1 To rs.Fields.Count
    ExlWrkSht.Columns(ExcelColumn(i) & ":" & ExcelColumn(i)).ColumnWidth
= 20 'rs.Fields(i - 1).ActualSize
    ExlApp.Range(ExcelColumn(i) & 1).Font.Bold = True
    ExlApp.Range(ExcelColumn(i) & 1).Font.Size = 14
    ExlApp.Range(ExcelColumn(i) & 1) = rs.Fields(i - 1).Name
Next i
j = 2
Do Until rs.EOF = True
    For i = 1 To rs.Fields.Count
        If Not IsNull(rs.Fields(i - 1).Value) Then
ExlApp.Range(ExcelColumn(i) & j) = rs.Fields(i - 1).Value
    Next i
    j = j + 1
    rs.MoveNext
Loop
rs.Close
Set rs = Nothing
isfeDatabase.ReleaseISFEDBConnection
Set cnn = Nothing
Screen.MousePointer = vbNormal
Set ExlWrkSht = Nothing
Set ExlApp = Nothing
Exit Sub

ErrorHandler:

isfeErrorHandler.Module = "frmSQLWindow"
isfeErrorHandler.Procedure = "mnuDumpToExcel_Click"
isfeErrorHandler.ErrorDescription = Err.Description
isfeErrorHandler.ErrorNumber = Err.Number
isfeErrorHandler.RaiseError
Err.Clear
End Sub

-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of Fred Hooper
Sent: Wednesday, October 29, 2008 3:24 PM
To: 'Access Developers discussion and problem solving'
Subject: Re: [AccessD] My first use of the Listview Control

Very neat! I, for one, would like to see the code behind it.

Thanks,
Fred
The information contained in this transmission is intended only for the person or entity to which it is addressed and may contain II-VI Proprietary and/or II-VI Business Sensitive material. If you are not the intended recipient, please contact the sender immediately and destroy the material in its entirety, whether electronic or hard copy. You are notified that any review, retransmission, copying, disclosure, dissemination, or other use of, or taking of any action in reliance upon this information by persons or entities other than the intended recipient is prohibited.