code_junkie

Programmatically extract macro (VBA) code from Word 2007 docs

Nov 10th, 2011
132
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 3.75 KB | None | 0 0
  1. using Microsoft.Office.Interop.Word;
  2. using Microsoft.Vbe.Interop;
  3.  
  4. ...
  5.  
  6. public List<string> GetMacrosFromDoc()
  7. {
  8. Document doc = GetWordDoc(@"C:Temptest.docm");
  9.  
  10. List<string> macros = new List<string>();
  11.  
  12. VBProject prj;
  13. CodeModule code;
  14. string composedFile;
  15.  
  16. prj = doc.VBProject;
  17. foreach (VBComponent comp in prj.VBComponents)
  18. {
  19. code = comp.CodeModule;
  20.  
  21. // Put the name of the code module at the top
  22. composedFile = comp.Name + Environment.NewLine;
  23.  
  24. // Loop through the (1-indexed) lines
  25. for (int i = 0; i < code.CountOfLines; i++)
  26. {
  27. composedFile += code.get_Lines(i + 1, 1) + Environment.NewLine;
  28. }
  29.  
  30. // Add the macro to the list
  31. macros.Add(composedFile);
  32. }
  33.  
  34. CloseDoc(doc);
  35.  
  36. return macros;
  37. }
  38.  
  39. Sub GetCode()
  40.  
  41. Dim prj As VBProject
  42. Dim comp As VBComponent
  43. Dim code As CodeModule
  44. Dim composedFile As String
  45. Dim i As Integer
  46.  
  47. Set prj = ThisDocument.VBProject
  48. For Each comp In prj.VBComponents
  49. Set code = comp.CodeModule
  50.  
  51. composedFile = comp.Name & vbNewLine
  52.  
  53. For i = 1 To code.CountOfLines
  54. composedFile = composedFile & code.Lines(i, 1) & vbNewLine
  55. Next
  56.  
  57. MsgBox composedFile
  58. Next
  59.  
  60. End Sub
  61.  
  62. Sub ExportCode()
  63.  
  64. If Not CanAccessVBOM Then Exit Sub ' Exit if access to VB object model is not allowed
  65. If (ThisWorkbook.VBProject.VBE.ActiveWindow Is Nothing) Then
  66. Exit Sub ' Exit if VBA window is not open
  67. End If
  68. Dim comp As VBComponent
  69. Dim codeFolder As String
  70.  
  71. codeFolder = CombinePaths(GetWorkbookPath, "Code")
  72. On Error Resume Next
  73. MkDir codeFolder
  74. On Error GoTo 0
  75. Dim FileName As String
  76.  
  77. For Each comp In ThisWorkbook.VBProject.VBComponents
  78. Select Case comp.Type
  79. Case vbext_ct_ClassModule
  80. FileName = CombinePaths(codeFolder, comp.Name & ".cls")
  81. DeleteFile FileName
  82. comp.Export FileName
  83. Case vbext_ct_StdModule
  84. FileName = CombinePaths(codeFolder, comp.Name & ".bas")
  85. DeleteFile FileName
  86. comp.Export FileName
  87. Case vbext_ct_MSForm
  88. FileName = CombinePaths(codeFolder, comp.Name & ".frm")
  89. DeleteFile FileName
  90. comp.Export FileName
  91. Case vbext_ct_Document
  92. FileName = CombinePaths(codeFolder, comp.Name & ".cls")
  93. DeleteFile FileName
  94. comp.Export FileName
  95. End Select
  96. Next
  97.  
  98. End Sub
  99. Function CanAccessVBOM() As Boolean
  100. ' Check resgistry to see if we can access the VB object model
  101. Dim wsh As Object
  102. Dim str1 As String
  103. Dim AccessVBOM As Long
  104.  
  105. Set wsh = CreateObject("WScript.Shell")
  106. str1 = "HKEY_CURRENT_USERSoftwareMicrosoftOffice" & _
  107. Application.Version & "ExcelSecurityAccessVBOM"
  108. On Error Resume Next
  109. AccessVBOM = wsh.RegRead(str1)
  110. Set wsh = Nothing
  111. CanAccessVBOM = (AccessVBOM = 1)
  112. End Function
  113.  
  114.  
  115. Sub DeleteFile(FileName As String)
  116. On Error Resume Next
  117. Kill FileName
  118. End Sub
  119.  
  120. Function GetWorkbookPath() As String
  121. Dim fullName As String
  122. Dim wrkbookName As String
  123. Dim pos As Long
  124.  
  125. wrkbookName = ThisWorkbook.Name
  126. fullName = ThisWorkbook.fullName
  127.  
  128. pos = InStr(1, fullName, wrkbookName, vbTextCompare)
  129.  
  130. GetWorkbookPath = Left$(fullName, pos - 1)
  131. End Function
  132.  
  133. Function CombinePaths(ByVal Path1 As String, ByVal Path2 As String) As String
  134. If Not EndsWith(Path1, "") Then
  135. Path1 = Path1 & ""
  136. End If
  137. CombinePaths = Path1 & Path2
  138. End Function
  139.  
  140. Function EndsWith(ByVal InString As String, ByVal TestString As String) As Boolean
  141. EndsWith = (Right$(InString, Len(TestString)) = TestString)
  142. End Function
Add Comment
Please, Sign In to add comment