I have written the following code using the MS KnowledgeBase Article
Creating a Data Aware Class and would like to write the fields in my
recordset out to an existing table called GlassPro which has columns with
the same names assigned to the fields in the recordset. To this end I have
written a function called WriteToFile() of this Data Aware Class called
GlassDataSource. The WriteToFile() function has the Connection String set up
correctly but that is all. Can anyone help me ?
Public rsGlass As ADODB.Recordset
Public Sub Class_GetDataMember(DataMember As String, Data As Object)
Set Data = rsGlass
End Sub
Public Sub Class_Initialize()
Dim fld As ADODB.Field
Dim strRow As String
Dim strField As String
Set rsGlass = New ADODB.Recordset
With rsGlass
.Fields.Append "CustomerCode", adVarChar, 6, adFldUpdatable
.Fields.Append "CustomerName", adVarChar, 30, adFldUpdatable
.Fields.Append "OrderDate", adVarChar, 6, adFldUpdatable
.Fields.Append "Batch Number", adVarChar, 8, adFldUpdatable
.Fields.Append "Order Number", adVarChar, 6, adFldUpdatable
.Fields.Append "ItemNumber", adVarChar, 3, adFldUpdatable
.Fields.Append "Quantity", adVarChar, 4, adFldUpdatable
.Fields.Append "GlassLeaf1", adVarChar, 6, adFldUpdatable
.Fields.Append "GlassLeaf2", adVarChar, 6, adFldUpdatable
.Fields.Append "SpacerCode", adVarChar, 3, adFldUpdatable
.Fields.Append "Width1", adVarChar, 4, adFldUpdatable
.Fields.Append "Width2", adVarChar, 4, adFldUpdatable
.Fields.Append "Height1", adVarChar, 4, adFldUpdatable
.Fields.Append "Height2", adVarChar, 4, adFldUpdateable
.Fields.Append "ProductionDesc", adVarChar, 32, adFldUpdateable
.Fields.Append "DeliveryDate", adVarChar, 6, adFldUpdateable
.Fields.Append "DeliveryName", adVarChar, 30, adFldUpdateable
.Fields.Append "OrderReference", adVarChar, 20, adFldUpdateable
.Fields.Append "Comment", adVarChar, 20, adFldUpdatable
.Fields.Append "GlassLeaf3", adVarChar, 6, adFldUpdatable
.Fields.Append "SpacerCode2", adVarChar, 3, adFldUpdatable
.Fields.Append "ProcessWork1", adVarChar, 20, adFldUpdatable
.Fields.Append "ProcessWork2", adVarChar, 20, adFldUpdatable
.Fields.Append "ProcessWork3", adVarChar, 20, adFldUpdatable
.Fields.Append "ProcessWork4", adVarChar, 20, adFldUpdatable
.Fields.Append "ProcessWork5", adVarChar, 20, adFldUpdatable
.Fields.Append "ProductionDescription", adVarChar, 20, adFldUpdatable
.Fields.Append "DeliveryRoute", adVarChar, 2, adFldUpdatable
.Fields.Append "CollectedCode", adVarChar, 1, adFldUpdatable
.Fields.Append "PackedCode", adVarChar, 1, adFldUpdatable
.Fields.Append "ProductRoute1", adVarChar, 4, adFldUpdatable
.Fields.Append "ProductRoute2", adVarChar, 4, adFldUpdatable
.Fields.Append "ProductRoute3", adVarChar, 4, adFldUpdatable
.Fields.Append "ProductRoute4", adVarChar, 4, adFldUpdatable
.Fields.Append "ProductRoute5", adVarChar, 4, adFldUpdatable
.Fields.Append "ProductRoute6", adVarChar, 4, adFldUpdatable
.Fields.Append "ProductRoute7", adVarChar, 4, adFldUpdatable
.Fields.Append "ProductRoute8", adVarChar, 4, adFldUpdatable
.Fields.Append "ProductRoute9", adVarChar, 4, adFldUpdatable
.Fields.Append "ProductRoute10", adVarChar, 4, adFldUpdatable
.Fields.Append "ShapeCode", adVarChar, 1, adFldUpdatable
.Fields.Append "ShapeDims1", adVarChar, 4, adFldUpdatable
.Fields.Append "ShapeDims2", adVarChar, 4, adFldUpdatable
.Fields.Append "ShapeDims3", adVarChar, 4, adFldUpdatable
.Fields.Append "ShapeDims4", adVarChar, 4, adFldUpdatable
.Fields.Append "ShapeDims5", adVarChar, 4, adFldUpdatable
.Fields.Append "ShapeDims6", adVarChar, 4, adFldUpdatable
.Fields.Append "ShapeDims7", adVarChar, 4, adFldUpdatable
.Fields.Append "ShapeDims8", adVarChar, 4, adFldUpdatable
.Fields.Append "ShapeDims9", adVarChar, 4, adFldUpdatable
.Fields.Append "ShapeDims10", adVarChar, 4, adFldUpdatable
' use keyset cursor type to allow updating records.
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Open
End With
Open "C:\Data\Gpopt2.DAT" For Input As #1
Do Until EOF(1)
Line Input #1, strRow
With rsGlass
.AddNew
For Each fld In .Fields
fld.Value = Left(strRow, fld.DefinedSize)
strRow = Mid(strRow, fld.DefinedSize + 1)
Next
.Update
End With
Loop
Close
rsGlass.MoveFirst
End Sub
Public Function WriteToFile()
Dim conn As New ADODB.Connection
Dim cmd As New ADODB.Command
Dim tablename As TableDef
Dim fld As ADODB.Field
Dim strField As String
conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data
Source=C:\Data\highway.mdb;Persist Security Info=False"
Set cmd.ActiveConnection = conn
rsGlass.CursorLocation = adUseServer
cmd.CommandText = "INSERT INTO GlassPro(CustomerCode)"
conn.BeginTrans
rsGlass.Open cmd, adOpenDynamic, adLockOptimistic
conn.CommitTrans
Else
conn.RollbackTrans
End If
rsGlass.Close
conn.Close
Set rsGlass = Nothing
Set conn = Nothing
End Function