Класс Functions Здесь расположены универсальные функции которые не отн

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
'Класс Functions. Здесь расположены универсальные функции, которые не относятся к заданию
Option Explicit
'функция считает количество строк в таблице
Public Function countRows(ByVal ws As Worksheet) As Integer
Dim count As Integer
count = 0
Do While Trim(ws.Cells(count + 1, 1).Value) <> ""
count = count + 1
Loop
countRows = count
End Function
'функция считает количество колонок в таблице
Public Function countColumns(ByVal ws As Worksheet) As Integer
countColumns = ws.Cells.SpecialCells(xlLastCell).Column
End Function
'фукнция выполняет подгон ширины колонок под размер контента в них
Public Function wsAutoFit(ByRef ws As Worksheet)
ws.UsedRange.Columns.AutoFit
End Function
'функция проверяет наличие листа в заданой книге
Public Function shExist(ByRef sName As String, Optional ByVal wb As Workbook = Nothing) As Boolean
If (wb Is Nothing) Then Set wb = ThisWorkbook
Dim wsSh As Worksheet
On Error Resume Next
Set wsSh = wb.Sheets(sName)
shExist = Not wsSh Is Nothing
End Function
'функция создает новый лист с заданным названием для заданной книги
Public Function createNewWs(ByVal name As String, Optional ByVal wb As Workbook = Nothing) As Worksheet
If (wb Is Nothing) Then Set wb = ThisWorkbook
Set createNewWs = wb.Sheets.Add(, wb.Sheets(wb.Sheets.count))
createNewWs.name = name
End Function
'функция создает новый лист с заданным названием для заданной книги, при этом удаляет уже существующий лист
Public Function createWsWithCheck(ByVal name As String, Optional ByVal wb As Workbook = Nothing) As Worksheet
If (wb Is Nothing) Then Set wb = ThisWorkbook
If shExist(name, wb) Then
deleteSheetWithoutAsking name
End If
Set createWsWithCheck = wb.Sheets.Add(, wb.Sheets(wb.Sheets.count))
createWsWithCheck.name = name
End Function
'проверяет, открыта ли книга с заданным названием
Public Function wbIsOpen(ByRef name As String) As Boolean
On Error Resume Next
Dim wb As Workbook
Set wb = Workbooks(name)
wbIsOpen = Not wb Is Nothing
End Function
'удаление объекта без оповещения для пользователя
Public Sub deleteWithoutAsking(ByRef obj As Variant)
Dim b As Boolean
b = Application.DisplayAlerts
Application.DisplayAlerts = False
obj.Delete
Application.DisplayAlerts = b
End Sub
'удаляет лист без оповещения пользователя
Public Sub deleteSheetWithoutAsking(ByVal name As String, Optional ByVal wb As Workbook = Nothing)
If (wb Is Nothing) Then Set wb = ThisWorkbook
Dim b As Boolean
b = Application.DisplayAlerts
Application.DisplayAlerts = False
wb.Sheets(name).Delete
Application.DisplayAlerts = b
End Sub
'функция создает новую книгу
Public Function getNewWb(Optional ByVal sheetscnt As Integer = 1) As Workbook
Dim tmpint As Integer
tmpint = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = sheetscnt
Set getNewWb = Workbooks.Add()
Application.SheetsInNewWorkbook = tmpint
End Function
'сохранить книгу с заданым именем в заданой директории
Public Function saveAs(wb As Workbook, ByVal path As String, ByVal filename As String)
wb.saveAs path & "\" & filename
End Function
'сохранить ворд файл с заданым именем в заданой директории
Public Function saveAs2(ByRef wd As Word.Document, ByVal path As String, ByVal filename As String)
wd.saveAs2 path & "\" & filename
End Function
'Создаем документ word, и вставляем полученную таблицу в этот документ. Затем сохраняем документ в указанную директорию.
Public Function printListInWord(ByRef ws As Worksheet, ByVal template_name As String, ByVal word_name)
Dim consts As Constants
Set consts = New Constants
Dim funcs As Functions
Set funcs = New Functions
Dim objWDApp As Word.Application
Dim objWDDoc As Word.Document
Dim blnQuitApp As Boolean
On Error Resume Next
Set objWDApp = GetObject(, "Word.Application")
On Error GoTo 0
If objWDApp Is Nothing Then
Set objWDApp = CreateObject("Word.Application")
blnQuitApp = True
End If
Set objWDDoc = objWDApp.Documents.Add(Template:=consts.wbDataPath() & consts.wbTemplateRelativePath() & template_name)
Dim countRows, countColumns As Integer
countRows = funcs.countRows(ws)
countColumns = funcs.countColumns(ws)
ws.Range(ws.Cells(1, 1), ws.Cells(countRows, countColumns)).Copy
With objWDDoc.Paragraphs(2).Range
.PasteExcelTable False, True, False
.Font.Size = 10
End With
funcs.saveAs2 objWDDoc, consts.wbDataPath() & consts.wbPrintRelativePath(), word_name & ".doc"
objWDDoc.Close False
End Function
'ускорить работу макроса
Sub speedUp(ByVal flag As Boolean)
Application.ScreenUpdating = Not flag 'отключает перерисовку
Application.EnableEvents = Not flag 'отключает любые события у книги (щелчки мышкой, нажатия на клавиатуру)
ActiveSheet.DisplayPageBreaks = Not flag 'отключает разбиение страниц
Application.DisplayStatusBar = Not flag 'отключает статус панель
Application.DisplayAlerts = Not flag 'отключает все диалоговые окна
If flag Then
Application.Calculation = xlCalculationManual 'отключает вычисления в ячейках
Else
Application.Calculation = xlCalculationAutomatic
End If
End Sub