Cnoppiks » 01.12.2005 (Чт) 14:07
If RecAccess.RecordCount <> 0 Then
RecAccess.MoveFirst
Do
k = 1
For Each fldLoop In RecAccess.Fields
Ex.ActiveSheet.Cells(j, k).Value = fldLoop.Value
k = k + 1
Next fldLoop
j = j + 1
RecAccess.MoveNext
Loop Until RecAccess.EOF
End If
Andrey Fedorov » 01.12.2005 (Чт) 15:08
Andrey Fedorov » 01.12.2005 (Чт) 16:08
Cnoppiks писал(а):Ну да, так оно и есть, однако что то не могу сообразить как весь его закинуть туда...
Public Function SaveRecordsetAsExcelFile(ByRef SourceRecordset As ADODB.Recordset, _
ByRef ExcelFileName As String, _
ByVal WorksheetName As String, _
Optional ByVal AscFileName As Boolean = True, _
Optional hWnd As Long = 0, _
Optional Captions As String = "", _
Optional bShowSuccess As Boolean = True) As Boolean
Dim bResimeStart As Boolean
Dim cnnExcel As ADODB.Connection
Dim catExcel As ADOX.Catalog
Dim tblWorksheet As ADOX.Table
Dim rstExcelData As ADODB.Recordset
Dim fldColumnHeader As ADODB.Field
Dim strWkshtName As String, i As Long, s As String
Dim vc As Variant
vc = Split(Captions, "|")
If SourceRecordset.RecordCount Then
SourceRecordset.MoveLast
SourceRecordset.MoveFirst
If SourceRecordset.RecordCount > 64000 Then
MsgBox "Слишком много строк для экспорта в Excel!", vbInformation: Exit Function
End If
Else
MsgBox "Нет данных для экспорта в Excel-файл!", vbInformation: Exit Function
End If
If hWnd = 0 Then hWnd = Screen.ActiveForm.hWnd
If AscFileName Or Len(ExcelFileName) = 0 Then
ExcelFileName = FileSaveDialog(hWnd, "Книга Microsoft Office Excel (*.xls)|*.xls", "Имя файла Excel для экспорта", g_sExportPath, ExcelFileName, "xls")
If Len(ExcelFileName) = 0 Then Exit Function
End If
i = InStrRev(ExcelFileName, "")
If i > 0 Then g_sExportPath = Left$(ExcelFileName, i)
ResumeStart:
Screen.MousePointer = vbHourglass
On Error GoTo EH_SaveRecordsetAsExcelFile
If FileExists(ExcelFileName) Then
If 0 = DeleteFile(ExcelFileName) Then
Screen.MousePointer = vbDefault
MsgBox "Файл не может быть удален так как он занят другой программой!", vbInformation
Exit Function
End If
End If
' Create Excel file and worksheet
Set cnnExcel = New ADODB.Connection
Set catExcel = New ADOX.Catalog
Set tblWorksheet = New ADOX.Table
cnnExcel.CursorLocation = adUseClient
cnnExcel.Provider = "Microsoft.Jet.OLEDB.4.0"
cnnExcel.Properties("Extended Properties") = "Excel 8.0"
cnnExcel.Properties("Locale Identifier") = 1049
cnnExcel.Open "Data Source = " & ExcelFileName
Set catExcel.ActiveConnection = cnnExcel
tblWorksheet.Name = WorksheetName
i = 0
For Each fldColumnHeader In SourceRecordset.Fields
If i <= UBound(vc) Then s = vc(i) Else s = ""
If Len(s) = 0 Then
s = fldColumnHeader.Name
s = Replace(s, ".", "")
End If
Select Case fldColumnHeader.Type
Case adVarChar, adChar, adVarWChar, adWChar
tblWorksheet.Columns.Append s, adVarWChar
Case adDBTimeStamp
tblWorksheet.Columns.Append s, adDate
Case adCurrency
tblWorksheet.Columns.Append s, adDouble
Case Else
tblWorksheet.Columns.Append s, fldColumnHeader.Type
End Select
i = i + 1
Next fldColumnHeader
catExcel.Tables.Append tblWorksheet
Set tblWorksheet = Nothing
Set catExcel = Nothing
Set cnnExcel = Nothing
' Fill worksheet with data
Set cnnExcel = New ADODB.Connection
Set rstExcelData = New ADODB.Recordset
With cnnExcel
.CursorLocation = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Extended Properties") = "Excel 8.0"
.Properties("Locale Identifier") = 1049
.Open ExcelFileName
' strWkshtName = "[" & WorksheetName & "$]"
strWkshtName = "[" & WorksheetName & "]"
With rstExcelData
Set .ActiveConnection = cnnExcel
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockOptimistic
.Source = strWkshtName
.Open
End With 'rstExcelData
With SourceRecordset
.MoveFirst
Do While Not .EOF
rstExcelData.AddNew: i = 0
For Each fldColumnHeader In .Fields
' rstExcelData.Fields(fldColumnHeader.Name) = fldColumnHeader 'insert value
If fldColumnHeader.Type = adCurrency Then
If Not IsNull(fldColumnHeader) Then rstExcelData.Fields(i) = Round(fldColumnHeader, 2)
Else
rstExcelData.Fields(i) = fldColumnHeader 'insert value
End If
i = i + 1
Next fldColumnHeader
rstExcelData.Update
.MoveNext
Loop
End With 'SourceRecordset
.Close 'cnnExcel
End With 'cnnExcel
Set cnnExcel = Nothing
Set rstExcelData = Nothing
Set fldColumnHeader = Nothing
SaveRecordsetAsExcelFile = True
If bShowSuccess Then
Screen.MousePointer = vbDefault
MsgBox "Данные успешно экспортированы!", vbInformation
End If
Exit Function
EH_SaveRecordsetAsExcelFile:
Screen.MousePointer = vbDefault
If Err.Number = -2147467259 Then
If cnnExcel.Errors.Count Then
If cnnExcel.Errors(0).Number = -2147467259 And cnnExcel.Errors(0).NativeError = -329323426 Then
If Not bResimeStart Then
bResimeStart = True
cnnExcel.Errors.Clear: Err.Clear
Set tblWorksheet = Nothing
Set catExcel = Nothing
cnnExcel.Close: Set cnnExcel = Nothing
Set rstExcelData = Nothing
Set fldColumnHeader = Nothing
GoTo ResumeStart
End If
End If
End If
End If
Set tblWorksheet = Nothing
Set catExcel = Nothing
Set cnnExcel = Nothing
Set rstExcelData = Nothing
Set fldColumnHeader = Nothing
MsgBox Err.Description, vbCritical, Err.Number
End Function
Andrey Fedorov » 01.12.2005 (Чт) 16:26
Cnoppiks писал(а):Спасибо... А если попробовать с CopyFromRecordset? Кто нить пробовал?
VVitafresh » 09.12.2005 (Пт) 0:36
Cnoppiks писал(а):Спасибо... А если попробовать с CopyFromRecordset? Кто нить пробовал?
Dim oXL As Object
Dim oWBook As Object
Dim oWSheet As Object
Set oXL = CreateObject("Excel.Application")
oXL.SheetsInNewWorkbook = 2
Set oWBook = oXL.Workbooks.Add
Set oWSheet = oXL.Worksheets(1)
oXL.Visible = True
oWSheet.Range("A2").CopyFromRecordset rsTemp
Set oXL = Nothing
Cnoppiks » 09.12.2005 (Пт) 12:56
Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 2