Как добавить код процедуры программно, скопировать модуль

Бывают ситуации, когда кодом создается книга, в нее опять же кодом заносятся данные. И порой необходимо помимо всего прочего добавить в новую книгу и код VBA. Естественно, тоже программно. На самом деле это совсем не сложно.

Для изменения кодов программно необходимо, чтобы было проставлено доверие к объектной модели проекта VBA и изменяемый проект не должен быть защищен. Подробнее читайте в статье: Что необходимо для внесения изменений в проект VBA(макросы) программно
Без этого будет невозможно программное вмешательство в проект VBA.

В данной статье я покажу как программно выполнить следующее:

• Как копировать модуль из одной книги в другую;
• Как создать новый модуль;
• Как создать событийную процедуру (изменение данных на листе, открытие книги и т.п.).

Так же приведена функция, которая копирует указанный модуль из одной книги в другую.

1. Экспорт имеющегося модуля(с процедурами) из книги с кодом в новую книгу. Чаще всего применяется когда кодов для записи в новую книгу довольно много и создавать их все, прописывая в коде, весьма неудобно и громоздко;
2. Создание нового модуля и запись необходимых кодов в него. Применяется, если необходимо создать относительно короткие процедуры в модуле.

 
1. ЭКСПОРТ ИМЕЮЩЕГОСЯ МОДУЛЯ

Sub Copy_Module() Dim objVBProjFrom As Object, objVBProjTo As Object, objVBComp As Object Dim sModuleName As String, sFullName As String 'расширение стандартного модуля Const sExt As String = ".bas" 'имя модуля для копирования sModuleName = "Module1" On Error Resume Next 'проект книги, из которой копируем модуль Set objVBProjFrom = ThisWorkbook.VBProject 'необходимый компонент Set objVBComp = objVBProjFrom.VBComponents(sModuleName) 'если указанного модуля не существует If objVBComp Is Nothing Then MsgBox "Модуль с именем '" & sModuleName & "' отсутствует в книге.", vbCritical, "Error" Exit Sub End If 'проект книги для добавления модуля Set objVBProjTo = ActiveWorkbook.VBProject 'полный путь для экспорта/импорта модуля. К папке должен быть доступ на запись/чтение sFullName = "C:\" & sModuleName & sExt objVBComp.Export Filename:=sFullName objVBProjTo.VBComponents.Import Filename:=sFullName 'удаляем временный файл для импорта Kill sFullName End Sub

Хочу добавить, что подобным образом можно копировать любой модуль. В конце статьи я приведу код функции, которая позволяет копировать любой компонент VBA из одной книги в другую.

 
2. СОЗДАНИЕ НОВОГО МОДУЛЯ

Sub Create_NewModule() Dim objVBProj As Object, objVBComp As Object, objCodeMod As Object Dim sModuleName As String, sFullName As String Dim sProcLines As String Dim lLineNum As Long 'добавляем новый стандартный модуль в активную книгу Set objVBComp = ActiveWorkbook.VBProject.VBComponents.Add(1) 'получаем ссылку на коды модуля Set objCodeMod = objVBComp.CodeModule 'узнаем количество строк в модуле '(т.к. VBA в зависимости от настроек может добавлять строки деклараций) lLineNum = objCodeMod.CountOfLines + 1 'текст всставляемой процедуры sProcLines = "Sub Test()" & vbCrLf & _ " MsgBox ""Hello, World""" & vbCrLf & _ "End Sub" 'вставляем текст процедуры в тело нового модуля objCodeMod.InsertLines lLineNum, sProcLines End Sub

Данная процедура добавит в активную книгу новый модуль и запишет в него процедуру:

Sub Test() MsgBox "Hello, World" End Sub

Sub Test()

    MsgBox "Hello, World"

End Sub

 
 
CОЗДАНИЕ СОБЫТИЙНЫХ ПРОЦЕДУР
Помимо стандартных процедур, имеется возможность добавить и событийные(изменения на листе, открытие книги и т.п.). Я приведу примеры создания кода:

• в Лист1 на изменении данных ячейки в новой книге
• в ЭтаКнига(ThisWorkbook) на событие открытия книги.

На их основе уже можно будет понять как создать другие событийные процедуры.
 
CОЗДАНИЕ СОБЫТИЙНОЙ ПРОЦЕДУРЫ Worksheet_Change в Лист1

Sub CreateEventProcedure_WorkSheetChange() Dim objVBProj As Object, objVBComp As Object, objCodeMod As Object Dim lLineNum As Long 'добавляем новую книгу Workbooks.Add 'получаем ссылку на проект и модуль листа Set objVBProj = ActiveWorkbook.VBProject Set objVBComp = objVBProj.VBComponents("Лист1") Set objCodeMod = objVBComp.CodeModule 'вставляем код With objCodeMod lLineNum = .CreateEventProc("Change", "Worksheet") lLineNum = lLineNum + 1 .InsertLines lLineNum, " MsgBox ""Hello World""" End With End Sub

Sub CreateEventProcedure_WorkSheetChange()

    Dim objVBProj As Object, objVBComp As Object, objCodeMod As Object

    Dim lLineNum As Long

    'добавляем новую книгу

    Workbooks.Add

    'получаем ссылку на проект и модуль листа

    Set objVBProj = ActiveWorkbook.VBProject

    Set objVBComp = objVBProj.VBComponents("Лист1")

    Set objCodeMod = objVBComp.CodeModule

    'вставляем код

    With objCodeMod

        lLineNum = .CreateEventProc("Change", "Worksheet")

        lLineNum = lLineNum + 1

        .InsertLines lLineNum, "    MsgBox ""Hello World"""

    End With

End Sub

Важно: для русской версии используется ссылка на Лист1. Для английской как правило Sheet1

Set objVBComp = objVBProj.VBComponents("Sheet1")

 
 
CОЗДАНИЕ СОБЫТИЙНОЙ ПРОЦЕДУРЫ Workbook_Open

Sub CreateEventProcedure() Dim objVBProj As Object, objVBComp As Object, objCodeMod As Object Dim lLineNum As Long 'добавляем новую книгу Workbooks.Add 'получаем ссылку на проект и модуль книги Set objVBProj = ActiveWorkbook.VBProject Set objVBComp = objVBProj.VBComponents("ЭтаКнига") Set objCodeMod = objVBComp.CodeModule 'вставляем код With objCodeMod lLineNum = .CreateEventProc("Open", "Workbook") lLineNum = lLineNum + 1 .InsertLines lLineNum, " MsgBox ""Hello World""" End With End Sub

Sub CreateEventProcedure()

    Dim objVBProj As Object, objVBComp As Object, objCodeMod As Object

    Dim lLineNum As Long

    'добавляем новую книгу

    Workbooks.Add

    'получаем ссылку на проект и модуль книги

    Set objVBProj = ActiveWorkbook.VBProject

    Set objVBComp = objVBProj.VBComponents("ЭтаКнига")

    Set objCodeMod = objVBComp.CodeModule

    'вставляем код

    With objCodeMod

        lLineNum = .CreateEventProc("Open", "Workbook")

        lLineNum = lLineNum + 1

        .InsertLines lLineNum, "    MsgBox ""Hello World"""

    End With

End Sub

Важно: для русской версии используется ссылка на ЭтаКнига. Для английской ThisWorkbook

Set objVBComp = objVBProj.VBComponents("ThisWorkbook")

'--------------------------------------------------------------------------------------- ' Procedure : CopyVBComponent ' DateTime : 02.08.2013 23:10 ' Author : The_Prist(Щербаков Дмитрий) ' http://www.excel-vba.ru ' Purpose : Функция копирует компонент из одной книги в другую. ' Возвращает True, если копирование прошло удачно ' False - если компонент не удалось скопировать ' ' wbFromFrom Книга, компонент из VBA-проекта которой необходимо копировать ' ' wbFromTo Книга, в VBA-проект которой необходимо копировать компонент ' ' sModuleName Имя модуля, который необходимо копировать. ' ' bOverwriteExistModule Если True или 1, то при наличии в конечной книге ' компонента с именем sModuleName - он будет удален, ' а вместо него импортирован копируемый. ' Если False, то при наличии в конечной книге ' компонента с именем sModuleName функция вернет False, ' а сам компонент не будет скопирован. '--------------------------------------------------------------------------------------- ' Function CopyVBComponent(sModuleName As String, _ wbFromFrom As Workbook, wbFromTo As Workbook, _ bOverwriteExistModule As Boolean) As Boolean Dim objVBProjFrom As Object, objVBProjTo As Object Dim objVBComp As Object, objTmpVBComp As Object Dim sTmpFolderPath As String, sVBCompName As String, sModuleCode As String Dim lSlashPos As Long, lExtPos As Long 'Проверяем корректность указанных параметров On Error Resume Next Set objVBProjFrom = wbFromFrom.VBProject Set objVBProjTo = wbFromTo.VBProject If objVBProjFrom Is Nothing Then CopyVBComponent = False: Exit Function End If If objVBProjTo Is Nothing Then CopyVBComponent = False: Exit Function End If If Trim(sModuleName) = "" Then CopyVBComponent = False: Exit Function End If If objVBProjFrom.Protection = 1 Then CopyVBComponent = False: Exit Function End If If objVBProjTo.Protection = 1 Then CopyVBComponent = False: Exit Function End If Set objVBComp = objVBProjFrom.VBComponents(sModuleName) If objVBComp Is Nothing Then CopyVBComponent = False: Exit Function End If '==================================================== 'полный путь для экспорта/импорта модуля. К папке должен быть доступ на запись/чтение sTmpFolderPath = Environ("Temp") & "\" & sModuleName & ".bas" '" If bOverwriteExistModule = True Then ' Если bOverwriteExistModule = True ' удаляем из временной папки и из конечного проекта ' модуль с указанным именем If Dir(sTmpFolderPath, 6) <> "" Then Err.Clear Kill sTmpFolderPath If Err.Number <> 0 Then CopyVBComponent = False: Exit Function End If End If With objVBProjTo.VBComponents .Remove .Item(sModuleName) End With Else Err.Clear Set objVBComp = objVBProjTo.VBComponents(sModuleName) If Err.Number <> 0 Then 'Err.Number 9 - отсутствие указанного компонента, что нам не мешает. 'Если ошибка другая - выход из функции If Err.Number <> 9 Then CopyVBComponent = False: Exit Function End If End If End If '==================================================== 'Экспорт/Импорт компонента во временную директорию objVBProjFrom.VBComponents(sModuleName).Export sTmpFolderPath 'Получаем имя компонента из экспортированного файла lSlashPos = InStrRev(sTmpFolderPath, "\") lExtPos = InStrRev(sTmpFolderPath, ".") sVBCompName = Mid(sTmpFolderPath, lSlashPos + 1, lExtPos - lSlashPos - 1) '==================================================== 'копируем Set objVBComp = Nothing Set objVBComp = objVBProjTo.VBComponents(sVBCompName) If objVBComp Is Nothing Then objVBProjTo.VBComponents.Import sTmpFolderPath Else 'Если компонент - модуль листа или книги - 'его нельзя удалить. Поэтому удаляем из него весь код 'и добавляем код из копируемого компонента If objVBComp.Type = 100 Then 'создаем временный компонент Set objTmpVBComp = objVBProjTo.VBComponents.Import(sTmpFolderPath) 'копируем из него код With objVBComp.CodeModule .DeleteLines 1, .CountOfLines sModuleCode = objTmpVBComp.CodeModule.Lines(1, objTmpVBComp.CodeModule.CountOfLines) .InsertLines 1, sModuleCode End With On Error GoTo 0 'удаляем временный компонент objVBProjTo.VBComponents.Remove objTmpVBComp End If End If 'удаляем временный файл компонента Kill sTmpFolderPath CopyVBComponent = True End Function

Пример вызова функции CopyVBComponent:

Sub CopyComponent() Workbooks.Add If CopyVBComponent("ЭтаКнига", ThisWorkbook, ActiveWorkbook, True) Then MsgBox "Указанный компонент успешно скопирован в новую книгу", vbInformation Else MsgBox "Компонент не был скопирован", vbInformation End If End Sub

Думаю теперь у вас не должно возникнуть трудностей с переносом кодов из одной книги в другую.