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 просмотров