I have VBA code that is protected and I want to distribute the file once all the code runs, however, I want to remove all the macros before I do so that the user is not prompted to "enable" macros when they open the document.
I have this code that works if the project is "unlocked" but of course it will not work if the project is not unlocked.
I want to be able to UNLOCK the project then have the code below run. Again, I know the password.
This is a unique situation in that I have quite a few pieces of code and functions that run to perform a scan of another document. I think copy the results of the scanned document that includes comments and highlighted text into the existing document that contains all the code. I then want to remove all traces of itself so that the saved document contains no VBA or Macros.
Private Sub NothingHere(objDocument As Object)
' deletes all VBProject components from objDocument
' removes the code from built-in components that can't be deleted
' use like this: RemoveAllMacros ActiveWorkbook ' in Excel
' or like this: RemoveAllMacros ActiveWorkbookDocument ' in Word
' requires a reference to the
' Microsoft Visual Basic for Applications Extensibility library
Dim i As Long, l As Long
If objDocument Is Nothing Then Exit Sub
i = 0
On Error Resume Next
i = objDocument.VBProject.VBComponents.Count
On Error GoTo 0
If i < 1 Then ' no VBComponents or protected VBProject
MsgBox "The VBProject in " & objDocument.Name & _
" is protected or has no components!", _
vbInformation, "Remove All Macros"
Exit Sub
End If
With objDocument.VBProject
For i = .VBComponents.Count To 1 Step -1
On Error Resume Next
.VBComponents.Remove .VBComponents(i)
' delete the component
On Error GoTo 0
Next i
End With
With objDocument.VBProject
For i = .VBComponents.Count To 1 Step -1
l = 1
On Error Resume Next
l = .VBComponents(i).CodeModule.CountOfLines
.VBComponents(i).CodeModule.DeleteLines 1, l
' clear lines
On Error GoTo 0
Next i
End With
End Sub
Related
I want to set up a VBA so that for any document based on a template hidden bookmarks are deleted prior to the document closing. We publish documents on our website. They are written as Word and an API converts them to html. If there are hidden bookmarks they appear as links on the website (the hidden bookmarks convert to html anchors). Currently we remove the bookmarks manual prior to the API, but this is time consuming (we publish 1000s of documents a year) and ineffective (people forget).
I found VBA to remove hidden bookmarks which works and tried to add DocumentBeforeClose as the trigger. But it doesn't work:
Private Sub DocumentBeforeClose(cancel As Boolean)
Dim nBK As Long
With ActiveDocument
For nBK = .Bookmarks.Count To 1 Step -1
If LCase(Left(.Bookmarks(nBK).Name, 3)) = "_hl" Then
.Bookmarks(nBK).Delete
End If
Next nBK
End With
ActiveDocument.Save
End Sub
I went through Visual Basic Window, Normal, Microsoft Word Objects, ThisDocument.
Nothing happens, the hidden bookmarks remain if I close and re-open the document.
I think you need to add this line :
.Bookmarks.ShowHidden = True
Like this it should work :
Private Sub DocumentBeforeClose(cancel As Boolean)
Dim nBK As Long
With ActiveDocument
.Bookmarks.ShowHidden = True
For nBK = .Bookmarks.Count To 1 Step -1
If LCase(Left(.Bookmarks(nBK).Name, 3)) = "_hl" Then
.Bookmarks(nBK).Delete
End If
Next nBK
End With
ActiveDocument.Save
End Sub
This has solved it:
Sub AutoClose()
On Error Resume Next
Dim nBK As Long
With ActiveDocument
.bookmarks.ShowHidden = True
For nBK = .bookmarks.Count To 1 Step -1
If LCase(Left(.bookmarks(nBK).Name, 3)) = "_hl" Then
.bookmarks(nBK).Delete
End If
Next nBK
End With
ActiveDocument.Save
End Sub
Only issue is that it tries to run when you open a document and puts up an error message that there is no active document. 'On error resume next' is to stop that error message
I haven't understood how to use the object structure in the VBA. I barely get by picking up pieces from stack overflow to accomplish my task. Thanks a lot for everyone who contributes here.
I need to set the header in a document from Quick Parts. I found this
Header on all pages, footer in first page only that works if the header and footer are text only.
ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range = "Header_2"
ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range.Text = "Main footer"
ActiveDocument.Sections(1).PageSetup.DifferentFirstPageHeaderFooter = True
ActiveDocument.Sections(1).Headers(wdHeaderFooterFirstPage).Range.Text = "First page header"
ActiveDocument.Sections(1).Footers(wdHeaderFooterFirstPage).Range.Text = "First page footer"
Is it possible to add to the text in quotes - sendkeys() to use the functionality of {f3} that populates the header from quick parts?
Create a range variable, set it to the particular header or footer you want, then replace Selection.Range with that variable. To set a range variable:
Dim myRange as Range
Set myRange = ActiveDocument.Sections(1).Footers(wdHeaderFooterFirstPage).Range
The macro recorder tells me:
Application.Templates( _
"C:\Users\jkorc\AppData\Roaming\Microsoft\Templates\Normal.dotm"). _
BuildingBlockEntries("I have a macro").Insert Where:=Selection.Range, _
RichText:=True
Replace Selection.Range with myRange.
If the QuickPart is AutoText in the template attached to the document, you can use:
ActiveDocument.AttachedTemplate.AutoTextEntries("I have a macro").Insert myRange
From my page on using vba to insert building blocks:
You need to, somehow, identify the building block:
Template
Gallery
Category, and
Name
Recording a macro will work, to a limited extent. Recorded macros
will not work on someone else's system even if they have the same
building blocks or even if they are a different user on the same
computer. Recorded macros will not work if the template contains more
than one building block with the same name, even if they are different
types. Note that the file that comes with Word "Built-In Building
Blocks.dotx" has many building blocks with the same names. You can use
the Building Blocks Organizer and sort by name to see if there are
multiple building blocks with the same name and in the same template.
Because of these limitations, often you will need to actually write a
macro.
However, you can try recording one. The key is to use the Building
Blocks Organizer to insert the Building Block when recording the
macro, rather than a shortcut or another gallery/menu.
Any macro, recorded or written, should be stored in the same template
that holds the building block. That way, if the macro is available,
the building block is available.
Writing a Macro
To do this, you need to know:
The name of the building block. If you have a unique name for the
building block (no other building block of the same name exists in any
building block entry location) then use Graham Mayor's macro found on
one of his sample macro pages. A variation is shown below.
The name (and location) of the template that holds the building block unless the macro is in the same template
How to insert a macro. See Installing Macros and Install/Employ VBA Procedures (Macros).
Building Block Name = "MyBB" (example in this macro, change to fit)
Situation 1 and 1a have the Building Block and the macro in the same template. This simplifies coding because a macro can always tell
the name and location of the template that holds it. That information
is required to use a macro to insert a building block.
Situation 1 - template holds both the building block and the macro
Here is the macro to insert that uniquely-named building block at the insertion point in the document:
Sub InsertMyBB()
' Will not work if there are multiple building blocks with the same name in the template! See below.
'
Const sBBName As String = "MyBB" 'use the name of your building block instead of "MyBB"
'
On Error GoTo Oops
Application.Templates.LoadBuildingBlocks ' Thank you Timothy Rylatt
Application.Templates(ThisDocument.fullname).BuildingBlockEntries(sBBName).Insert Where:=Selection.range, _
RichText:=True ' Insert MyBB Building Block
Exit Sub ' We're done here
Oops: ' Didn't work - building block not there!
MsgBox Prompt:="The Building Block " & sBBName & " cannot be found in " & _
ThisDocument.Name & ".", Title:="Didn't Work!"
On Error GoTo -1
End Sub
This and the following macro are both contained in a demonstration
template that can be downloaded from my downloads page.
Situation 1a - template holding building blocks and macro in same template - multiple building blocks with the same name
In this situation, the previous macro would confuse Word and give
unpredictable (to the user) results. In this case, the macro needs to
know both the gallery and category of the building block. The
following macro assumes that the building block is stored in the
AutoText gallery and in the General category. You can find the name of
the gallery and category using the Building Blocks Organizer. Category
names are plain text. Galleries are referenced in vba as Building
Block Types and use constants. You can find a list of the constants
for the different galleries here.
Sub InsertMyBB()
'
' Assumes that the Building Block is of the type AutoText (wdTypeAutoText) in Category "General"
' See https://msdn.microsoft.com/en-us/library/bb243303(v=office.12).aspx
'
' This is based in part upon contributions from Greg Maxey and Jay Freedman - any errors remain mine
' Written by Charles Kenyon April 2021
'
Const sBBName As String = "MyBB" 'use the name of your building block instead of "MyBB"
Const sTempName As String = ThisDocument.fullname ' puts name and full path of template in string
'
Dim oBB As BuildingBlock
'
On Error Resume Next
Application.Templates.LoadBuildingBlocks ' Thank you Timothy Rylatt
Set oBB = Application.Templates(sTempName).BuildingBlockTypes(wdTypeAutoText) _
.Categories("General").BuildingBlocks(sBBName)
If err.Number = 0 Then
oBB.Insert Selection.range, True
Else
MsgBox Prompt:="The Building Block '" & sBBName & "' cannot be found in " & _
ThisDocument.Name & ".", Title:="Didn't Work!"
End If
lbl_Exit:
On Error GoTo -1
Set oBB = Nothing
End Sub
This and the preceding macro are both contained in a demonstration
template that can be downloaded from my downloads page.
Situation 2 - template holding building block is in Word Startup Folder and named MyBBTemplate.dotx
This template, for some reason, does not hold the macro, it is in a
separate template. We know the name of the container template. The
name of the template containing the macro does not matter for our
purposes.
Sub InsertMyBB()
' Will not work if the Startup Folder is the root directory of a drive, i.e. C:\
' For use with building block stored in a template loaded in the Word Startup Folder that does NOT hold this macro
' Will not work if there are multiple building blocks with the same name in the template!
'
Const sBBName As String = "MyBB" 'use the name of your building block instead of "MyBB"
Const sTempName As String = "MyBBTemplate.dotx" 'use the name of your template instead of "MyBBTemplate.dotx"
On Error GoTo NoStartupPath
Const sStartupFolder As String = Application.Options.DefaultFilePath(wdStartupPath)
'
On Error GoTo Oops ' error handler
Application.Templates.LoadBuildingBlocks ' Thank you Timothy Rylatt
Application.Templates(sStartupPath & "\" & sTemplateName).BuildingBlockEntries(sBBName) _
.Insert Where:=Selection.range, RichText:=True ' Insert MyBB Building Block
Exit Sub ' We're done here
NoStartupPath:
On Error GoTo -1
MsgBox Prompt:="No Startup Folder Set in Options"
Exit Sub
Oops: ' Didn't work - building block not there!
MsgBox Prompt:="The Building Block " & sBBName & " cannot be found in " & _
sTemplateName & ".", Title:="Didn't Work!"
On Error GoTo -1
End Sub
Situation 3 - Insert a building block with a unique name at a bookmark, regardless of location
This macro does NOT care where the building block is stored but its
name must be unique to have predictable results.
Sub InsertMyBuildingBlock_Bookmark()
' Charles Kenyon 09 April 2021
' based on Graham Mayor's macro at
' http://www.gmayor.com/word_vba_examples_3.htm
' In addition to checking the active template, add-in templates and the normal template,
' this macro looks in the building blocks.dotx template.
' Building Block name must be unique!
'
Const BookMarkNAME As String = "delete" ' use the name of the building block - make variable if multiple bookmarks
'
Dim oTemplate As Template
Dim oAddin As AddIn
Dim bFound As Boolean
Dim oRng As range
Dim i As Long
'Define the required building block entry
Const strBuildingBlockName As String = "Building Block Name"
' Set the range
Set oRng = ActiveDocument.Bookmarks(BookMarkNAME).range
'Set the found flag default to False
bFound = False
'Ignore the attached template for now if the
'document is based on the normal template
Application.Templates.LoadBuildingBlocks ' Thank you Timothy Rylatt
If ActiveDocument.AttachedTemplate <> NormalTemplate Then
Set oTemplate = ActiveDocument.AttachedTemplate
'Check each building block entry in the attached template
For i = 1 To oTemplate.BuildingBlockEntries.Count
'Look for the building block name
'and if found, insert it.
If oTemplate.BuildingBlockEntries(i).Name = strBuildingBlockName Then
oTemplate.BuildingBlockEntries(strBuildingBlockName).Insert _
Where:=oRng
'Set the found flag to true
bFound = True
'Clean up and stop looking
GoTo lbl_Exit
End If
Next i
End If
'The entry has not been found
If bFound = False Then
For Each oAddin In AddIns
'Check currently loaded add-ins
If oAddin.Installed = False Then Exit For
Set oTemplate = Templates(oAddin.Path & _
Application.PathSeparator & oAddin.Name)
'Check each building block entry in the each add in
For i = 1 To oTemplate.BuildingBlockEntries.Count
If oTemplate.BuildingBlockEntries(i).Name = strBuildingBlockName Then
'Look for the building block name
'and if found, insert it.
oTemplate.BuildingBlockEntries(strBuildingBlockName).Insert _
Where:=oRng
'Set the found flag to true
bFound = True
'Clean up and stop looking
GoTo lbl_Exit
End If
Next i
Next oAddin
End If
'The entry has not been found. Check the normal template
If bFound = False Then
For i = 1 To NormalTemplate.BuildingBlockEntries.Count
If NormalTemplate.BuildingBlockEntries(i).Name = strBuildingBlockName Then
NormalTemplate.BuildingBlockEntries(strBuildingBlockName).Insert _
Where:=oRng
'set the found flag to true
bFound = True
End If
Next i
End If
'If the entry has still not been found
'finally check the Building Blocks.dotx template
If bFound = False Then
Templates.LoadBuildingBlocks
For Each oTemplate In Templates
If oTemplate.Name = "Building Blocks.dotx" Then Exit For
Next oTemplate
For i = 1 To Templates(oTemplate.fullname).BuildingBlockEntries.Count
If Templates(oTemplate.fullname).BuildingBlockEntries(i).Name = strBuildingBlockName Then
Templates(oTemplate.fullname).BuildingBlockEntries(strBuildingBlockName).Insert _
Where:=oRng
'set the found flag to true
bFound = True
'Clean up and stop looking
GoTo lbl_Exit
End If
Next i
End If
'All sources have been checked and the entry is still not found
If bFound = False Then
'so tell the user.
MsgBox "Entry not found", _
vbInformation, _
"Building Block " _
& Chr(145) & strBuildingBlockName & Chr(146)
End If
lbl_Exit:
set oTemplate = Nothing
set oRng = Nothing
End Sub
For more thoughts/ideas on inserting a building block at a bookmark,
see this thread: Updating bookmark with multiple building blocks based
on checkbox
Even after looking through all of similar phrased questions and several search engine results I did not find any answer.
I copy the current word document and change the codebase by removing former modules and rewrite the ThisDocument-component by adding from file. For the context, but most probably skippable:
Public Sub DOCMPublish()
'...msoFileDialogSaveAs...and then...'
Application.Documents.Add ThisDocument.FullName
On Error Resume Next
' unlink fields and finalize content to avoid updates within the archived documents
Dim oFld As field
For Each oFld In ActiveDocument.Fields
oFld.Unlink
Next
' rewrite macros and unload modules
On Error Resume Next
Dim Element As Object
For Each Element In ActiveDocument.VBProject.VBComponents
ActiveDocument.VBProject.VBComponents.Remove Element
Next
rewriteMain ActiveDocument, "ThisDocument", ThisDocument.path & "\Document_Public_DOCM.vba"
' protect content
ActiveDocument.Protect wdAllowOnlyFormFields, Password:="LoremIpsum"
' msoFileDialogSaveAs does not support filetypes, hence forcing extension
DOCMFile = fileSaveName.SelectedItems(1)
DOCMFile = Replace(DOCMFile, ".doc", ".docm")
DOCMFile = Replace(DOCMFile, ".docmx", ".docm")
' the next line saves the copy to your location and name
ActiveDocument.SaveAs2 filename:=DOCMFile, FileFormat:=wdFormatXMLDocumentMacroEnabled
' next line closes the copy leaving you with the original document
ActiveDocument.Close
End Sub
This sub worked properly for that over the last years:
Sub rewriteMain(ByRef Workument, ByVal Module, ByVal Source)
'delete code from ThisDocument/ThisWorkbook
Workument.VBProject.VBComponents.Item(1).CodeModule.DeleteLines 1, Workument.VBProject.VBComponents.Item(1).CodeModule.CountOfLines
'rewrite from file
With Workument.VBProject
.VBComponents(Module).CodeModule.AddFromFile Source
End With
'delete module
Workument.VBProject.VBComponents.Remove Workument.VBProject.VBComponents("Rewrite")
End Sub
The content of Document_Public_DOCM.vba to be imported is
Option Explicit
Private Sub Document_Close()
ThisDocument.Saved = True
End Sub
Private Sub Document_ContentControlOnExit(ByVal ContentControl As ContentControl, Cancel As Boolean)
Dim cc As ContentControl
For Each cc In ThisDocument.ContentControls
'checkboxes have no type attribute to check against, therefore the need of _
error handling on checked-property that is checkbox-only in this usecase
On Error Resume Next
ThisDocument.Bookmarks("text" & cc.Tag).Range.Font.Hidden = Not cc.Checked
ThisDocument.Bookmarks("notext" & cc.Tag).Range.Font.Hidden = cc.Checked
Next
End Sub
I can see no problem here, and the modified and saved file doesn't complain later on. But in the meantime i get the compiling error on closing the ActiveDocument after the import and ActiveDocument.SaveAs2. I get no error without closing the file though, but this is not nice for the work environment, messing up the screen.
Often word crashes, sometimes it just results in a state loss. I also tried encoding as utf-8 and iso 8859-1, disabled screen updating but that does not seem to be the solution as well. What am I missing?
Edit:
What I tried further without success:
disabling syntax checking in the editor
On Error Resume Next
Err.Clear
newDoc.EnableEvents = False (after implementing #Алексей-Р suggestion)
excluding deletion of .VBProject.VBComponents names "ThisDocument"
Also explicitly compiling the modified files code expectedly does not raise any errors. Are there any editor settings I am unaware of?
I try to answer it myself, at least this solved the issue in this case:
I open the file with
Set newDOC = Documents.Add(ThisDocument.FullName, True, wdNewBlankDocument, False)
I can only assume that opening the file in a new blank document and not displaying it might prevent the code executing and therefore having issues being replaced at runtime.
Edit:
it worked at first, then it didn't. Still don't know why. The following now seems to be failproof:
Set newDOC = Documents.Add("", True, wdNewBlankDocument, False)
ThisDocument.Content.Copy
dim rng
Set rng = newDoc.Content
rng.Collapse Direction:=wdCollapseEnd
rng.Paste
'clear clipboard, otherwise an annoying msg popy up everytime because huge content is left there from copying
Dim clscb As New DataObject 'object to use the clipboard
clscb.SetText text:=Empty
clscb.PutInClipboard 'put void into clipboard
This solution opens a new blank document and copypasts the content without having macros in the first place. Afterwards I proceed to rewrite the modules as in the initial snippet from the question
Not sure why it worked for #АлексейР with my provided code though. Thanks for caring anyway!
I realize that it is probably not supposed to work, but I have this visual basic code from a Word Macro that opens a piece of software linked to a piece of fluke equipment connectded to the computer and when the macro runs it inserts the image from the screen of the equipment into the word document, is there anyway to change this code so it does the same thing in excel?
' InsertInsertActiveScreen Module
' Function: Start FlukeView if required
' Locate position for inserting Screen
' Insert active screen at cursor position
Global Const AppName = "FlukeView ScopeMeter"
Global StartedFV90 As String
' Declare constant values
Private Const ER_NONE = 0
Private Const ER_DDE_CMD_UNK = 25
Private Const ER_DDE_NO_INIT = 26
Private Const ER_DDE_NO_CONN = 27
Private Const ER_DDE_NO_SERVER = 28
Public Sub MAIN()
Dim chan As Long
Dim Status As String
Dim wordApp As Object
Set wordApp = CreateObject("Word.Application")
' Display cursor as an hourglass
Application.Cursor = xlWait
If (wordApp.Tasks.Exists(AppName) = False) Then
' Start FlukeView as server (-s) Modification of these statement is required if
' FlukeView is installed in another directory as the QReport.dot template
Call Shell(ActiveWorkbook.Path & Application.PathSeparator & "FV90WIN.EXE -s", vbMinimizedNoFocus)
' Reminder for terminating FlukeView when closing the document
StartedFV90 = "STARTED"
Else
If (Len(StartedFV90) = 0) Then
' Reminder to prevent terminating FlukeView when closing the document
StartedFV90 = "NOT STARTED BY Fluke View Report"
End If
End If
' Setup a DDE link with FlukeView
chan = DDEInitiate(App:="FV90WIN", Topic:="FlukeView")
While (Val(DDERequest(Channel:=chan, Item:="DDEStatus")) <> ER_NONE)
' Wait until FlukeView is ready to receive commands
Wend
Call DDEExecute(Channel:=chan, String:="Connect")
DoEvents
' Transfer the active screen and place it on the clipboard
Call DDEExecute(Channel:=chan, String:="Screen")
' Read completion status
Status$ = DDERequest(Channel:=chan, Item:="DDEStatus")
If (Val(Status) = ER_NONE) Then
' locate bookmark for pasting contents
Call Selection.GoTo(What:=wdGoToBookmark, Name:="InstrumentScreen")
' Paste the contents of the clipboard into the document
Call Selection.PasteSpecial
' Convert to Inline Shape to prevent overlapping images
For Each ScreenPicture In ActiveSheet.Shapes
If ScreenPicture.Type = msoPicture Then
ScreenPicture.ConvertToInlineShape
End If
Next ScreenPicture
Else
' Error occurred
Call DDEExecute(Channel:=chan, String:="Error" + Status$)
End If
' Terminate DDE connection
Call DDETerminate(Channel:=chan)
' Restore cursor
Application.Cursor = xlDefault
End Sub
This is what i have no and i get a Run-time error '13': Type mismatch?
It's hard to know what works and what doesn't in your macro when transferred from Word to Excel. However, just looking at the code I can offer a few pointer to put you in the right direction:
Replace Global with Private for your global definitions. If you don't, Excel will give you a compile error: "Constants, fixed-length strings, arrays, user-defined types and Declare statements not allowed as Public members of object modules."
Replace:
System.Cursor = wdCursorWait
System.Cursor = wdCursorNormal
with:
Application.Cursor = xlWait
Application.Cursor = xlDefault
Excel doesn't have an ActiveDocument but an ActiveWorkbook and an ActiveSheet for the active sheet in the active workbook.
I don't think you can find an easy way to call:
Tasks.Exists()
in Excel. However, you can cheat and call into Word to do this job for you:
Dim wordApp As Object
Set wordApp = CreateObject("Word.Application")
...
wordApp.Tasks.Exists()
...
Set wordApp = Nothing ' Call this when you're done with it.
The DDEExecute signature is slightly different for Excel, but I've never used it myself so I can't tell you if this will work. The second parameter is not called Command but String in Excel. Try replacing Command:= with String:= and see if that works.
Selection.Copy will copy the selected range, which is similar to Word. But you'll need Selection.PasteSpecial to paste it. Of course, in that case, you're copying and pasting over the same thing so you'll see no different. I suggest looking at the Copy/Paste functionality of the Range object in Excel.
Anyway, that's all I can think of right now. It won't cover everything that's different between Word and Excel, but it's a start. No one here would be able to help you fully, since you're relying on the functionality of a specific program ("FlukeView" or "FV90WIN.EXE") for a lot of the work.
I am writing a reporting tool to document Excel files for various "compliance criteria", including wkb.VBProject.Protection to report if the VBA is locked.
But how can I find if the workbook HAS any project ?
If I calculate
wkb.VBProject.VBComponents.Count - wkb.Worksheets.Count - 1 '(for the workbook)
that will give me the number of modules + class modules + forms, but I could still have some code behind a sheet.
Is there a way in Excel - like Access frm.HasModule - to find out if there's any VBA code in the workbook ?
Excel 2007+ has a new workbook property called ".HasVBProject" that you can enquire.
For Excel 2003 and earlier the above solution testing for lines of code in the CodeModule of any of the VBComponents of the workbook is appropriate.
You should test the ".CountOfLines" property all alone, since lines of code in the Declaration section of a code module (obtained via ".CountOfDeclarationLines") are considered by Excel as "Macro code" and require saving to macro-enabled formats.
Public Function HasVBProject(Optional pWorkbook As Workbook) As Boolean
'
' Checks if the workbook contains a VBProject.
'
On Error Resume Next
Dim wWorkbook As Workbook
Dim wVBComponent As VBIDE.VBComponent ' As Object if used with Late Binding
' Default.
'
HasVBProject = False
' Use a specific workbook if specified, otherwise use current.
'
If pWorkbook Is Nothing _
Then Set wWorkbook = ActiveWorkbook _
Else Set wWorkbook = pWorkbook
If wWorkbook Is Nothing Then GoTo EndFunction
If (VBA.CInt(Application.Version) >= 12) _
Then
' The next method only works for Excel 2007+
'
HasVBProject = wWorkbook.HasVBProject
Else
' Signs the workbook has a VBProject is code in any of the VBComponents that make up this workbook.
'
For Each wVBComponent In wWorkbook.VBProject.VBComponents
If (wVBComponent.CodeModule.CountOfLines > 0) _
Then
' Found a sign of programmer's activity. Mark and quit.
'
HasVBProject = True: Exit For
End If
Next wVBComponent
End If
EndFunction:
Set wVBComponent = Nothing
Set wWorkbook = Nothing
End Function
Dutch
I've used the following to count the total number of lines in a project before. It will pick up code in ThisWorkbook, code modules, class modules and forms.
Private Sub countCodeLines()
Dim obj As Object
Dim VBALineCount As Long
For Each obj In ThisWorkbook.VBProject.VBComponents
VBALineCount = VBALineCount + obj.CodeModule.CountOfLines
Next obj
Debug.Print VBALineCount
End Sub
Note however that if your workbooks have Option Explicit forced then this will count as two lines per object (Option Explicit and a line feed). If you know this to be the case, and are checking the LOC from another project, then you could simply count the number of objects, double it and test that VBALineCount does not exceed this number.
After Lunatik's hint, here's my final function (for whom it may help):
Function fTest4Code(wkb As Workbook) As Boolean
'returns true if wkb contains VBA code, false otherwise
Dim obj As Object
Dim iCount As Integer
For Each obj In wkb.VBProject.VBComponents
With obj.CodeModule
'# lines - # declaration lines > 2 means we do have code
iCount = iCount + ((.CountOfLines - .CountOfDeclarationLines) > 2)
End With
If iCount 0 Then Exit For 'stop when 1st found
Next obj
fTest4Code = CBool(iCount)
End Function