'-----------------------------------------------------------------------------
'======== 'This program has been written by Frederic Fievez on April 22th, 2002 ======
Public Function Export2XL(InitRow
As Long, DBAccess
As String, DBTable
As String)
As Long '+
' Экспортирует с базы в Exel
Dim cn
As New ADODB.Connection
'Use for the connection string
Dim cmd
As New ADODB.Command
'Use for the command for the DB
Dim rs
As New ADODB.Recordset
'Recordset return from the DB
Dim MyIndex
As Integer 'Used for Index
Dim MyRecordCount
As Long 'Store the number of record on the table
Dim MyFieldCount
As Integer 'Store the number of fields or column
Dim ApExcel
As Object 'To open Excel
Dim MyCol
As String
Dim Response
As Integer
Set ApExcel = CreateObject("Excel.application"
'Creates an object
ApExcel.Visible =
True 'This enable you to see the process in Excel
ApExcel.Workbooks.Add
'Adds a new book.
'Set the connection string
cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0
ata Source=" & DBAccess
'Open the connection
cn.
Open
'Check that the connection is open
If cn.State = 0
Then cn.
Open
Set cmd.ActiveConnection = cn
cmd.CommandText = DBTable
cmd.CommandType = adCmdTable
Set rs = cmd.Execute
'Count the number of fields or column
MyFieldCount = rs.Fields.Count
'Fill the first line with the name of the fields
For MyIndex = 0
To MyFieldCount - 1
ApExcel.Cells(InitRow, (MyIndex + 1)).Formula = rs.Fields(MyIndex).
Name 'Write Title to a Cell
ApExcel.Cells(InitRow, (MyIndex + 1)).Font.Bold =
True
ApExcel.Cells(InitRow, (MyIndex + 1)).interior.colorindex = 36
ApExcel.Cells(InitRow, (MyIndex + 1)).WrapText =
True
Next
'Draw border on the title line
MyCol = Chr((64 + MyIndex)) & InitRow
ApExcel.Range("A" & InitRow & ":" & MyCol).Borders.Color = RGB(0, 0, 0)
MyRecordCount = 1 + InitRow
'Fill the excel book with the values from the database
Do While rs.EOF =
False
For MyIndex = 1
To MyFieldCount
ApExcel.Cells(MyRecordCount, MyIndex).Formula = rs((MyIndex - 1)).Value
'Write Value to a Cell
ApExcel.Cells(MyRecordCount, MyIndex).WrapText =
False 'Format the Cell
Next
MyRecordCount = MyRecordCount + 1
rs.MoveNext
If MyRecordCount > 50
Then
Exit Do
End If
Loop
'Close the connection with the DB
rs.Close
'Return the last position in the workbook
Export2XL = MyRecordCount
End Function
'===================================================================================