MyTetra Share
Делитесь знаниями!
Выгрузка списка макросов (или всего кода целиком) из проекта VBA в текстовый файл
Время создания: 16.03.2019 23:43
Текстовые метки: Объектная модель, VBOM
Раздел: !Закладки - VBA - VBA управление кодами
Запись: xintrea/mytetra_db_adgaver_new/master/base/1514733512em18hvv20p/text.html на raw.githubusercontent.com

Выгрузка списка макросов (или всего кода целиком) из проекта VBA в текстовый файл

Sub print_all_sub_and_function_names_of_current_project()
    ' пишет названия функций программы в файл c:\output.txt
    On Error Resume Next
    sub_list = "": Set iVBComponents = ThisWorkbook.VBProject.VBComponents
    For Each iVBComponent In iVBComponents
        Select Case iVBComponent.Type
            Case 1 To 100:
                With iVBComponent.CodeModule
                    sub_list = sub_list & "==============" & vbNewLine & .Name & vbNewLine & "==============" & vbNewLine
                    For i = 1 To .CountOfLines
                        If InStr(1, .Lines(i, 1), "Sub ") And InStr(1, .Lines(i, 1), "Exit ") = 0 And _
                           (InStr(1, .Lines(i, 1), "End Sub") > 15 Or InStr(1, .Lines(i, 1), "End Sub") = 0) Then
                            sub_list = sub_list & .Lines(i, 1) & vbNewLine
                        End If
                        If InStr(1, .Lines(i, 1), "Function ") And InStr(1, .Lines(i, 1), "Exit ") = 0 And _
                           (InStr(1, .Lines(i, 1), "End Function") > 15 Or InStr(1, .Lines(i, 1), "End Function") = 0) Then
                            sub_list = sub_list & .Lines(i, 1) & vbNewLine
                        End If
                    Next
                End With
        End Select
    Next
    Dim FSO As FileSystemObject, ts As TextStream, fil As File
    Set FSO = CreateObject("scripting.filesystemobject")
    If FSO.FileExists("c:\output.txt") Then Kill "c:\output.txt"
 
    Set ts = FSO.OpenTextFile("c:\output.txt", 8, True)
    ts.Write sub_list: ts.Close: Set ts = Nothing: Set FSO = Nothing
End Sub

Пример того, что записывается в файл "c:\output.txt"

==============
Trace_Open_Save
==============
Sub test988d()
Function Get_InitialFileName_for_Trace() As String
Function SaveTrace(ByVal Filename As String, ByRef Tr As Trace) As Boolean
Sub test_LoadTrace(): Dim Tr As Trace: Set Tr = LoadTrace: Tr.Existed = True: Tr.Show: End Sub
Function LoadTrace(Optional ByVal Filename As String = "") As Trace
==============
Link
==============
Function ConvertHPPs(ByRef node As TraceNode, HPPind As Integer) As String
Function GetLinkInfo() As String
Sub Apply()
Private Sub Class_Initialize()
Sub MoveLink(ByRef WSource As Warrant, ByRef WDestination As Warrant)
Sub DeleteLink(ByRef WSource As Warrant)
Sub AddLink(ByRef WDestination As Warrant)
Sub Undo()

Sub print_all_code_of_current_project()
    ' пишет весь код данной программы в файл c:\code.vb
    On Error Resume Next
    sub_list = "": Set iVBComponents = ThisWorkbook.VBProject.VBComponents
    For Each iVBComponent In iVBComponents
        Select Case iVBComponent.Type
            Case 1 To 100:
                With iVBComponent.CodeModule
                    sub_list = sub_list & "==============  " & .Name & "  ==============" & vbNewLine
                    For i = 1 To .CountOfLines
                        codeline = Trim$(.Lines(i, 1))
                        If Len(codeline) > 0 Then sub_list = sub_list & codeline & vbNewLine
                    Next
                End With
        End Select
    Next
 
    Dim FSO As FileSystemObject, ts As TextStream, fil As File
    Set FSO = CreateObject("scripting.filesystemobject")
    If FSO.FileExists("c:\code.vb") Then Kill "c:\code.vb"
 
    Set ts = FSO.OpenTextFile("c:\code.vb", 8, True)
    ts.Write sub_list: ts.Close: Set ts = Nothing: Set FSO = Nothing
End Sub

Пример того, что записывается в файл "c:\code.vb"

============== Files_Control ==============
Public DectDB As New Collection
Public Enum FileIconConst
az_Cross = 1: az_Trace = 2: az_Warrant = 3: az_Distr = 4
az_Excel = 10: az_Access_Key = 50: az_Settings = 51: az_LogFile = 60
End Enum
Sub Reg_NewFileTypeEx(ByVal NewExtension As String, ByVal NewDescription As String, ByVal NewIcon As FileIconConst)
' регистрирует новый тип файла. иконка файла в соответствии с FileIconConst
Const az = "CompanyName"
SaveRegString HKEY_CLASSES_ROOT, NewExtension, "", az & NewExtension
SaveRegString HKEY_CLASSES_ROOT, az & NewExtension, "", NewDescription
SaveRegString HKEY_CLASSES_ROOT, az & NewExtension, "EditFlags", 0
Select Case NewIcon ' чтобы файлы можно было открыть EXCEL-ем без лишних вопросов о формате файла

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