Option Explicit
Private Const CONNSTRING As String = _
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source='$MDB$'"
Private DbPath As String
Private CN As ADODB.Connection
Private FieldIds As Variant
Private Sub OpenDb()
If Len(Dir$(DbPath, vbNormal)) > 0 Then
Set CN = New ADODB.Connection
CN.Open Replace$(CONNSTRING, "$MDB$", DbPath)
Else
With CreateObject("ADOX.Catalog")
.Create Replace$(CONNSTRING, "$MDB$", DbPath)
Set CN = .ActiveConnection
End With
CN.Execute "CREATE TABLE SOMETABLE(" _
& "F1 TEXT(25)," _
& "F2 TEXT(25)," _
& "F3 TEXT(25)," _
& "F4 TEXT(25)," _
& "F5 TEXT(25)," _
& "F6 TEXT(25)," _
& "F7 TEXT(25)," _
& "F8 TEXT(25))", _
, _
adCmdText Or adExecuteNoRecords
End If
CN.CursorLocation = adUseServer
FieldIds = Array("F1", "F2", "F3", "F4", "F5", "F6", "F7", "F8")
End Sub
Private Sub CloseDb()
CN.Close
End Sub
Private Sub PutString( _
ByRef StringData As String, _
ByVal Connection As ADODB.Connection, _
ByVal TableName As String, _
ByVal ColumnIds As Variant, _
Optional ByVal ColumnDelimiter As String = vbTab, _
Optional ByVal RowDelimiter As String = vbCr, _
Optional ByVal NullExpr As Variant = vbNullString)
'A sort of "inverse analog" of the ADO Recordset's GetString() method.
Dim RS As ADODB.Recordset
Dim ColumnStart As Long
Dim ColumnLength As Long
Dim ColumnValues() As Variant
Dim Pos As Long
Dim RowLimit As Long
Dim I As Long
Dim AtRowEnd As Boolean
If (VarType(ColumnIds) And vbArray) = 0 Then Err.Raise 5 'Invalid procedure call or argument.
With New ADODB.Command
Set .ActiveConnection = CN
.CommandType = adCmdTable
.CommandText = TableName
.Properties![Append-Only Rowset] = True
.Properties![Others' Changes Visible] = False 'Doesn't matter when using exclusive access.
Set RS = .Execute()
End With
ReDim ColumnValues(UBound(ColumnIds))
Pos = 1
Do
RowLimit = InStr(Pos, StringData, RowDelimiter)
If RowLimit = 0 Then RowLimit = Len(StringData)
I = 0
AtRowEnd = False
Do
ColumnStart = Pos
Pos = InStr(Pos, StringData, ColumnDelimiter)
If Pos = 0 Or Pos >= RowLimit Then
ColumnLength = RowLimit - ColumnStart
If Pos <> 0 Then
Pos = Pos + Len(RowDelimiter)
If Mid$(StringData, Pos, 1) = vbLf Then Pos = Pos + 1 'Auto-handle CrLf.
End If
AtRowEnd = True
Else
ColumnLength = Pos - ColumnStart
Pos = Pos + Len(ColumnDelimiter)
End If
ColumnValues(I) = Trim$(Mid$(StringData, ColumnStart, ColumnLength))
If Not IsMissing(NullExpr) Then
If ColumnValues(I) = NullExpr Then ColumnValues(I) = Null
End If
I = I + 1
Loop Until AtRowEnd
RS.AddNew ColumnIds, ColumnValues
Loop Until Pos = 0
End Sub
Private Sub Main()
Dim InsertAt As Long
Dim I As Long
Dim F As Long
Dim FieldText As String
Dim CsvLines As String
Dim T0 As Single
DbPath = App.Path & "\demo.mdb"
OpenDb
CN.Execute "DELETE FROM SOMETABLE", , adCmdText Or adExecuteNoRecords
Randomize
CsvLines = Space$(18& * 8& * 5700&)
InsertAt = 1
For I = 1 To 5700
For F = 1 To 8
FieldText = ChrW$(Int(Rnd() * 26) + 65) _
& CStr(Int(Rnd * 100000000)) _
& CStr(Int(Rnd * 100000000))
Mid$(CsvLines, InsertAt) = FieldText
If F = 8 Then
Mid$(CsvLines, InsertAt + Len(FieldText)) = vbCr
Else
Mid$(CsvLines, InsertAt + Len(FieldText)) = ","
End If
InsertAt = InsertAt + Len(FieldText) + 1
Next
Next
CsvLines = Left$(CsvLines, InsertAt - 1)
T0 = Timer()
PutString CsvLines, CN, "SOMETABLE", FieldIds, ","
MsgBox Format$(Timer() - T0, "#,##0.000")
CloseDb
End Sub