I am attempting to construct code to remotely loop through a folder with .xls files and delete the macros contained within. So far I have the individual components working, but am having difficulties activating the various workbooks and then programmatically ensuring "Microsoft Visual Basic for Application Extensibility 5.3" is referenced within each file.
Thanks!
Sub LoopFiles()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
strPath = ' enter path here
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.DisplayAlerts = False
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder(strPath)
For Each objfile In objFolder.Files
If objFso.GetExtensionName(objfile.Path) = "xls" Then
Set Objworkbook = objExcel.Workbooks.Open(objfile.Path)
' Include your code to work with the Excel object here
Objworkbook.Activate
AddReference (objfile)
Objworkbook.Close True 'Save changes
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Sub AddReference(FileRequired)
FileRequired.Activate
'MsgBox "Sheet: " & ActiveWorkbook.Name
ActiveWorkbook.VBProject.References.AddFromGuid _
GUID:="{0002E157-0000-0000-C000-000000000046}", _
Major:=5, Minor:=3
End Sub
Sub DeleteAllVBACode()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Set VBProj = ActiveWorkbook.VBProject
For Each VBComp In VBProj.VBComponents
If VBComp.Type = vbext_ct_Document Then
Set CodeMod = VBComp.CodeModule
With CodeMod
.DeleteLines 1, .CountOfLines
End With
Else
VBProj.VBComponents.Remove VBComp
End If
Next VBComp
End Sub
Like I mentioned in my comments, you do not need to add a reference to Microsoft Visual Basic for Application Extensibility 5.3 to delete the code from the files. Consider this small exercise.
1). Create an Excel file
2). Paste this code in a module
Sub Sample1()
MsgBox "A"
End Sub
3). Save the above file as C:\Sample.xls
4). Close the file
5). Open a new excel file and paste this code in a module
Option Explicit
'~~> Trust Access To Visual Basics Project must be enabled.
Sub Sample2()
Dim wb As Workbook
Dim i As Long
'~~> Replace this with the relevant file
'~~> We can open the files in a loop as well
Set wb = Workbooks.Open("C:\Sample.xls")
On Error Resume Next
With wb.VBProject
'~~> Remove the components
For i = .VBComponents.Count To 1 Step -1
.VBComponents.Remove .VBComponents(i)
Next i
'~~> Remove the code lines
For i = .VBComponents.Count To 1 Step -1
.VBComponents(i).CodeModule.DeleteLines _
1, .VBComponents(i).CodeModule.CountOfLines
Next i
End With
On Error GoTo 0
End Sub
6) Ensure that "Trust Access To Visual Basics Project" is enabled
7) Run the Sample2()
You will see that the code in Sample.xls is deleted and we haven't even set the reference to Microsoft Visual Basic for Application Extensibility 5.3.
Related
I have a set of ~10 modules/forms/classes that I like to use and reuse for many many projects. Usually these modules are coming in at the middle or the end of the project, not the start (So no making a template and using that from the start - I use that to make a few projects). Is there an easy way to mass import modules and references (that doesn't involve changing the file extension to .zip)?
I'm open to the file extension change method, but I'd like to exhaust my other resources first
You don't need any code or add-in for mass-importing. Simply save the commonly-used files in one specific folder that only contains these files.
It's a little-known VBE feature, that the Project Explorer supports drag-and-drop.
Then when you start a new VBA project, drag the files from the Windows Explorer and drop them onto the VBE's Project Explorer toolwindow - done.
The VBE's "import" file browse dialog is blocking multiple selections for some reason; Rubberduck fixes that by allowing multiple selections in its own "import" file browse dialog (off its Code Explorer toolwindow), and its "Export Active Project" tool makes it trivial to export an entire project's source code into a given folder like, say, a local git repository.
As for project references, no code can do that automatically without parsing some metadata that would have to be included somewhere in the module itself. Adding project references is annoying... Rubberduck's add/remove references dialog makes it much easier:
Disclaimer: I manage the Rubberduck open-source project.
You can do it from vba code ,
i get this code from here :
https://www.rondebruin.nl/win/s9/win002.htm
Public Sub ImportModules()
Dim wkbTarget As Excel.Workbook
Dim objFSO As Scripting.FileSystemObject
Dim objFile As Scripting.File
Dim szTargetWorkbook As String
Dim szImportPath As String
Dim szFileName As String
Dim cmpComponents As VBIDE.VBComponents
If ActiveWorkbook.Name = ThisWorkbook.Name Then
MsgBox "Select another destination workbook" & _
"Not possible to import in this workbook "
Exit Sub
End If
'Get the path to the folder with modules
If FolderWithVBAProjectFiles = "Error" Then
MsgBox "Import Folder not exist"
Exit Sub
End If
''' NOTE: This workbook must be open in Excel.
szTargetWorkbook = ActiveWorkbook.Name
Set wkbTarget = Application.Workbooks(szTargetWorkbook)
If wkbTarget.VBProject.Protection = 1 Then
MsgBox "The VBA in this workbook is protected," & _
"not possible to Import the code"
Exit Sub
End If
''' NOTE: Path where the code modules are located.
szImportPath = FolderWithVBAProjectFiles & "\"
Set objFSO = New Scripting.FileSystemObject
If objFSO.GetFolder(szImportPath).Files.Count = 0 Then
MsgBox "There are no files to import"
Exit Sub
End If
'Delete all modules/Userforms from the ActiveWorkbook
Call DeleteVBAModulesAndUserForms
Set cmpComponents = wkbTarget.VBProject.VBComponents
''' Import all the code modules in the specified path
''' to the ActiveWorkbook.
For Each objFile In objFSO.GetFolder(szImportPath).Files
If (objFSO.GetExtensionName(objFile.Name) = "cls") Or _
(objFSO.GetExtensionName(objFile.Name) = "frm") Or _
(objFSO.GetExtensionName(objFile.Name) = "bas") Then
cmpComponents.Import objFile.Path
End If
Next objFile
MsgBox "Import is ready"
End Sub
Public Sub ExportModules()
Dim bExport As Boolean
Dim wkbSource As Excel.Workbook
Dim szSourceWorkbook As String
Dim szExportPath As String
Dim szFileName As String
Dim cmpComponent As VBIDE.VBComponent
''' The code modules will be exported in a folder named.
''' VBAProjectFiles in the Documents folder.
''' The code below create this folder if it not exist
''' or delete all files in the folder if it exist.
If FolderWithVBAProjectFiles = "Error" Then
MsgBox "Export Folder not exist"
Exit Sub
End If
On Error Resume Next
Kill FolderWithVBAProjectFiles & "\*.*"
On Error GoTo 0
''' NOTE: This workbook must be open in Excel.
szSourceWorkbook = ActiveWorkbook.Name
Set wkbSource = Application.Workbooks(szSourceWorkbook)
If wkbSource.VBProject.Protection = 1 Then
MsgBox "The VBA in this workbook is protected," & _
"not possible to export the code"
Exit Sub
End If
szExportPath = FolderWithVBAProjectFiles & "\"
For Each cmpComponent In wkbSource.VBProject.VBComponents
bExport = True
szFileName = cmpComponent.Name
''' Concatenate the correct filename for export.
Select Case cmpComponent.Type
Case vbext_ct_ClassModule
szFileName = szFileName & ".cls"
Case vbext_ct_MSForm
szFileName = szFileName & ".frm"
Case vbext_ct_StdModule
szFileName = szFileName & ".bas"
Case vbext_ct_Document
''' This is a worksheet or workbook object.
''' Don't try to export.
bExport = False
End Select
If bExport Then
''' Export the component to a text file.
cmpComponent.Export szExportPath & szFileName
''' remove it from the project if you want
'''wkbSource.VBProject.VBComponents.Remove cmpComponent
End If
Next cmpComponent
MsgBox "Export is ready"
End Sub
Function FolderWithVBAProjectFiles() As String
Dim WshShell As Object
Dim FSO As Object
Dim SpecialPath As String
Set WshShell = CreateObject("WScript.Shell")
Set FSO = CreateObject("scripting.filesystemobject")
SpecialPath = WshShell.SpecialFolders("MyDocuments")
If Right(SpecialPath, 1) <> "\" Then
SpecialPath = SpecialPath & "\"
End If
If FSO.FolderExists(SpecialPath & "VBAProjectFiles") = False Then
On Error Resume Next
MkDir SpecialPath & "VBAProjectFiles"
On Error GoTo 0
End If
If FSO.FolderExists(SpecialPath & "VBAProjectFiles") = True Then
FolderWithVBAProjectFiles = SpecialPath & "VBAProjectFiles"
Else
FolderWithVBAProjectFiles = "Error"
End If
End Function
Function DeleteVBAModulesAndUserForms()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Set VBProj = ActiveWorkbook.VBProject
For Each VBComp In VBProj.VBComponents
If VBComp.Type = vbext_ct_Document Then
'Thisworkbook or worksheet module
'We do nothing
Else
VBProj.VBComponents.Remove VBComp
End If
Next VBComp
End Function
This script worked perfectly... until it didn't. I have an Excel workbook in the same folder as multiple copies of a Word form. The macro should pull the data from each form and copy it to a row in the workbook. I now get either "OLE Excel is waiting on another application" errors or Runtime 438 errors. The macro I use is as follows:
Sub GetFormData()
Application.ScreenUpdating = False
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim CCtrl As Word.ContentControl
Dim strFolder As String, strFile As String
Dim WkSht As Worksheet, i As Long, j As Long
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set WkSht = ActiveSheet
i = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(strFolder & "\*.docm", vbNormal)
While strFile <> ""
i = i + 1
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
j = 0
For Each CCtrl In .ContentControls
j = j + 1
WkSht.Cells(i, j).FormulaLocal = CCtrl.Range.Text
Next
End With
wdDoc.Close SaveChanges:=False
strFile = Dir()
Wend
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
The issue appears to start at "Set wdDoc = wdApp..."
I am a bit of a noob at this. As such, I appreciate your help.
Matt.
I see two possible issues, the first one is almost certainly causing the error; the second could cause this error (but probably not with VBA):
You declare and instantiate the Word application in the same line:
Dim wdApp As New Word.Application
You shouldn't do this. Instead:
Dim wdApp As Word.Application
Set wdApp = New Word.Application
I don't remember the exact details about the "why", but it's something to do with the Word.Application object being created immediately, and at a level where you can no longer control it using Set wdApp = Nothing.
Correctly, all objects of the "outside" application should be released, in reverse order of their creation. You've declared an object of the type Word.ContentControl, but don't release it:
Set Set CCtrl = Nothing : Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
I am new to VBA and obviously I am missing something. My code works for opening a word doc and sending data to it BUT does NOT for an ALREADY OPEN word doc. I keep searching for an answer on how to send info from Excel to an OPEN Word doc/Bookmark and nothing works.
I hope it is okay that I added all the code and the functions called. I really appreciate your help!
What I have so far
Sub ExcelNamesToWordBookmarks()
On Error GoTo ErrorHandler
Dim wrdApp As Object 'Word.Application
Dim wrdDoc As Object 'Word.Document
Dim xlName As Excel.Name
Dim ws As Worksheet
Dim str As String 'cell/name value
Dim cell As Range
Dim celldata As Variant 'added to use in the test
Dim theformat As Variant 'added
Dim BMRange As Object
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Set wb = ActiveWorkbook
strPath = wb.Path
If strPath = "" Then
MsgBox "Please save your Excel Spreadsheet & try again."
GoTo ErrorExit
End If
'GET FILE & path of Word Doc/Dot
strPathFile = strOpenFilePath 'call a function in MOD1
If strPathFile = "" Then
MsgBox "Please choose a Word Document (DOC*) or Template (DOT*) & try again." 'strPath = Application.TemplatesPath
GoTo ErrorExit
End If
If FileLocked(strPathFile) Then 'Err.Number = 70 if open
'read / write file in use 'do something
'NONE OF THESE WORK
Set wrdApp = GetObject(strPathFile, "Word.Application")
'Set wrdApp = Word.Documents("This is a test doc 2.docx")
'Set wrdApp = GetObject(strPathFile).Application
Else
'all ok 'Create a new Word Session
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
wrdApp.Activate 'bring word visiable so erros do not get hidden.
'Open document in word
Set wrdDoc = wrdApp.Documents.Open(Filename:=strPathFile) 'Open vs wrdApp.Documents.Add(strPathFile)<=>create new Document1 doc
End If
'Loop through names in the activeworkbook
For Each xlName In wb.Names
If Range(xlName).Cells.Count = 1 Then
celldata = Range(xlName.Value)
'do nothing
Else
For Each cell In Range(xlName)
If str = "" Then
str = cell.Value
Else
str = str & vbCrLf & cell.Value
End If
Next cell
'MsgBox str
celldata = str
End If
'Get format and strip away the spacing, negative color etc etc
'I know this is not right... it works but not best
theformat = Application.Range(xlName).DisplayFormat.NumberFormat
If Len(theformat) > 8 Then
theformat = Left(theformat, 5) 'was 8 but dont need cents
Else
'do nothing for now
End If
If wrdDoc.Bookmarks.Exists(xlName.Name) Then
'Copy the Bookmark's Range.
Set BMRange = wrdDoc.Bookmarks(xlName.Name).Range.Duplicate
BMRange.Text = Format(celldata, theformat)
'Re-insert the bookmark
wrdDoc.Bookmarks.Add xlName.Name, BMRange
End If
Next xlName
'Activate word and display document
With wrdApp
.Selection.Goto What:=1, Which:=2, Name:=1 'PageNumber
.Visible = True
.ActiveWindow.WindowState = wdWindowStateMaximize 'WAS 0 is this needed???
.Activate
End With
GoTo WeAreDone
'Release the Word object to save memory and exit macro
ErrorExit:
MsgBox "Thank you! Bye."
Set wrdDoc = Nothing
Set wrdApp = Nothing
Exit Sub
'Error Handling routine
ErrorHandler:
If Err Then
MsgBox "Error No: " & Err.Number & "; There is a problem"
If Not wrdApp Is Nothing Then
wrdApp.Quit False
End If
Resume ErrorExit
End If
WeAreDone:
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub
file picking:
Function strOpenFilePath() As String
Dim intChoice As Integer
Dim iFileSelect As FileDialog 'B
Set iFileSelect = Application.FileDialog(msoFileDialogOpen)
With iFileSelect
.AllowMultiSelect = False 'only allow the user to select one file
.Title = "Please... Select MS-WORD Doc*/Dot* Files"
.Filters.Clear
.Filters.Add "MS-WORD Doc*/Dot* Files", "*.do*"
.InitialView = msoFileDialogViewDetails
End With
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strOpenFilePath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
Else
'nothing yet
End If
End Function
checking if file is open...
Function FileLocked(strFileName As String) As Boolean
On Error Resume Next
' If the file is already opened by another process,
' and the specified type of access is not allowed,
' the Open operation fails and an error occurs.
Open strFileName For Binary Access Read Write Lock Read Write As #1
Close #1
' If an error occurs, the document is currently open.
If Err.Number <> 0 Then
' Display the error number and description.
MsgBox "Function FileLocked Error #" & str(Err.Number) & " - " & Err.Description
FileLocked = True
Err.Clear
End If
End Function
ANSWER BELOW. Backstory... So, after input from you guys and more research I discovered that I needed to set the active word document by using the file selection the user picked and that is then passed via late binding to the sub as an object to process. NOW it works if the word file is not in word OR if it is currently loaded into word AND not even the active document. The below code replaces the code in my original question.
Set Object app as word.
grab the file name.
Make the word doc selected active to manipulate.
Set the word object to the active doc.
THANK YOU EVERYONE!
If FileLocked(strPathFile) Then 'Err.Number = 70 if open
'read / write file in use 'do something
Set wrdApp = GetObject(, "Word.Application")
strPathFile = Right(strPathFile, Len(strPathFile) - InStrRev(strPathFile, "\"))
wrdApp.Documents(strPathFile).Activate ' need to set picked doc as active
Set wrdDoc = wrdApp.ActiveDocument ' works!
This should get you the object you need.
Dim WRDFile As Word.Application
Set WRDFile = GetObject(strPathFile)
'Have Microsoft Word 16.0 Object Library selected in your references
Dim wordapp As Object
Set wordapp = GetObject(, "Word.Application")
wordapp.Documents("documentname").Select
'works if you only have one open word document. In my case, I'm trying to push updates to word links from excel.
I am currently using to following code to prompt the user for a workbook, open it, get some information from it and then close it. at the moment, I address the opened workbook by using the workbooks collection with and index ("woorkbooks(2)"). Now I need to open two workbooks, and my problem is that I wouldn't know which of the workbooks will be indexed as 2 and which will be indexed as 3. So, I figured there must be a way to get a reference to each workbook.
Function openfile() As Boolean
Dim fd As FileDialog
Dim file_was_chosen As Boolean
Set fd = Application.FileDialog(msoFileDialogOpen)
With fd
.Filters.Clear
.Filters.Add "Excel File", "*.xl*"
End With
file_was_chosen = fd.Show
If Not file_was_chosen Then
MsgBox "You didn't select a file"
openfile = False
Exit Function
End If
fd.Execute
openfile = True
End Function
Now I've seen some solutions to this problem involving getting the full path of each workbook, but I'd prefer avoid using the full path since it contains words in different language (and the name of the workbook appears with question marks). Moreover, I'd prefer a solution in which the user is promped only once for 2 files and not twice.
This version gives the user a single dialog. Enjoy. And whoever downvoted my other answer, please add a comment to that explaining what you so disliked about it that it required a downvote.
Function openfile() As Variant
Dim aOpen(2) As String, itm As Variant, cnt As Long, lAsk As Long
Dim fd As FileDialog
Dim file_was_chosen As Boolean
Set fd = Application.FileDialog(msoFileDialogOpen)
With fd
.Filters.Clear
.Filters.Add "Excel File", "*.xl*"
End With
Do
file_was_chosen = fd.Show
If Not file_was_chosen Or fd.SelectedItems.Count > 2 Then
lAsk = MsgBox("You didn't select one or two files, try again?", vbQuestion + vbYesNo, "File count mismatch")
If lAsk = vbNo Then
openfile = aOpen
Exit Function
End If
End If
Loop While fd.SelectedItems.Count < 1 Or fd.SelectedItems.Count > 2
cnt = 0
For Each itm In fd.SelectedItems
aOpen(cnt) = itm
cnt = cnt + 1
Next
openfile = aOpen
fd.Execute
End Function
Sub test()
Dim vRslt As Variant
Dim wkb As Excel.Workbook, wkb1 As Excel.Workbook, wkb2 As Excel.Workbook
vRslt = openfile
For Each wkb In Application.Workbooks
If wkb.Path & "\" & wkb.Name = vRslt(0) Then Set wkb1 = wkb
If wkb.Path & "\" & wkb.Name = vRslt(1) Then Set wkb2 = wkb
Next
If vRslt(0) = "" Then ' no files
MsgBox "No files opened so nothing happens..."
ElseIf vRslt(1) = "" Then ' one file was opened
MsgBox "One file so do whatever you want for one file"
Else ' two files were opened
MsgBox "Two files so do whatever you want for two files"
End If
End Sub
Working with your existing openfile function, change the return from Boolean to Excel.Workbook. If they don't open a workbook you set it to Nothing instead of false, otherwise you set it to the workbook reference of the file you just opened (You'll need to modify openfile to get that reference). You then just call it twice and set a workbook reference for each call that is not Nothing.
Example code below is written freeform and is untested - it's really just glorified pseudocode - but should point you the right general direction.
sub test
dim lAsk as long
dim wkb1 as excel.workbook
dim wkb2 as excel.workbook
do
if wkb1 is Nothing then
set wkb1 = openfile
if wkb1 is Nothing then
lAsk = msgbox("you didn't select a first file, try again?",vbyesno,"No file selected")
if lAsk = vbNo then exit do
end if
elseif wkb2 is Nothing then
set wkb2 = openfile
if wkb2 is Nothing then
lAsk = msgbox("you didn't select a second file, try again?",vbyesno,"No file selected")
if lAsk = vbNo then exit do
end if
end if
loop while wkb1 is Nothing or wkb2 is Nothing
' do whatever with wkb1 and wkb2 here
end sub
Edited to add:
Here's a very basic shape for your revised openfile function. Again, untested but I've modified it from one of my own procs so it should work
Function openfile() As Excel.Workbook
Dim sFilter As String
Dim sTitle As String
Dim vFileName As Variant
sFilter = "Excel Files (*.xl*), *.xl*, CSV Files (*.csv), *.csv, All Files (*.*), *.*"
sTitle = "Select file to process"
vFileName = Application.GetOpenFilename(filefilter:=sFilter, Title:=sTitle)
If vFileName = False Then
Set openfile = Nothing
Else
Set openfile = Workbooks.Open(Filename:=vFileName)
End If
End Function
The following code allows me to import .msg files into excel.
I was wondering if it is possible to create a macro in outlook that sends messages into an excel file rather than importing them.
The code I used for importing .msg files is as follows:
Sub IMPORTMSG()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim i As Long
Dim inPath As String
Dim thisFile As String
' Dim Msg As MailItem
Dim ws As Worksheet
' Dim myOlApp As Outlook.Application
' Dim MyItem As Outlook.MailItem
Set myOlApp = CreateObject("Outlook.Application")
Set ws = ThisWorkbook.Worksheets("A")
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = False Then
Exit Sub
End If
On Error Resume Next
inPath = .SelectedItems(1) & "\"
End With
thisFile = Dir(inPath & "*.msg")
i = 4
Do While thisFile <> ""
Set MyItem = myOlApp.CreateItemFromTemplate(inPath & thisFile)
If MyItem.Subject = "testheader" Then
ws.Cells(i, 1) = MyItem.Body
i = i + 1
End If
thisFile = Dir()
Loop
Set MyItem = Nothing
Set myOlApp = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
You can create a COM addin for Outlook and have it run the code above. Or you can use Application.ActiveExplorer.Selection collection in Outlook to loop through the selected messages in Outlook instead of processing standalone MSG files.
You can develop an Outlook VBA macro where you can automate Excel and set Excel cell values. See How to automate Microsoft Excel from Visual Basic for more information.
Also you may find the Getting Started with VBA in Outlook 2010 article helpful.