V
Vince P
Access 2003
Windows XP SP1
Jet 4
ADO 2.7
ADOX 2.7
MDB file, direct tables (not linked)
I have a query , it's a select query, has one parameter, [CSONum], it's a
text field. the parameter is in the Critera box in the designer, and in the
parameter property sheet for the query.
This code when it runs,, returns no rows. When I run the query through the
UI with the same value for the paramter, I get a bunch of rows. Any ideas?
(The object command is "comm", the recordset I want populated is "rsBroker"
First, here is the SQL from the Access Query UI , SQL View:
==============================
PARAMETERS [CSONum] Text ( 255 );
SELECT BrokerCargo.BL, BrokerCargo.SVVD, BrokerCargo.CSO, BrokerCargo.POD,
BrokerCargo.ETA, BrokerCargo.CONTAINER_NUM, BrokerCargo.CNTR_QTY,
BrokerCargo.COLLECT_CHRG, BrokerCargo.FND, BrokerCargo.CNEE,
BrokerCargo.NOTIFY_PARTY, BrokerCargo.ALSO_NOTIFY,
EmailAddresses.EmailAddress
FROM (BrokerCargo
LEFT JOIN EmailAddresses ON (BrokerCargo.SVC = EmailAddresses.SVC) AND
(BrokerCargo.IB_CTRL_OFC = EmailAddresses.IBControlOffice)) LEFT JOIN Broker
ON BrokerCargo.BrokerName = Broker.BrokerName
WHERE (((BrokerCargo.CSO)=[CSONum]))
ORDER BY BrokerCargo.ETA, BrokerCargo.SVVD, BrokerCargo.BL;
==================================
Here is my code (it was originally a module, but in troubleshooting, I
decied to use some Events, so now it's a quite ugly class.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ShipmentClass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Compare Database
Option Explicit
Dim WithEvents connRSBroker As ADODB.Connection
Attribute connRSBroker.VB_VarHelpID = -1
Dim WithEvents conn As ADODB.Connection
Attribute conn.VB_VarHelpID = -1
Public Function ShipmentSummary()
Dim strCSO As String
Dim strContactEmail1 As String
Dim strContactEmail2 As String
Dim strBrokerName As String
Dim strMsgBody As String
Dim strSubject As String
Dim rst As ADODB.Recordset
Dim comm As ADODB.Command
Dim param As ADODB.Parameter
Dim ippCat As New ADOX.Catalog
Dim ippviews As ADOX.Views
Dim ippTables As ADOX.Tables
Dim ippTable As ADOX.Table
Dim ippColumns As ADOX.Columns
Dim ippCol As ADOX.Column
Dim ippProcs As ADOX.Procedures
Dim ippproc As ADOX.Procedure
Dim ssql As String
Dim iCount As Integer
Dim strEmailTable As String
Dim rsBroker As ADODB.Recordset
Dim rsField As ADODB.Field
Dim comNewTable As ADODB.Command
Dim rsNewTable As ADODB.Recordset
Set conn = Access.Application.CurrentProject.Connection
Set connRSBroker = Access.Application.CurrentProject.Connection
ippCat.ActiveConnection = conn
Set ippviews = ippCat.Views
Set ippTables = ippCat.Tables
Set ippProcs = ippCat.Procedures
Set ippproc = ippProcs("BrokerEmailSummary")
Set rst = New ADODB.Recordset
rst.Open "Broker", conn
iCount = 0
Do Until rst.EOF = True
strCSO = rst("CSO")
strBrokerName = rst("BrokerName")
strMsgBody = "Attached are the shipments coming in to North
America for CSO " & strCSO
strContactEmail1 = rst("ContactEmail1")
strContactEmail2 = rst("ContactEmail2")
strSubject = strBrokerName & " " & strCSO & " " & "Shipments"
Set comm = ippproc.Command
Set param = comm.CreateParameter("[CSONum]", adWChar,
adParamInput, 15)
comm.Parameters.Append param
comm.Parameters("[CSONum]").Value = strCSO
comm.Execute
Set rsBroker = New ADODB.Recordset
rsBroker.Open comm
strEmailTable = "ShipmentsEmail" & iCount
Set ippTable = New ADOX.Table
ippTable.Name = strEmailTable
ippTable.ParentCatalog = ippCat
Set ippColumns = ippTable.Columns
For Each rsField In rsBroker.Fields
Set ippCol = New ADOX.Column
ippCol.Name = rsField.Name
ippCol.DefinedSize = rsField.DefinedSize
ippCol.Type = rsField.Type
ippColumns.Append ippCol
ippTable.Columns.Refresh
Next
ippTables.Append ippTable
ippCat.Tables.Refresh
Set ippCol = Nothing
Set ippColumns = Nothing
Set ippTable = Nothing
Set comNewTable = New ADODB.Command
comNewTable.ActiveConnection = conn
comNewTable.CommandText = strEmailTable
comNewTable.CommandType = adCmdTable
Set rsNewTable = New ADODB.Recordset
rsNewTable.LockType = adLockOptimistic
rsNewTable.CursorType = adOpenKeyset
rsNewTable.Open comNewTable
Do Until rsBroker.EOF = True
rsNewTable.AddNew
For Each rsField In rsBroker.Fields
rsNewTable.Fields(rsField.Name).Value =
rsBroker.Fields(rsField).Value
rsNewTable.Fields.Refresh
Next
rsNewTable.Update
rsBroker.MoveNext
Loop
rsNewTable.Close
rsBroker.Close
Set rsNewTable = Nothing
Set comNewTable = Nothing
Set ippColumns = Nothing
Set rsBroker = Nothing
Debug.Print strEmailTable & " added"
DoCmd.SendObject acSendTable, strEmailTable, acFormatXLS, _
strContactEmail1, strContactEmail2, , strSubject, strMsgBody,
vbFalse
ippTables.Delete strEmailTable
ippTables.Refresh
Debug.Print strEmailTable & " deleted"
iCount = iCount + 1
Set param = Nothing
Set comm = Nothing
rst.MoveNext
Loop
Set ippproc = Nothing
Set ippProcs = Nothing
Set ippTables = Nothing
Set ippviews = Nothing
Set ippCat = Nothing
rst.Close
conn.Close
Set rst = Nothing
Set conn = Nothing
End Function
Private Sub conn_WillExecute(Source As String, CursorType As
ADODB.CursorTypeEnum, LockType As ADODB.LockTypeEnum, Options As Long,
adStatus As ADODB.EventStatusEnum, ByVal pCommand As ADODB.Command, ByVal
pRecordset As ADODB.Recordset, ByVal pConnection As ADODB.Connection)
Debug.Print "hi"
End Sub
Private Sub connRSBroker_ExecuteComplete(ByVal RecordsAffected As Long,
ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal
pCommand As ADODB.Command, ByVal pRecordset As ADODB.Recordset, ByVal
pConnection As ADODB.Connection)
Dim par As ADODB.Property
For Each par In pCommand.Properties
Debug.Print par.Name & " is " & par.Value
Next
End Sub
Private Sub conn_ExecuteComplete(ByVal RecordsAffected As Long, ByVal pError
As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pCommand As
ADODB.Command, ByVal pRecordset As ADODB.Recordset, ByVal pConnection As
ADODB.Connection)
'Dim par As ADODB.Property
'For Each par In pCommand.Properties
' Debug.Print par.Name & " is " & par.Value
' Next
End Sub
Windows XP SP1
Jet 4
ADO 2.7
ADOX 2.7
MDB file, direct tables (not linked)
I have a query , it's a select query, has one parameter, [CSONum], it's a
text field. the parameter is in the Critera box in the designer, and in the
parameter property sheet for the query.
This code when it runs,, returns no rows. When I run the query through the
UI with the same value for the paramter, I get a bunch of rows. Any ideas?
(The object command is "comm", the recordset I want populated is "rsBroker"
First, here is the SQL from the Access Query UI , SQL View:
==============================
PARAMETERS [CSONum] Text ( 255 );
SELECT BrokerCargo.BL, BrokerCargo.SVVD, BrokerCargo.CSO, BrokerCargo.POD,
BrokerCargo.ETA, BrokerCargo.CONTAINER_NUM, BrokerCargo.CNTR_QTY,
BrokerCargo.COLLECT_CHRG, BrokerCargo.FND, BrokerCargo.CNEE,
BrokerCargo.NOTIFY_PARTY, BrokerCargo.ALSO_NOTIFY,
EmailAddresses.EmailAddress
FROM (BrokerCargo
LEFT JOIN EmailAddresses ON (BrokerCargo.SVC = EmailAddresses.SVC) AND
(BrokerCargo.IB_CTRL_OFC = EmailAddresses.IBControlOffice)) LEFT JOIN Broker
ON BrokerCargo.BrokerName = Broker.BrokerName
WHERE (((BrokerCargo.CSO)=[CSONum]))
ORDER BY BrokerCargo.ETA, BrokerCargo.SVVD, BrokerCargo.BL;
==================================
Here is my code (it was originally a module, but in troubleshooting, I
decied to use some Events, so now it's a quite ugly class.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ShipmentClass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Compare Database
Option Explicit
Dim WithEvents connRSBroker As ADODB.Connection
Attribute connRSBroker.VB_VarHelpID = -1
Dim WithEvents conn As ADODB.Connection
Attribute conn.VB_VarHelpID = -1
Public Function ShipmentSummary()
Dim strCSO As String
Dim strContactEmail1 As String
Dim strContactEmail2 As String
Dim strBrokerName As String
Dim strMsgBody As String
Dim strSubject As String
Dim rst As ADODB.Recordset
Dim comm As ADODB.Command
Dim param As ADODB.Parameter
Dim ippCat As New ADOX.Catalog
Dim ippviews As ADOX.Views
Dim ippTables As ADOX.Tables
Dim ippTable As ADOX.Table
Dim ippColumns As ADOX.Columns
Dim ippCol As ADOX.Column
Dim ippProcs As ADOX.Procedures
Dim ippproc As ADOX.Procedure
Dim ssql As String
Dim iCount As Integer
Dim strEmailTable As String
Dim rsBroker As ADODB.Recordset
Dim rsField As ADODB.Field
Dim comNewTable As ADODB.Command
Dim rsNewTable As ADODB.Recordset
Set conn = Access.Application.CurrentProject.Connection
Set connRSBroker = Access.Application.CurrentProject.Connection
ippCat.ActiveConnection = conn
Set ippviews = ippCat.Views
Set ippTables = ippCat.Tables
Set ippProcs = ippCat.Procedures
Set ippproc = ippProcs("BrokerEmailSummary")
Set rst = New ADODB.Recordset
rst.Open "Broker", conn
iCount = 0
Do Until rst.EOF = True
strCSO = rst("CSO")
strBrokerName = rst("BrokerName")
strMsgBody = "Attached are the shipments coming in to North
America for CSO " & strCSO
strContactEmail1 = rst("ContactEmail1")
strContactEmail2 = rst("ContactEmail2")
strSubject = strBrokerName & " " & strCSO & " " & "Shipments"
Set comm = ippproc.Command
Set param = comm.CreateParameter("[CSONum]", adWChar,
adParamInput, 15)
comm.Parameters.Append param
comm.Parameters("[CSONum]").Value = strCSO
comm.Execute
Set rsBroker = New ADODB.Recordset
rsBroker.Open comm
strEmailTable = "ShipmentsEmail" & iCount
Set ippTable = New ADOX.Table
ippTable.Name = strEmailTable
ippTable.ParentCatalog = ippCat
Set ippColumns = ippTable.Columns
For Each rsField In rsBroker.Fields
Set ippCol = New ADOX.Column
ippCol.Name = rsField.Name
ippCol.DefinedSize = rsField.DefinedSize
ippCol.Type = rsField.Type
ippColumns.Append ippCol
ippTable.Columns.Refresh
Next
ippTables.Append ippTable
ippCat.Tables.Refresh
Set ippCol = Nothing
Set ippColumns = Nothing
Set ippTable = Nothing
Set comNewTable = New ADODB.Command
comNewTable.ActiveConnection = conn
comNewTable.CommandText = strEmailTable
comNewTable.CommandType = adCmdTable
Set rsNewTable = New ADODB.Recordset
rsNewTable.LockType = adLockOptimistic
rsNewTable.CursorType = adOpenKeyset
rsNewTable.Open comNewTable
Do Until rsBroker.EOF = True
rsNewTable.AddNew
For Each rsField In rsBroker.Fields
rsNewTable.Fields(rsField.Name).Value =
rsBroker.Fields(rsField).Value
rsNewTable.Fields.Refresh
Next
rsNewTable.Update
rsBroker.MoveNext
Loop
rsNewTable.Close
rsBroker.Close
Set rsNewTable = Nothing
Set comNewTable = Nothing
Set ippColumns = Nothing
Set rsBroker = Nothing
Debug.Print strEmailTable & " added"
DoCmd.SendObject acSendTable, strEmailTable, acFormatXLS, _
strContactEmail1, strContactEmail2, , strSubject, strMsgBody,
vbFalse
ippTables.Delete strEmailTable
ippTables.Refresh
Debug.Print strEmailTable & " deleted"
iCount = iCount + 1
Set param = Nothing
Set comm = Nothing
rst.MoveNext
Loop
Set ippproc = Nothing
Set ippProcs = Nothing
Set ippTables = Nothing
Set ippviews = Nothing
Set ippCat = Nothing
rst.Close
conn.Close
Set rst = Nothing
Set conn = Nothing
End Function
Private Sub conn_WillExecute(Source As String, CursorType As
ADODB.CursorTypeEnum, LockType As ADODB.LockTypeEnum, Options As Long,
adStatus As ADODB.EventStatusEnum, ByVal pCommand As ADODB.Command, ByVal
pRecordset As ADODB.Recordset, ByVal pConnection As ADODB.Connection)
Debug.Print "hi"
End Sub
Private Sub connRSBroker_ExecuteComplete(ByVal RecordsAffected As Long,
ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal
pCommand As ADODB.Command, ByVal pRecordset As ADODB.Recordset, ByVal
pConnection As ADODB.Connection)
Dim par As ADODB.Property
For Each par In pCommand.Properties
Debug.Print par.Name & " is " & par.Value
Next
End Sub
Private Sub conn_ExecuteComplete(ByVal RecordsAffected As Long, ByVal pError
As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pCommand As
ADODB.Command, ByVal pRecordset As ADODB.Recordset, ByVal pConnection As
ADODB.Connection)
'Dim par As ADODB.Property
'For Each par In pCommand.Properties
' Debug.Print par.Name & " is " & par.Value
' Next
End Sub