| |
|
|
| | Использовал http://hiprog.com/index.php?option=com_content&task=view&id=428
Лист открывается, но в нём не печатается пример использования
call ExcelChangeCells("Москва", 1, False, 3, 1,,,,1,"RED","YELLOW",9)
Без ошибок без надписей....  | |
| |
| |
| |
|
|
| | Ну лано, выкрутился - другим кодом....
Но вот вопрос:
Хочу нарисовать таблицу чтобы все бордюры были окрашены
Вставил код - вот
With xl.Range("A4:H" & row - 1).Borders
.Item(7).Weight = -4138 ' xlEdgeLeft
.Item(8).Weight = -4138 ' xlEdgeTop
.Item(9).Weight = -4138 ' xlEdgeBottom
.Item(10).Weight = -4138 ' xlEdgeRight
End With
|
Но получилось обрамление по периметру выделенного диапазона, а как каждую ячейку - это что циклом только? | |
| |
| |
| |
|
|
| | и ещё вопрос как уменьшить левый и правый колонтитул - отступ
=======================================================
Спасибо вопрос решён:
With xlSheet.PageSetup
.Orientation = 2
.Draft = False
.BlackAndWhite = False
.Zoom = 100
.LeftMargin = xl.Application.InchesToPoints(1)
.TopMargin = xl.Application.InchesToPoints(0.14)
.BottomMargin = xl.Application.InchesToPoints(0.14)
.RightMargin = xl.Application.InchesToPoints(0.14)
End With
|
| |
| |
| |
| |
|
|
| | Остаётся вопрос
как окрасить бордюры диапазона ячеек | |
| |
| |
| |
|
|
| | Как-то так у меня бордюрятся:
...
With .Range(.Cells(1, 1), .Cells(lngRecordCount + 1, i))
For j = 11 To 12
With .Borders(j)
.LineStyle = 1
.Weight = 2
.ColorIndex = 5
End With
Next j
For j = 7 To 10
With .Borders(j)
.LineStyle = -4119 ' xlDouble
.Weight = 4
.ColorIndex = 5
End With
Next j
End With
...
|
| |
| |
| |
| |
|
|
| | вот чего сам Excel написал
Range("B3:H16").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
|
| |
| |
| |
| |
|
|
| | Спасибо ...
Забыл передупредить - это фсё в VB6 фигачится и потому константы Excel - там надо заменять числовыми значениями ..... которых я к сожалению не знаю....
Это я пробовал - матерится...............
Range("B3:H16").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
|
 | |
| |
| |
| |
|
|
| | Спасибо!!
With .Range(.Cells(1, 1), .Cells(lngRecordCount + 1, i))
For j = 11 To 12
With .Borders(j)
.LineStyle = 1
.Weight = 2
.ColorIndex = 5
End With
Next j
For j = 7 To 10
With .Borders(j)
.LineStyle = -4119 ' xlDouble
.Weight = 4
.ColorIndex = 5
End With
Next j
End With
|
но это опять таки цикл...
это я так и делаю - наподобиииеие
====================================
В openeOfice есть проще способ - задал диапазон и хлобысть....... всё готово одним махом...
Незнаете в Excel такое имеется?
| |
| |
| |
| |
|
|
| | Вместо второго цикла, рисующего двойной бордер по периметру, можно пользовать метод BorderAround Range-а.
Для сеточки внутри таблицы пока метода не нашел.  | |
| |
| |
| |
|
|
| | ну - тоже самое
Range("C5:J19").Select
Selection.Borders(5).LineStyle = -4142
Selection.Borders(6).LineStyle = -4142
With Selection.Borders(7)
.LineStyle = 1
.Weight = 2
.ColorIndex = -4105
End With
With Selection.Borders(8)
.LineStyle = 1
.Weight = 2
.ColorIndex = -4105
End With
With Selection.Borders(9)
.LineStyle = 1
.Weight = 2
.ColorIndex = -4105
End With
With Selection.Borders(10)
.LineStyle = 1
.Weight = 2
.ColorIndex = -4105
End With
With Selection.Borders(11)
.LineStyle = 1
.Weight = 2
.ColorIndex = -4105
End With
With Selection.Borders(12)
.LineStyle = 1
.Weight = 2
.ColorIndex = -4105
End With | |
| |
| |
| |
|
|
| | Спасибо !! Завтра бум пробовать...
о - уже сегодня - но попозже, то есть пораньше, ну вобщем утром. | |
| |
| |
| |
|
|
| | И где ты наковырял столько констант????? - места нуна знать  | |
| |
| |
| |
|
|
| | А чего их ковырять то
открыл ёксель
включил макрос на запись
выделил диапазон
включил режим окрашивания бордюр в выделенном диапазоне
отключил запись
залез в VBA
поставил точку останова на End sub
запустил макрос
и посмотрел все значения всех констант в макросе
вот доработал
Range("C5:J19").Select
Selection.Borders(5).LineStyle = -4142
Selection.Borders(6).LineStyle = -4142
'Вариант 1
'рисуем сетку в выделенном диапазоне с тонкими линиями
For i = 7 To 12
With Selection.Borders(i)
.LineStyle = 1
.Weight = 2
.ColorIndex = -4105
End With
Next i
'Вариант 2
'рисуем сетку с жирным бордюром вокруг выделенного диапазона
'если убрать if......end if и оставить .Weight = -4138, то все бордюры в сетке
'будут жирными
' Rem стоит специально - что бы варианты не путать
Rem For i = 7 To 12
Rem With Selection.Borders(i)
Rem .LineStyle = 1
Rem If i = 11 Or i = 12 Then
Rem .Weight = 2
Rem Else
Rem .Weight = -4138
Rem End If
Rem .ColorIndex = -4105
Rem End With
Rem Next i
Cells(1, 1).Select 'уводим курсор в сторону
|
если в первом варианте
написать
.LineStyle = -4119
.Weight = 4
|
то все линии будут двойными | |
| |
| |
| |
|
|
| | для экспорта в Excel использую следующий модуль
2 процедуры. на вход соответственно рекордсеты DAO или ADO
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
|
| |
| |
| |
|
|
| |
|
|
| | по константам:
получить их можно легко. Войти в VBA редактор в Excel, вывести окно Intermidiate и в нем
таким макаром получим значение нужной константы | |
| |
| |
| |
|
|
| | Всё пучком!!!!!
СПАСИБО!!!!!!!  | |
| |
| |
| |
|
|
| | упс, небольшая ошибка вкралась:
вместо
Call DrowBorder(.Range(.Cells(1, 1), .Cells(varRecordset.RecordCount, RcsCols - lStartColumn)))
|
нужно
Call DrowBorder(.Range(.Cells(1, 1), .Cells(varRecordset.RecordCount + 1, RcsCols - lStartColumn)))
|
иначе последнюю строчку не расчерчивает | |
| |
| |
| |
|
|
| | Да да.....
| |
| |
| |
