Here's a routine that I use to append daily stock price information to the MDB
file where I keep historical quotes. I have a generic function that sets up
the connection, rather than doing that in the sub itself.
Prices() is a module level array, defined with a Type/End Type block.
Private Sub WritePricesToMDBFile()
Dim cnn As ADODB.Connection
Dim FieldNames As Variant
Dim rst As ADODB.Recordset
Dim SQLOpen As String
Dim SQLTicker As String
Dim Stk As Long
Dim ThisTicker As String
Dim ThisDate As Date
Dim ThisPrice As Double
'08/23/2004: Prices table in ClosePrices.mdb is now linked to
'MutFunds.mdb, so don't have to update two databases
FieldNames = Array("PrTicker", "PrDate", "PrNAV")
ThisDate = Prices(0).TradeDate 'Prices() is module-level
SQLTicker = "PrTicker = 'TTTT'"
'open connection to the file -- function is in Personal.xls
Set cnn = OpenConnection("ClosePrices.MDB")
'create recordset
Set rst = New ADODB.Recordset
With rst
.ActiveConnection = cnn
' immediate & batch update modes use different settings for
' CursorType, CursorLocation and LockType
' 'Immediate update mode:
' .CursorType = adOpenKeyset
' .CursorLocation = adUseServer
' .LockType = adLockOptimistic
' Batch update mode:
.CursorType = adOpenStatic
.CursorLocation = adUseClient
.LockType = adLockBatchOptimistic
'open it, retrieving records for ThisDate only
SQLOpen = "SELECT * FROM Prices WHERE PrDate = " & SQLDate(ThisDate)
.Open Source:=SQLOpen, Options:=adCmdText
If .RecordCount = 0 Then
'there are no records for this date;
'add new record for each ticker
For Stk = LBound(Prices) To UBound(Prices)
.AddNew FieldNames, _
Array(Prices(Stk).Ticker, ThisDate, Round(Prices(Stk).Last, 3))
.Update
Next Stk
Else
'file already has *some* prices for this date, but possibly not all
'if record exists for this ticker, update it; if not, add one
For Stk = LBound(Prices) To UBound(Prices)
ThisTicker = Prices(Stk).Ticker
ThisPrice = Round(Prices(Stk).Last, 3)
.MoveFirst
.Find Replace(SQLTicker, "TTTT", ThisTicker)
If .EOF Then
'no price for this ticker
.AddNew FieldNames, Array(ThisTicker, ThisDate, ThisPrice)
Else
'update existing price
!PrNAV = ThisPrice
End If
.Update
Next Stk
End If
.UpdateBatch
End With 'rst
Set rst = Nothing
cnn.Close
Set cnn = Nothing
End Sub 'WritePricesToMDBFile
Function OpenConnection(dBaseName As String) As ADODB.Connection
Dim Cnxn As ADODB.Connection
Set Cnxn = New ADODB.Connection
With Cnxn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Data Source = " & XLDocDir & dBaseName
.Open
End With
Set OpenConnection = Cnxn
Set Cnxn = Nothing
End Function
