Option Compare Database Option Explicit Option Base 0 Public ExcelApp As Object ' объявляется под Excel
Public Function ExcelCreate(Optional ByVal pc_FromFileName As String = "", _ Optional pl_Show As Boolean = False) As Integer ' Создаёт Excel-файл ' pc_FromFileName - имя открываемого файла ' pl_Show - делать ли видимым Excel-объект ' ' Возвращает: 1 - Excel-файл создан успешно ' 0 - нет доступа к файлу (заблокирован путь) или файл (на основе которого создание) не существует ' -1 - ошибка запуска/наличия MS-Excel ' -2 - ошибка создания файла
pc_FromFileName = Trim(pc_FromFileName) If Not pc_FromFileName = "" Then On Error GoTo err1 If Len(Dir(pc_FromFileName)) < 1 Then ExcelCreate = 0 MsgBox "Не существует файла " & pc_FromFileName & ", на основе которого должен быть создан новый!", vbCritical + vbOKOnly, " " Exit Function End If End If On Error GoTo 0 If ExcelCheckApp(True) = False Then ExcelCreate = -1 Exit Function End If
On Error GoTo err2 ExcelApp.DisplayAlerts = False With ExcelApp If Len(pc_FromFileName) < 1 Then .Workbooks.Add Else .Workbooks.Add (pc_FromFileName) End If .Visible = pl_Show End With ExcelCreate = 1 Exit Function
err1: ExcelCreate = 0 MsgBox "Возможно нет доступа к файлу " & pc_FromFileName, vbCritical + vbOKOnly, " " Exit Function
err2: ExcelCreate = -2 MsgBox "Ошибка создания Excel-файла", vbCritical + vbOKOnly, " " Exit Function End Function Public Function ExcelOpen(ByVal pc_FileName As String, _ Optional pl_Show As Boolean = False, _ Optional pl_ReadOnly As Boolean = False) As Integer ' Открывает Excel-файл ' pc_FileName - имя открываемого файла ' pl_Show - делать ли видимым Excel-объект ' pl_ReadOnly - (=True) открытие в режиме "Только чтение" ' ' Возвращает: 1 - Excel-файл открыт успешно ' 0 - не указано имя открываемого файла ' -1 - нет доступа к файлу (заблокирован путь) или файл не существует ' -2 - ошибка запуска/наличия MS-Excel ' -3 - ошибка открытия файла
pc_FileName = Trim(pc_FileName) On Error GoTo err1 If pc_FileName = "" Then ExcelOpen = 0 MsgBox "Укажите имя Excel-файла !", vbCritical + vbOKOnly, " " Exit Function ElseIf Len(Dir(pc_FileName)) < 1 Then ExcelOpen = -1 MsgBox "Файла " & pc_FileName & " не существует!", vbCritical + vbOKOnly, " " Exit Function End If On Error GoTo 0 If ExcelCheckApp(True) = False Then ExcelOpen = -2 Exit Function End If
On Error GoTo err2 ExcelApp.DisplayAlerts = False With ExcelApp .Workbooks.Open pc_FileName, 0, pl_ReadOnly .Visible = pl_Show End With ExcelOpen = 1 Exit Function
err1: ExcelOpen = -1 MsgBox "Возможно нет доступа к файлу " & pc_FileName, vbCritical + vbOKOnly, " " Exit Function
err2: ExcelOpen = -3 MsgBox "Ошибка открытия Excel-файла " & pc_FileName, vbCritical + vbOKOnly, " " Exit Function End Function Public Function ExcelQuit() As Integer ' Закрывает Excel ' ' Возвращает: 1 - успешное закрытие Excel 0 - нет
Dim iiX As Integer, iiY As Integer
If ExcelCheckApp(False) = False Then Exit Function On Error GoTo err1 With ExcelApp iiY = .Workbooks.Count For iiX = 1 To iiY .ActiveWorkbook.Close (False) Next .Quit End With Set ExcelApp = Nothing ExcelQuit = 1 Exit Function
err1: ExcelQuit = 0 End Function Public Function ExcelSave(Optional ByVal pc_FileNameAs As String = "", _ Optional pl_Close As Boolean = True) As Integer ' Сохраняет Excel-документ ' pc_FileNameAs - если указано, то сохранение файла будет выполняться под указанным именем ' pl_Close - закрытие документа после его сохранения ' ' Возвращает: 1 - успешное сохранение Excel-документа ' 0 - ошибка сохранения Excel-файла ' -1 - ошибка при удалении предыдущей версии перед сохранением Excel-файла ' -2 - ошибка сохранения Excel-файла под указанным именем ' -3 - ошибка наличия MS-Excel/ отсутствия связи между глобальной объектной переменной ExcelApp и MS-Excel
If ExcelCheckApp(False) = False Then ExcelSave = -3 Exit Function End If pc_FileNameAs = Trim(pc_FileNameAs) With ExcelApp If Len(pc_FileNameAs) < 1 Then On Error GoTo err1 .ActiveWorkbook.Save Else On Error GoTo err2 If Len(Dir(pc_FileNameAs)) > 0 Then Kill pc_FileNameAs On Error GoTo err3 .ActiveWorkbook.Saveas (pc_FileNameAs) End If If pl_Close Then .ActiveWorkbook.Close (False) End With
ExcelSave = 1 Exit Function
err1: ExcelSave = 0 MsgBox "Ошибка сохранения Excel-файла !", vbCritical + vbOKOnly, " " Exit Function err2: ExcelSave = -1 MsgBox "Ошибка при удалении предыдущей версии перед сохранением Excel-файла " & _ pc_FileNameAs, vbCritical + vbOKOnly, " " Exit Function err3: ExcelSave = -2 MsgBox "Ошибка сохранения Excel-файла " & pc_FileNameAs, vbCritical + vbOKOnly, " " Exit Function End Function Public Function ExcelRowColCount(Optional ByVal WhatCount As String = "Row", _ Optional ByVal pu_Sheet As Variant = 1) As Long ' Возвращает: номер последнего заполненного столбца, если WhatCount="Column", ' иначе - номер последней заполненной строки в указанном pu_Sheet (номер или имя) листе ' или -1 - в случае неправильного задания параматра pu_Sheet ' или -2 - в случае отсутствия связи между глобальной объектной переменной ExcelApp и MS-Excel If ExcelCheckApp(False) = False Then ExcelRowColCount = -2 Exit Function End If If VarType(pu_Sheet) = vbString Then pu_Sheet = Trim(pu_Sheet) If ExcelCheckExistSheet(pu_Sheet) Then If WhatCount = "COLUMN" Then ExcelRowColCount = ExcelApp.Worksheets(pu_Sheet).Cells.SpecialCells(11).Column ' 11=xlCellTypeLastCell Else ExcelRowColCount = ExcelApp.Worksheets(pu_Sheet).Cells.SpecialCells(11).Row End If Else ExcelRowColCount = -1 End If End Function Public Sub ExcelChangeCells(ByVal pu_SeekValue As Variant, _ Optional ByVal pu_Sheet As Variant = 1, _ Optional pl_SlowSeek As Boolean = False, _ Optional ByVal pn_InColSeek As Long = 1, _ Optional ByVal pn_RowStart As Long = 1, _ Optional ByVal pn_RowEnd As Long = 0, _ Optional ByVal pn_ApplayColStart As Integer = 1, _ Optional ByVal pn_ApplayColEnd As Integer = 0, _ Optional ByVal pn_Fontbold As Integer = -1, _ Optional ByVal pc_BackColor As String = "", _ Optional ByVal pc_ForeColor As String = "", _ Optional ByVal pn_FontSize As Integer = 0, _ Optional pu_NewValue As Variant)
' pu_Sheet - номер или имя листа (если указан не верно, то данная процедура не выполняется) ' если вообще не указан, то данная процедура будет выполняться для первого листа
' pl_SlowSeek - если=True, то поиск по вхождению строки (только если в pu_SeekValue - символьное значение) ' иначе как равенство
' pn_InColSeek - в листе по колонке с каким номером вести поиск, если указан как < 1, или вообще не указан ' то поиск будет выполняться по первой колонке
' pn_RowStart - начиная с какой строки листа будет выполняться ПОИСК и изменение ячеек ' если не указано или указано как < 1, то начиная с первой строки листа, ' если же pn_RowStart > pn_RowEnd, то pn_RowStart=pn_RowEnd
' pn_RowEnd - по какую строку листа включительно будет выполняться ПОИСК и изменение ячеек ' но не более, чем последняя строка в листе, в которой есть хоть какое-то значение
' pn_ApplayColStart - начиная с какой колонки листа будет выполняться изменение ячеек ' если не указано или указано как < 1, то начиная с первой колонки листа, ' если же pn_ApplayColStart > pn_ApplayColEnd, то pn_ApplayColStart=pn_ApplayColEnd
' pn_ApplayColEnd - по какую колонку листа включительно будет выполняться изменение ячеек ' но не более, чем последняя колонка в листе, в которой есть хоть какое-то значение
' Нижеприведённые параметры затрагивают ячейки в диапазоне с pn_RowStart, pn_ApplayColStart ' до pn_RowEnd, pn_ApplayColEnd
' pn_Fontbold - если = 1 - жирный шрифт ячеек, 0 - обычный шрифт, иначе - тип шрифта НЕ меняется
' pc_BackColor - цвет фона ячеек, допустимые значения: ' "RED", "YELLOW", "GREEN", "DARKBLUE", "BLUE", "GREY", "CRIMSON", "BLACK", "WHITE" ' Если передано какое-то другое значение, то цвет сбрасывается в None, ' если же параметр не был задан, то цвет НЕ трогается вообще
' pc_ForeColor - цвет шрифта ячеек (см. также комментарий к pc_BackColor)
' pn_FontSize - номер шрифта ячеек, допустимый диапазон 6...50 ' если номер не указан или вне данного диапазона, то шрифт НЕ меняется
' pu_NewValue - если был передан данный параметр, то значение данного параметра ' присваивается в качестве содержимого ячеек ' Dim ln_rowStart As Long, ln_rowEnd As Long, ln_ColSeek As Integer, ln_NumColStart As Integer, _ ln_NumColEnd As Integer, cl As Variant, ll_okSeek As Boolean, ln_colorIndex As Integer, _ ln_color As Integer, iiX As Integer
Select Case VarType(pu_SeekValue) Case vbString pu_SeekValue = UCase(Trim(pu_SeekValue)) If Len(pu_SeekValue) < 1 Then Exit Sub Case vbDate, vbDecimal, vbInteger, vbLong, vbDouble, vbSingle, vbBoolean Case Else Exit Sub End Select If ExcelCheckApp(False) = False Then Exit Sub If VarType(pu_Sheet) = vbString Then pu_Sheet = Trim(pu_Sheet) If ExcelCheckExistSheet(pu_Sheet) = False Then Exit Sub pc_BackColor = UCase(Trim(pc_BackColor)) pc_ForeColor = UCase(Trim(pc_ForeColor)) Select Case pc_BackColor Case "BLACK" ln_colorIndex = 1 Case "WHITE" ln_colorIndex = 2 Case "RED" ln_colorIndex = 3 Case "YELLOW" ln_colorIndex = 6 Case "GREEN" ln_colorIndex = 4 Case "DARKBLUE" ln_colorIndex = 5 Case "BLUE" ln_colorIndex = 8 Case "GREY" ln_colorIndex = 15 Case "CRIMSON" ln_colorIndex = 7 ' малиновый Case Else ln_colorIndex = -4142 ' нет цвета End Select Select Case pc_ForeColor Case "BLACK" ln_color = 1 Case "WHITE" ln_color = 2 Case "RED" ln_color = 3 Case "YELLOW" ln_color = 6 Case "GREEN" ln_color = 4 Case "DARKBLUE" ln_color = 5 Case "BLUE" ln_color = 8 Case "GREY" ln_color = 15 Case "CRIMSON" ln_color = 7 Case Else ln_color = -4142 End Select 'On Error GoTo err1 With ExcelApp.Worksheets(pu_Sheet) ln_NumColStart = IIf(pn_ApplayColStart < 1, 1, pn_ApplayColStart) ln_NumColEnd = .Cells.SpecialCells(11).Column If pn_ApplayColEnd > 0 Then ln_NumColEnd = IIf(pn_ApplayColEnd < ln_NumColEnd, pn_ApplayColEnd, ln_NumColEnd) If ln_NumColEnd < ln_NumColStart Then ln_NumColStart = ln_NumColEnd ln_rowStart = IIf(pn_RowStart < 1, 1, pn_RowStart) ln_rowEnd = .Cells.SpecialCells(11).Row If pn_RowEnd > 0 Then ln_rowEnd = IIf(pn_RowEnd < ln_rowEnd, pn_RowEnd, ln_rowEnd) If ln_rowEnd < ln_rowStart Then ln_rowStart = ln_rowEnd ln_ColSeek = IIf(pn_InColSeek < 1, 1, pn_InColSeek) For Each cl In .Range(.Cells(ln_rowStart, ln_ColSeek), .Cells(ln_rowEnd, ln_ColSeek)) If VarType(pu_SeekValue) = vbString Then If pl_SlowSeek Then ll_okSeek = InStr(1, UCase(cl.Value), pu_SeekValue) > 1 Else ll_okSeek = Trim(UCase(cl.Value)) = pu_SeekValue End If Else ll_okSeek = cl.Value = pu_SeekValue End If If ll_okSeek Then If pn_Fontbold > -1 Then .Range(.Cells(cl.Row, ln_NumColStart), .Cells(cl.Row, ln_NumColEnd)).Font.Bold = pn_Fontbold = 1 If pn_FontSize > 5 And pn_FontSize < 51 Then .Range(.Cells(cl.Row, ln_NumColStart), .Cells(cl.Row, ln_NumColEnd)).Font.Size = pn_FontSize If Not pc_ForeColor = "" Then .Range(.Cells(cl.Row, ln_NumColStart), .Cells(cl.Row, ln_NumColEnd)).Font.colorIndex = ln_color If Not pc_BackColor = "" Then .Range(.Cells(cl.Row, ln_NumColStart), .Cells(cl.Row, ln_NumColEnd)).interior.colorIndex = ln_colorIndex If Not IsMissing(pu_NewValue) Then For iiX = ln_NumColStart To ln_NumColEnd .Cells(cl.Row, iiX).Value = pu_NewValue Next End If End If Next End With
err1: End Sub Public Function ExcelCheckExistSheet(ByVal pu_Sheet As Variant) As Boolean ' Возвращает True, если лист с указанным номером или именем существует
Dim lnCnt As Integer, iiX As Integer, ll_ExistSheet As Boolean
If ExcelCheckApp(False) = False Then ExcelCheckExistSheet = False Exit Function End If On Error GoTo err1 With ExcelApp lnCnt = .Worksheets.Count If VarType(pu_Sheet) = vbString Then pu_Sheet = Trim(pu_Sheet) For iiX = 1 To lnCnt If UCase(.Worksheets(iiX).Name) = UCase(pu_Sheet) Then ll_ExistSheet = True Exit For End If Next ExcelCheckExistSheet = ll_ExistSheet Exit Function End If If VarType(pu_Sheet) = vbInteger Then If pu_Sheet < 1 Then ExcelCheckExistSheet = False MsgBox "Значение передаваемого параметра pu_Sheet должно быть > 0", vbCritical + vbOKOnly, " " Exit Function End If ExcelCheckExistSheet = pu_Sheet <= lnCnt Else ExcelCheckExistSheet = False MsgBox "Тип передаваемого параметра pu_Sheet должен быть vbString или vbInteger", vbCritical + vbOKOnly, " " Exit Function End If End With Exit Function
err1: ExcelCheckExistSheet = False End Function Public Function ExcelCheckApp(Optional pl_CreateExcelObject As Boolean = False) As Boolean ' Возвращает True, если глобальная объектная переменная ExcelApp успешно связана с MS-Excel
On Error GoTo err1 If ExcelApp Is Nothing And pl_CreateExcelObject Then Set ExcelApp = CreateObject("Excel.Application") End If On Error GoTo errSet ' на тот случай если Excel был вручную вырублен через Диспетчер задач ExcelApp.DisplayAlerts = False NextSt: ExcelCheckApp = True Exit Function
err1: ExcelCheckApp = False MsgBox "Ошибка при запуске MS-Excel !", vbCritical + vbOKOnly, " " Exit Function
errSet: If pl_CreateExcelObject Then On Error GoTo err1 Set ExcelApp = CreateObject("Excel.Application") GoTo NextSt Else ExcelCheckApp = False End If End Function ' Примеры вызовы ' ? ExcelOpen("C:Premia.xls",True, True ) ' ? ExcelCheckApp(False) ' ? ExcelCheckExistSheet(2) ' ? ExcelRowColCount("COLUMN", "ЛисТ2") ' call ExcelChangeCells("МосквА", 1, False, 3, 1,,,,1,"RED","YELLOW",9)