以编程方式从Word 2007文档中提取宏(VBA)代码

您可以将代码导出到文件,然后再将其读回.

我一直在使用下面的代码来帮助我在源代码控制下保留一些Excel宏(使用Subversion和TortoiseSVN).它基本上在我打开VBA编辑器时保存所有代码到文本文件.我把文本文件放在subversion中,这样我就可以做差异了.您应该能够适应/窃取其中一些在Word中工作.

CanAccessVBOM()中的注册表检查对应于安全设置中的"对Visual Basic项目的信任访问".

Sub ExportCode()

    If Not CanAccessVBOM Then Exit Sub ' Exit if access to VB object model is not allowed
    If (ThisWorkbook.VBProject.VBE.ActiveWindow Is Nothing) Then
        Exit Sub ' Exit if VBA window is not open
    End If
    Dim comp As VBComponent
    Dim codeFolder As String

    codeFolder = CombinePaths(GetWorkbookPath, "Code")
    On Error Resume Next
    MkDir codeFolder
    On Error GoTo 0
    Dim FileName As String

    For Each comp In ThisWorkbook.VBProject.VBComponents
        Select Case comp.Type
            Case vbext_ct_ClassModule
                FileName = CombinePaths(codeFolder, comp.Name & ".cls")
                DeleteFile FileName
                comp.Export FileName
            Case vbext_ct_StdModule
                FileName = CombinePaths(codeFolder, comp.Name & ".bas")
                DeleteFile FileName
                comp.Export FileName
            Case vbext_ct_MSForm
                FileName = CombinePaths(codeFolder, comp.Name & ".frm")
                DeleteFile FileName
                comp.Export FileName
            Case vbext_ct_Document
                FileName = CombinePaths(codeFolder, comp.Name & ".cls")
                DeleteFile FileName
                comp.Export FileName
        End Select
    Next

End Sub
Function CanAccessVBOM() As Boolean
    ' Check resgistry to see if we can access the VB object model
    Dim wsh As Object
    Dim str1 As String
    Dim AccessVBOM As Long

    Set wsh = CreateObject("WScript.Shell")
    str1 = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & _
        Application.Version & "\Excel\Security\AccessVBOM"
    On Error Resume Next
    AccessVBOM = wsh.RegRead(str1)
    Set wsh = Nothing
    CanAccessVBOM = (AccessVBOM = 1)
End Function


Sub DeleteFile(FileName As String)
    On Error Resume Next
    Kill FileName
End Sub

Function GetWorkbookPath() As String
    Dim fullName As String
    Dim wrkbookName As String
    Dim pos As Long

    wrkbookName = ThisWorkbook.Name
    fullName = ThisWorkbook.fullName

    pos = InStr(1, fullName, wrkbookName, vbTextCompare)

    GetWorkbookPath = Left$(fullName, pos - 1)
End Function

Function CombinePaths(ByVal Path1 As String, ByVal Path2 As String) As String
    If Not EndsWith(Path1, "\") Then
        Path1 = Path1 & "\"
    End If
    CombinePaths = Path1 & Path2
End Function

Function EndsWith(ByVal InString As String, ByVal TestString As String) As Boolean
    EndsWith = (Right$(InString, Len(TestString)) = TestString)
End Function

Sub GetCode()

    Dim prj As VBProject
    Dim comp As VBComponent
    Dim code As CodeModule
    Dim composedFile As String
    Dim i As Integer

    Set prj = ThisDocument.VBProject
        For Each comp In prj.VBComponents
            Set code = comp.CodeModule

            composedFile = comp.Name & vbNewLine

            For i = 1 To code.CountOfLines
                composedFile = composedFile & code.Lines(i, 1) & vbNewLine
            Next

            MsgBox composedFile
        Next

End Sub