Я ознакомился с интересными примерами кода, найденными по следующим URL-адресам https://www.rondebruin.nl/win/s9/win002.htm
http://www.cpearson.com/excel/vbe.aspx
Я до сих пор адаптировал код для экспорта / импорта модулей под свои нужды.не могу понять, как можно импортировать файл исходного кода листа, чтобы добавить его в новую книгу в виде кода листа.Я могу легко проверить тип VBcomponent при сохранении компонента для создания файла исходного кода листа, но метод import VBcomponent неправильно создаст новый модуль класса после прочтения созданного файла no.независимо от того, какое расширение файла я использую.Та же проблема возникает с файлом исходного кода ThisWorkbook .Тип компонента и расширение файла получаются из этого фрагмента кода
Public Function VBE_GetFileExtension(VBComp As VBIDE.VBComponent) As String
Select Case VBComp.Type
Case vbext_ct_ClassModule
VBE_GetFileExtension = ".cls"
Case vbext_ct_Document
VBE_GetFileExtension = ".xcls"
Case vbext_ct_MSForm
VBE_GetFileExtension = ".frm"
Case vbext_ct_StdModule
VBE_GetFileExtension = ".bas"
Case Else
VBE_GetFileExtension = ".bas"
End Select
End Function
Я знаю, что можно редактировать исходный код листа и рабочей книги, используя VBA, но, боюсь, это будет не очень эффективно.
Здесь полный код экспорта
Public Sub VBE_ExportCodeSource()
If (Not IsEditorInSync()) Then Call SyncVBAEditor
On Error GoTo ErrorHandler
Dim sFolderName As String
sFolderName = ThisWorkbook.Path & "\" & ThisWorkbook.Name & ".SrcCodeExport"
'create folder where to save source code files
Dim bOk As Boolean
bOk = Z_bIOCreateFolder(sFolderName)
'create sub folder where to save modules based on the type
Dim bOk As Boolean
bOk = Z_bIOCreateFolder(sFolderName)
Dim sSubFolderName As String
sSubFolderName = sFolderName & "\" & "Microsoft Excel Objects"
bOk = Z_bIOCreateFolder(sSubFolderName)
If (Not bOk) Then GoTo ErrorHandler
sSubFolderName = sFolderName & "\" & "Forms"
bOk = Z_bIOCreateFolder(sSubFolderName)
If (Not bOk) Then GoTo ErrorHandler
sSubFolderName = sFolderName & "\" & "Modules"
bOk = Z_bIOCreateFolder(sSubFolderName)
If (Not bOk) Then GoTo ErrorHandler
sSubFolderName = sFolderName & "\" & "Class Modules"
bOk = Z_bIOCreateFolder(sSubFolderName)
If (Not bOk) Then GoTo ErrorHandler
sSubFolderName = sFolderName & "\" & "Active X"
bOk = Z_bIOCreateFolder(sSubFolderName)
If (Not bOk) Then GoTo ErrorHandler
Dim VBAEditor As VBIDE.VBE
Set VBAEditor = Application.VBE
Dim VBProj As VBIDE.VBProject
Set VBProj = VBAEditor.ActiveVBProject
Dim VBComp As VBIDE.VBComponent
For Each VBComp In VBProj.VBComponents
If (Not VBComp Is Nothing) Then
bOk = VBE_ExportVBComponent(VBComp, sFolderName)
End If
Next VBComp
Exit Sub
ErrorHandler:
MsgBox _
Prompt:="Error while exporting source code", _
Buttons:=vbExclamation
End Sub
Public Function VBE_ExportVBComponent( _
ByVal VBComp As VBIDE.VBComponent, _
ByVal sFolderName As String, _
Optional OverwriteExisting As Boolean = True) As Boolean
'
VBE_ExportVBComponent = False 'default
sFolderName = VBE_GetFileSubFolder(sFolderName, VBComp)
Dim sFileExtension As String
' based on module type get the file extension string
sFileExtension = VBE_GetFileExtension(VBComp:=VBComp)
Dim sFileName As String
sFileName = VBComp.Name & sFileExtension
' add path checking for \ at the end of sFolderName
If StrComp(Right(sFolderName, 1), "\", vbBinaryCompare) = 0 Then
sFileName = sFolderName & sFileName
Else
sFileName = sFolderName & "\" & sFileName
End If
Dim sFullPathName As String
sFullPathName = Dir(sFileName, vbNormal + vbHidden + vbSystem)
'Debug.Print "exporting " & VBComp.Name & " to " & sFileName
If sFullPathName <> vbNullString Then
If OverwriteExisting Then
Kill sFileName
Else
Exit Function
End If
End If
VBComp.Export Filename:=sFileName
VBE_ExportVBComponent = True
End Function
Здесь полный код для импорта
''
' sFolderName is the full path to a folder which contains subfolders, one for each module type
' sWkbTargetName is the workbook name created to 'host' the imported modules
Public Sub VBE_ImportModules( _
ByVal sFolderName As String, _
ByVal sWkbTargetName As String)
'
Dim wkbTarget As Excel.Workbook
Dim bW As Boolean
bW = (StrComp(sWkbTargetName, ThisWorkbook.Name) <> 0)
'Get the path to the folder with modules
Dim bP As Boolean
bP = Z_bIOExistFolder(sFolderName)
If (bW And bP) Then
On Error Resume Next
Set wkbTarget = Application.Workbooks(sWkbTargetName)
If (wkbTarget Is Nothing) Then
Set wkbTarget = Application.Workbooks.Add(sWkbTargetName)
End If
If (Not wkbTarget Is Nothing) Then
If (wkbTarget.VBProject.Protection <> 1) Then
''' NOTE: sFolderName where the code modules are located.
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim sSubFolderName As String, asSubFolderName(1 To 5) As String
asSubFolderName(1) = sFolderName & "\" & "Microsoft Excel Objects" & "\"
asSubFolderName(2) = sFolderName & "\" & "Forms" & "\"
asSubFolderName(3) = sFolderName & "\" & "Modules" & "\"
asSubFolderName(4) = sFolderName & "\" & "Class Modules" & "\"
asSubFolderName(5) = sFolderName & "\" & "Active X" & "\"
Dim i As Integer
For i = LBound(asSubFolderName) To UBound(asSubFolderName)
sSubFolderName = asSubFolderName(i)
If (objFSO.GetFolder(sSubFolderName).Files.Count > 0) Then
'Here we should/could Delete all modules in the target workbook
Dim VBComp As VBIDE.VBComponents
Set VBComp = wkbTarget.VBProject.VBComponents
''' Import all the code modules in the specified path
''' to the ActiveWorkbook.
Dim objFile As Object
'objFile = CreateObject("Scripting.File")
For Each objFile In objFSO.GetFolder(sSubFolderName).Files
If (objFSO.GetExtensionName(objFile.Name) = "cls") Or _
(objFSO.GetExtensionName(objFile.Name) = "xcls") Or _
(objFSO.GetExtensionName(objFile.Name) = "frm") Or _
(objFSO.GetExtensionName(objFile.Name) = "bas") _
Then
'Debug.Print "Importing a new component from : " & objFile.Path
VBComp.Import objFile.Path
End If
Next objFile
Debug.Print "Files from '" & sSubFolderName & "' imported"
Else
Debug.Print _
"There are no files to import, " & _
"in import Folder '" & sSubFolderName & "'"
End If
Next i
Else
Debug.Print _
"The VBA in this workbook is protected, " & _
"not possible to Import the code"
End If
Else
Debug.Print "Cannot open workbook '" & sWkbTargetName & "'"
End If
Else
If (Not bW) Then _
Debug.Print _
"Select another target workbook, " & _
"Not possible to import code in this workbook "
If (Not bP) Then _
Debug.Print "Import Folder '" & sFolderName & "' does not exist"
End If
End Sub
Public Function VBE_GetFileExtension(VBComp As VBIDE.VBComponent) As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This returns the appropriate file extension based on the Type of
' the VBComponent.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Select Case VBComp.Type
Case vbext_ct_ClassModule
VBE_GetFileExtension = ".cls"
Case vbext_ct_Document
VBE_GetFileExtension = ".xcls"
Case vbext_ct_MSForm
VBE_GetFileExtension = ".frm"
Case vbext_ct_StdModule
VBE_GetFileExtension = ".bas"
Case Else
VBE_GetFileExtension = ".bas"
End Select
End Function
некоторый код для работы с папками
''
' Z_bIOCreateFolder
Private Function Z_bIOCreateFolder(ByVal sFolderPath As String) As Boolean
Z_bIOCreateFolder = False ' default
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not Z_bIOExistFolder(sFolderPath) Then
On Error GoTo IOCreateFolderErrorTrap
objFSO.CreateFolder sFolderPath ' could there be any error with this, like if the path is really screwed up?
Z_bIOCreateFolder = True
End If
Exit Function
IOCreateFolderErrorTrap:
Call MsgBox("A folder could not be created for the following path: " & sFolderPath & ". Check the path name and try again.")
End Function
''
' Z_bIOExistFolder
Private Function Z_bIOExistFolder(ByVal sFolderPath As String) As Boolean
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error GoTo IOExistFolderErrorTrap
Z_bIOExistFolder = objFSO.FolderExists(sFolderPath)
Exit Function
IOExistFolderErrorTrap:
Call MsgBox("objFSO failed checking: " & sFolderPath)
End Function
результат, как показано на рисунке ниже (Feuil * создаются из кода листа).
