Option Compare Database
Const xlNone = -4142
Const xlContinuous = 1
Const xlThin = 2
Const xlAutomatic = -4105
Const xlDiagonalDown = 5
Const xlDiagonalUp = 6
Const xlEdgeBottom = 9
Const xlEdgeLeft = 7
Const xlEdgeRight = 10
Const xlEdgeTop = 8
Const xlInsideHorizontal = 12
Const xlInsideVertical = 11
Public Function Export_RecordSet_to_Excel_DAO(varRecordset As DAO.Recordset, Optional lStartColumn As Long = 0, Optional bAutoFilter As Boolean = False, Optional bRecCount As Boolean = False) As Boolean
' экспорт содержимого DAO рекордсета в Excel
' Create by: DKV
'
' Вход:
' varRecordset - рекордсет с данными
' lStartColumn - номер первого выводимого столбца (начиная с 0)
' bAutoFilter - выставлять автофильтр?
' bRecCount - вывести общее количество записей?
On Error GoTo Err_Debug
Dim xlsApp As Object
Dim xlsBook As Object
Dim xlsSheet As Object
Dim RcsCols As Long
Dim iCols As Long
Dim lResult As String
DoCmd.Hourglass True
If varRecordset.RecordCount = 0 Then
MsgBox "Выборка пуста."
GoTo Exit_Here
Else
RcsCols = varRecordset.Fields.Count
varRecordset.MoveLast
varRecordset.MoveFirst
End If
Set xlsApp = CreateObject("Excel.Application")
Set xlsBook = xlsApp.Workbooks.Add
Set xlsSheet = xlsBook.Worksheets(1)
xlsApp.Application.ReferenceStyle = -4150
xlsSheet.Activate
' xlsApp.Visible = True
With xlsSheet
For iCols = 0 To RcsCols - 1 - lStartColumn
.Cells(1, iCols + 1).VALUE = varRecordset.Fields(iCols + lStartColumn).Name
Next
.Range(.Cells(1, 1), .Cells(1, RcsCols - lStartColumn)).Font.Bold = True
For irows = 1 To varRecordset.RecordCount
For iCols = 0 To RcsCols - 1 - lStartColumn
Select Case varRecordset.Fields(iCols + lStartColumn).type
Case dbDate
xlsSheet.Cells(irows + 1, iCols + 1).NumberFormat = "dd/mm/yy h:mm;@"
xlsSheet.Cells(irows + 1, iCols + 1).VALUE = CDate(varRecordset.Fields(iCols + lStartColumn).VALUE)
Case Else
xlsSheet.Cells(irows + 1, iCols + 1).NumberFormat = ""
xlsSheet.Cells(irows + 1, iCols + 1).VALUE = Left(varRecordset.Fields(iCols + lStartColumn), 255)
End Select
' Debug.Print varRecordset(iCols + lStartColumn).type & "-" & varRecordset(iCols + lStartColumn)
Next
varRecordset.MoveNext
Next
If bRecCount Then
.Cells(irows + 2, 1) = "Всего записей: " & varRecordset.RecordCount
.Cells(irows + 2, 1).Font.Bold = True
.Cells(irows + 2, 1).Font.Italic = True
End If
.Cells.EntireColumn.AutoFit
.Cells.EntireRow.AutoFit
.Range(.Cells(1, 1), .Cells(1, RcsCols - lStartColumn)).Interior.ColorIndex = 15
.Range(.Cells(1, 1), .Cells(1, RcsCols - lStartColumn)).Interior.Pattern = 1
' .Range(.Cells(1, 1), .Cells(irows + 1, RcsCols - lStartColumn)).EntireColumn.AutoFit
Call DrowBorder(.Range(.Cells(1, 1), .Cells(varRecordset.RecordCount, RcsCols - lStartColumn)))
End With
If bAutoFilter Then
xlsApp.Selection.AutoFilter
End If
xlsApp.Visible = True
Export_RecordSet_to_Excel_DAO = True
Exit_Here:
DoCmd.Hourglass False
Set xlsSheet = Nothing
Set xlsBook = Nothing
Set xlsApp = Nothing
Exit Function
Err_Debug:
MsgBox "Ошибка! Возможно данные выгружение некорректно. " & Err.Description
Export_RecordSet_to_Excel_DAO = False
Resume Exit_Here
End Function
Public Function Export_RecordSet_to_Excel_ADO(varRecordset As ADODB.Recordset, Optional lStartColumn As Long = 0, Optional bAutoFilter As Boolean = False, Optional bRecCount As Boolean = False) As Boolean
' экспорт содержимого ADO рекордсета в Excel
' Create by: DKV
'
' Вход:
' varRecordset - рекордсет с данными
' lStartColumn - номер первого выводимого столбца (начиная с 0)
' bAutoFilter - выставлять автофильтр?
' bRecCount - вывести общее количество записей?
On Error GoTo Err_Debug
Dim xlsApp As Object
Dim xlsBook As Object
Dim xlsSheet As Object
Dim RcsCols As Long
Dim iCols As Long
Dim lResult As String
DoCmd.Hourglass True
If varRecordset.RecordCount = 0 Then
MsgBox "Выборка пуста."
GoTo Exit_Here
Else
RcsCols = varRecordset.Fields.Count
varRecordset.MoveLast
varRecordset.MoveFirst
End If
Set xlsApp = CreateObject("Excel.Application")
Set xlsBook = xlsApp.Workbooks.Add
Set xlsSheet = xlsBook.Worksheets(1)
xlsApp.Application.ReferenceStyle = -4150
xlsSheet.Activate
' xlsApp.Visible = True
With xlsSheet
For iCols = 0 To RcsCols - 1 - lStartColumn
.Cells(1, iCols + 1).VALUE = varRecordset.Fields(iCols + lStartColumn).Name
Next
.Range(.Cells(1, 1), .Cells(1, RcsCols)).Font.Bold = True
For irows = 1 To varRecordset.RecordCount
For iCols = 0 To RcsCols - 1 - lStartColumn
lResult = Nz(varRecordset.Fields(iCols + lStartColumn), vbNullString)
Select Case varRecordset.Fields(iCols + lStartColumn).type
Case dbDate
xlsSheet.Cells(irows + 1, iCols + 1).NumberFormat = "dd/mm/yy h:mm;@"
xlsSheet.Cells(irows + 1, iCols + 1).VALUE = CDate(lResult)
Case Else
xlsSheet.Cells(irows + 1, iCols + 1).NumberFormat = ""
xlsSheet.Cells(irows + 1, iCols + 1).VALUE = Left(lResult, 255)
End Select
' xlsSheet.Cells(irows + 1, iCols + 1).NumberFormat = "@"
' xlsSheet.Cells(irows + 1, iCols + 1).VALUE = lResult
Next
varRecordset.MoveNext
Next
If bRecCount Then
.Cells(irows + 2, 1) = "Всего записей: " & varRecordset.RecordCount
.Cells(irows + 2, 1).Font.Bold = True
.Cells(irows + 2, 1).Font.Italic = True
End If
.Cells.EntireColumn.AutoFit
.Cells.EntireRow.AutoFit
.Range(.Cells(1, 1), .Cells(1, RcsCols - lStartColumn)).Interior.ColorIndex = 15
.Range(.Cells(1, 1), .Cells(1, RcsCols - lStartColumn)).Interior.Pattern = 1
' .Range(.Cells(1, 1), .Cells(irows + 1, RcsCols - lStartColumn)).EntireColumn.AutoFit
Call DrowBorder(.Range(.Cells(1, 1), .Cells(varRecordset.RecordCount, RcsCols - lStartColumn)))
End With
If bAutoFilter Then
xlsApp.Selection.AutoFilter
End If
xlsApp.Visible = True
Export_RecordSet_to_Excel_ADO = True
Exit_Here:
DoCmd.Hourglass False
Set xlsSheet = Nothing
Set xlsBook = Nothing
Set xlsApp = Nothing
Exit Function
Err_Debug:
Debug.Print Err.Description
Export_RecordSet_to_Excel_ADO = False
Resume Exit_Here
End Function
Public Sub DrowBorder(lRange As Variant)
' отрисовка границ в Excel
' Create by: DKV
'
' Вход:
' lRange - диапазон ячеек дляч отрисовки
On Error GoTo Err_Debug
With lRange
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalDown).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
Exit_Here:
Exit Sub
Err_Debug:
Debug.Print Err.Description
Resume Exit_Here
End Sub
|