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

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

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

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

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

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

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

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

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

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

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

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