by Gabio (9 Submissions)
Category: Databases/Data Access/DAO/ADO
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Wed 10th September 2003
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Save Ado Recordset to Excel File
VBcoders
Dim conS As String, strSql As String
Dim aCon As New ADODB.Connection, idx As Integer
conS = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & fileName & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes;"";"
aCon.ConnectionString = conS
aCon.CursorLocation = adUseServer
aCon.Mode = adModeShareExclusive
Call aCon.Open
strSql = "CREATE TABLE [" & tableName & "] ("
For idx = 0 To aRec.Fields.Count - 1
strSql = strSql & "[" & aRec.Fields(idx).Name & "] " & Me.GetAccessFieldType(aRec.Fields(idx))
If (Me.GetAccessFieldType(aRec.Fields(idx)) = "TEXT") Then
If aRec.Fields(idx).DefinedSize > 255 Then
strSql = strSql & ", "
Else
strSql = strSql & " (" & aRec.Fields(idx).DefinedSize & ") ,"
End If
Else
strSql = strSql & ", "
End If
Next idx
strSql = Left(strSql, Len(strSql) - 2) & " )"
Call aCon.Execute(strSql)
Dim oRec As New ADODB.Recordset
Set oRec.ActiveConnection = aCon
oRec.CursorLocation = adUseClient
oRec.LockType = adLockOptimistic
oRec.CursorType = adOpenKeyset
oRec.Source = "SELECT * FROM [" & tableName & "]"
oRec.Open
aRec.MoveFirst
Do Until aRec.EOF
oRec.AddNew
For idx = 0 To aRec.Fields.Count - 1
If Not IsNull(aRec.Fields(idx).Value) Then
oRec.Fields(idx).Value = aRec.Fields(idx).Value
End If
Next idx
aRec.MoveNext
oRec.Update
Loop
aRec.MoveFirst
oRec.Close
Set oRec = Nothing
aCon.Close
Set aCon = Nothing
End Sub
Public Function GetAccessFieldType(ByRef oField As ADODB.Field) As String
Dim strRez As String
Select Case oField.Type
Case adBSTR, adChar, adVarChar, adWChar, _
adVarWChar, adLongVarChar, adLongVarWChar
strRez = "TEXT"
Case adBigInt, adNumeric, adInteger, _
adSingle, adSmallInt, adTinyInt, adUnsignedBigInt, adUnsignedInt, _
adUnsignedSmallInt, adUnsignedTinyInt
strRez = "INTEGER"
Case adDecimal, adDouble
strRez = "DOUBLE"
Case adSingle
strRez = "SINGLE"
Case adCurrency
strRez = "CURRENCY"
Case adBoolean
strRez = "BIT"
Case adDBTimeStamp, adDBTime
strRez = "DATETIME"
End Select
GetAccessFieldType = strRez
End Function
