Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- using Microsoft.Office.Interop.Word;
- using Microsoft.Vbe.Interop;
- ...
- public List<string> GetMacrosFromDoc()
- {
- Document doc = GetWordDoc(@"C:Temptest.docm");
- List<string> macros = new List<string>();
- VBProject prj;
- CodeModule code;
- string composedFile;
- prj = doc.VBProject;
- foreach (VBComponent comp in prj.VBComponents)
- {
- code = comp.CodeModule;
- // Put the name of the code module at the top
- composedFile = comp.Name + Environment.NewLine;
- // Loop through the (1-indexed) lines
- for (int i = 0; i < code.CountOfLines; i++)
- {
- composedFile += code.get_Lines(i + 1, 1) + Environment.NewLine;
- }
- // Add the macro to the list
- macros.Add(composedFile);
- }
- CloseDoc(doc);
- return macros;
- }
- 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
- 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_USERSoftwareMicrosoftOffice" & _
- Application.Version & "ExcelSecurityAccessVBOM"
- 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
Add Comment
Please, Sign In to add comment