These two procedures are hosted in Excel.
Public Function CreateReportFromQuerySP(DbPath As String, _
Proc As String, _
Optional Param1 As String) As Boolean
' Code Header inserted by the Procedure Header Add-In
'=============================================================
' Function frmB2ReportGenerator.CreateReportFromQuerySP
'-------------------------------------------------------------
' Purpose : Uses a DbPath and Parameter to run a Stored
' Procedure on the Access database.
' Author : Stephen King, 06-11-2002
' Notes :
'-------------------------------------------------------------
' Parameters
'-----------
' DbPath (String) Short path of the database
' Proc (String) Name of Stored Procedure in the database
' Param1 (Optional) (String) Parameter to be passed to the
' stored procedure.
'-------------------------------------------------------------
' Returns
'--------
' N/A
'-------------------------------------------------------------
' Revision History
'-------------------------------------------------------------
' Date Initials Description
' ---------- -------- -----------
' 06-11-2002 sck Created
'
'=============================================================
' End Code Header block
Dim cnnConn As ADODB.Connection
Dim rstRecordset As ADODB.Recordset
Dim cmdCommand As ADODB.Command
Dim prmParameter As ADODB.Parameter
Dim ws As Worksheet
Dim lngSize As Long
Dim iCols As Integer
On Error Resume Next
' Open the connection.
Set cnnConn = New ADODB.Connection
' If the DbPath was provided verify it
' otherwise open from the default database.
If Len(DbPath) > 0 Then
' Check to verify that the database exists at the location stated
' in the input parameter
If Len(Dir(DbPath)) > 0 Then
With cnnConn
.ConnectionString = _
"Provider=Microsoft.Jet.OLEDB.4.0"
.Open DbPath
.CursorLocation = adUseServer
End With
Else
MsgBox "Invalid database path (" & DbPath & "
"
Exit Function
End If
Else
If Len(Dir(DefaultDbPath)) > 0 Then
With cnnConn
.ConnectionString = _
"Provider=Microsoft.Jet.OLEDB.4.0"
.Open DefaultDbPath & ";UID=guest;PWD="
End With
Else
MsgBox "Invalid database path (" & DefaultDbPath & "
"
Exit Function
End If
End If
On Error GoTo HandleErr
' Set the command text.
Set cmdCommand = New ADODB.Command
Set cmdCommand.ActiveConnection = cnnConn
If Len(Param1) > 0 Then
Set prmParameter = cmdCommand.CreateParameter("MyParam", adVariant, _
adParamInput, Len(Param1))
cmdCommand.Parameters.Append prmParameter
prmParameter.Value = Param1
End If
With cmdCommand
.CommandText = Proc
.CommandType = adCmdStoredProc
.Execute
End With
If cnnConn.Errors.Count > 0 Then
Err.Raise 10621, "cnnConn", "Error Returns following execute."
End If
' Open the recordset.
Set rstRecordset = New ADODB.Recordset
Set rstRecordset.ActiveConnection = cnnConn
rstRecordset.Open cmdCommand
' If there are no records then just notify the user
' and exit the procedure.
If rstRecordset.EOF Then
MsgBox "There are no records for this request. Please " _
& "review your request to ensure it is correct."
Exit Function
Else
CreateNewSheet
End If
'Worksheets.Add Count:=1, Before:=Sheets(1)
Set ws = Worksheets(1)
For iCols = 0 To rstRecordset.Fields.Count - 1
ws.Cells(1, iCols + 1).Value = rstRecordset.Fields(iCols).Name
Next
ws.Range(ws.Cells(1, 1), _
ws.Cells(1, rstRecordset.Fields.Count)).Font.Bold = True
ws.Range("A2"
.CopyFromRecordset rstRecordset
Exit_Proc:
On Error Resume Next
' Close the connections and clean up.
cnnConn.Close
Set cmdCommand = Nothing
Set rstRecordset = Nothing
cnnConn.Close
Set cnnConn = Nothing
Exit Function
HandleErr:
Select Case Err.Number
Case 10621
MsgBox "Error: " & Err.Number & vbCrLf & "Source: " & Err.Source & vbCrLf _
& "Description: " & Err.Description _
& vbCrLf & "CreateReportFromQueryADO"
Case Else
Call HandleTheError("", "frmB2ReportGenerator.CreateReportFromQuerySP", Err)
End Select
Resume Exit_Proc
Resume
End Function
Public Function CreateQueryTable(Optional strConnect As String, _
Optional strSQL As String) As Boolean
' Ref: Microsoft Office 2000/Visual Basic Programmers Guide
' Creating a Query Table by Using a Database Query (Pg 659)
' Create query table from external data source. Takses a valid ADO
' connection string and a valid SQL SELECT statement.
Const ODBC_CONNECT As String = "ODBC;" _
& "DBQ=D:\Groups\SDV\DMATS\scking\CompDb\CompData2k.mdb;" _
& "Driver={Microsoft Access Driver (*.mdb)};"
Const conQuery As String = "SELECT tblComponent.[CP/N], tblComponent.Cage " _
& "FROM tblComponent " _
& "WHERE (((tblComponent.FSC) Is Null)) Or (((tblComponent.NIIN) Is Null)) " _
& "ORDER BY tblComponent.[CP/N], tblComponent.Cage;"
Dim wsp As DAO.Workspace
Dim db As DAO.Database
Dim rstData As DAO.Recordset
Dim qtbData As QueryTable
Dim wksNew As Excel.Worksheet
Dim strQuery As String
Dim strConnection As String
On Error GoTo CreateQueryTable_Err
strQuery = "qryOutputNonStockListed"
Set wsp = DBEngine.Workspaces(0)
Set db = wsp.OpenDatabase("D:\Groups\SDV\DMATS\scking\CompDb\CompData2k.mdb"
Set rstData = db.OpenRecordset(conQuery)
' Can create a new worksheet but this uses the activesheet
With ActiveSheet.QueryTables.Add(Connection:=rstData, _
Destination:=Range("A1"
)
.Refresh
End With
'connstring = "Microsoft.Jet.OLEDB.4.0;Database=D:\Groups\SDV\DMATS\scking\CompDb\CompData2k.mdb"
CreateQueryTable = True
CreateQueryTable_End:
On Error Resume Next
rstData.Close
Set rstData = Nothing
Set db = Nothing
Set wsp = Nothing
Exit Function
CreateQueryTable_Err:
CreateQueryTable = False
MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
Resume CreateQueryTable_End
Resume -------------------------------------
scking@arinc.com
Try to resolve problems independently
Then seek help among peers or experts
But TEST recommended solutions
-------------------------------------
