MyTetra Share
Делитесь знаниями!
Как добавить код процедуры программно, скопировать модуль
16.03.2019
23:43
Раздел: !Закладки - VBA - VBA управление кодами

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

Бывают ситуации, когда кодом создается книга, в нее опять же кодом заносятся данные. И порой необходимо помимо всего прочего добавить в новую книгу и код 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


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 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")


1

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")


1

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



'---------------------------------------------------------------------------------------

' 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


Sub CopyComponent()

    Workbooks.Add

    If CopyVBComponent("ЭтаКнига", ThisWorkbook, ActiveWorkbook, True) Then

        MsgBox "Указанный компонент успешно скопирован в новую книгу", vbInformation

    Else

        MsgBox "Компонент не был скопирован", vbInformation

    End If

End Sub

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

Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования