Медленный экспорт

Работа VB и СУБД (Access, MSSQL, MySQL, Oracle и пр.)
Правила форума
При создании новой темы не забывайте указывать используемую СУБД.
Cnoppiks
Обычный пользователь
Обычный пользователь
 
Сообщения: 89
Зарегистрирован: 17.08.2005 (Ср) 17:52

Медленный экспорт

Сообщение Cnoppiks » 01.12.2005 (Чт) 14:07

Скажите, почему программными средствами экспорт в ексель из Access таблицы занимает много времени? В таблице порядка 3000 записей. Если пользоваться меню Файл - Экспорт - то за пару секунд...
Код: Выделить всё
   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
Член-корреспондент академии VBStreets
Член-корреспондент академии VBStreets
 
Сообщения: 3287
Зарегистрирован: 21.05.2004 (Пт) 9:28
Откуда: Москва

Сообщение Andrey Fedorov » 01.12.2005 (Чт) 15:08

Потому что ты по одной ячейке загоняешь.

Пиши сразу весь Recordset и будет быстро.

Аналогия - чтение/запись файла по байтику...
Фиг Вам! - Сказал Чебурашка, обгладывая Крокодила Гену...

Cnoppiks
Обычный пользователь
Обычный пользователь
 
Сообщения: 89
Зарегистрирован: 17.08.2005 (Ср) 17:52

Сообщение Cnoppiks » 01.12.2005 (Чт) 15:29

Andrey Fedorov
Ну да, так оно и есть, однако что то не могу сообразить как весь его закинуть туда...
Хочу все знать....

Andrey Fedorov
Член-корреспондент академии VBStreets
Член-корреспондент академии VBStreets
 
Сообщения: 3287
Зарегистрирован: 21.05.2004 (Пт) 9:28
Откуда: Москва

Сообщение 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
Фиг Вам! - Сказал Чебурашка, обгладывая Крокодила Гену...

Cnoppiks
Обычный пользователь
Обычный пользователь
 
Сообщения: 89
Зарегистрирован: 17.08.2005 (Ср) 17:52

Сообщение Cnoppiks » 01.12.2005 (Чт) 16:22

Спасибо... А если попробовать с CopyFromRecordset? Кто нить пробовал?
Хочу все знать....

Andrey Fedorov
Член-корреспондент академии VBStreets
Член-корреспондент академии VBStreets
 
Сообщения: 3287
Зарегистрирован: 21.05.2004 (Пт) 9:28
Откуда: Москва

Сообщение Andrey Fedorov » 01.12.2005 (Чт) 16:26

Cnoppiks писал(а):Спасибо... А если попробовать с CopyFromRecordset? Кто нить пробовал?


Так тоже должно буть нормально - путей как всегда много.
Мне просто хватило того что привел выше - экспериментами заниматься дальше было неохота...
Фиг Вам! - Сказал Чебурашка, обгладывая Крокодила Гену...

VVitafresh
Продвинутый гуру
Продвинутый гуру
Аватара пользователя
 
Сообщения: 1641
Зарегистрирован: 12.05.2005 (Чт) 14:44
Откуда: Херсон, UA

Сообщение 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
Обычный пользователь
Обычный пользователь
 
Сообщения: 89
Зарегистрирован: 17.08.2005 (Ср) 17:52

Сообщение Cnoppiks » 09.12.2005 (Пт) 12:56

VVitafresh

Спасибо !!!Уже давно сделал так же-) Единственной проблемой тогда было сохранение, но найдя свойство FileDialog, проблема частично ушла. Осталось только странное свойство-при сохранении выскакивает еще и дубликат сохраняемого ексель-листа-) Сейчас времени нет разбираться, позже разберусь в чем трабл.
Хочу все знать....


Вернуться в Базы данных

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 2

    TopList  
cron