Receive notification of file creation in VBA without polling - vba

I am writing a program that integrates with a ScanSnap scanner. ScanSnap scanners do not support TWAIN. Once a document is scanned it is automatically saved to a PDF.
I want to monitor the directory where the files will be saved and take some action when the file appears (and is done being written to). A simple approach is to use the MS Access form Timer event and check for an existing file at some small interval of time.
Is there a better alternative via Windows Messaging, the FileSystemObject, or some Windows API function that supports callbacks?

This provides a native WinAP + VB/VBA way of doing the job, I expect:
http://books.google.com/books?id=46toCUvklIQC&pg=PA757&lpg=PA757&dq=windows+api+monitor+directory+changes+vba&source=bl&ots=jmMY4sJFK4&sig=KCB6B_soEA9_JzjlhyNZvSC91w4&hl=en&sa=X&ei=cUAMUsDzOe3iyAHu8YGwAg&ved=0CFIQ6AEwBw#v=onepage&q=windows%20api%20monitor%20directory%20changes%20vba&f=false

Nothing inside Excel.
You can create another application that monitors the file system, and executes the Excel macro, opening the workbook if required, opening Excel if required.

#Steve effectively answered the question I asked. What I should have asked is how to monitor file system changes in a thread separate from the MS Access UI thread. And the simple answer to that question is that VBA does not support multi-threading in Office applications.
There are a variety of workarounds that generally involve calling an external COM library or integrating with an external application. I decided none of those was very appealing and instead decided to implement the solution in VB.Net using the FileSystemWatcher class.

Not sure if this really solves your Problem, but here is an approach using Excel VBA that helped me monitor a specific file within a specific Folder and execute certain actions (here: copy the file into another folder) if the file is modified and saved (i.e. when the file's timestamp changes):
Option Explicit
Const SourcePath = "C:\YourFolder\"
Const TargetPath = "C:\YourFolder\YourFolder_Changes\"
Const TargetFile = "YourFileName"
Private m_blnLooping As Boolean
Private Sub CommandButton1_Click()
Dim FSO As Scripting.FileSystemObject
Dim n, msg, dt, inttext As String
Dim file, files As Object
Dim d1, d2 As Date
Dim cnt As Integer
Dim wsshell
Application.ScreenUpdating = False
On Error Resume Next
Set FSO = CreateObject("Scripting.FileSystemObject")
Set files = FSO.GetFolder(SourcePath).files
Set wsshell = CreateObject("WScript.Shell")
msg = "FileWatcher started. Monitoring of " & TargetFile & " in progress."
cnt = 0
'Initialize: Loop through Folder content and get file date
For Each file In files
n = file.name
'Get Initial SaveDate of Target File
If n = TargetFile Then
d1 = file.DateLastModified
End If
Next file
m_blnLooping = True
inttext = wsshell.popup(msg, 2, "FileWatcher Ready", vbInformation)
'Message Box should close after 2 seconds automatically
Shell "C:\WINDOWS\explorer.exe """ & TargetPath & "", vbNormalFocus
'Open Windows Explorer and display Target Directory to see changes
Do While m_blnLooping
For Each file In files
n = file.name
If n = TargetFile Then
d2 = file.DateLastModified
If d2 > d1 Then
dt = Format(CStr(Now), "yyyy-mm-dd_hh-mm-ss")
'FSO.CopyFile (SourcePath & TargetFile), (TargetPath & Left(TargetFile, Len(TargetFile) - 4) & "_" & dt & ".txt"), True 'Option with file name extension
FSO.CopyFile (SourcePath & TargetFile), (TargetPath & TargetFile & "_" & dt), True 'Option without file name extension
cnt = cnt + 1
d1 = d2
End If
End If
Next file
'Application.Wait (Now() + CDate("00:00:02")) 'wait 2 seconds, then loop again
DoEvents
Loop
msg = "File " & TargetFile & " has been updated " & cnt & " times."
inttext = wsshell.popup(msg, 2, "FileWatcher Closed", vbInformation)
'Message Box should close after 2 seconds automatically
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton2_Click()
m_blnLooping = False
End Sub
The procedure is activated via a CommandButton ("START") and loops through the speficied Folder (keeps watching the file) until another CommandButton ("STOP") is pressed. You may, however, need to adjust the code to monitor file creation instead of file changes (file.DateCreated instead of file.DateLastModified). The Code is just meant to provide you hint that might solve your Problem.

Related

Windows Warning Messages for VBA/Sendkeys App

I am trying to do a very simple routine with SendKeys method in VBA to automate opening an app.
The problem is when I try to open a .exe ou .Ink (shortcut) file. The VBA compilation stops and the following message appears "Some files contain viruses that can be harmful to your computer...."
After that I need to select "Ok" or "Cancel" and the aplication doesn't work properly.
I researched a lot but couldn't find any solution. Are there any way to make the message not appear?
I have Windows 10 Home Single Language, Microsoft 365, Excel Version 2107.
See below the code please (The warning message appears in the line "SendKeys (strFile)"):
Sub Ligacao()
Dim strOrigem As String
Dim strExtensao As String
Dim strFile As String
Application.DisplayAlerts = False
strOrigem = ThisWorkbook.Path & "\"
strExtensao = ".lnk"
strFile = Dir(strOrigem & "*" & strExtensao)
Do While strFile <> ""
If Mid(strFile, 1, 3) = "Hat" Then
SendKeys (strFile)
End If
Loop
End Sub

Detect new mail then extract, unzip and rename attachments

I receive 4 weekly emails from 3 different senders.
Emails 1 and 2 are from the same sender and can be recognized through VBA. These emails contain zip files, where each zip file has one .csv file.
Emails 3 and 4 can also be recognized by VBA and the attachments are Excel sheets (.xlsx).
I want to extract and unzip (where needed) and save these 4 files in a folder as; email1.report, email2.report etc.
Then make a copy of these 4 files in a different folder for each file and rename like; "Today's date".email1.report.csv etc.
I want to combine these steps in a single code and to replace the email1.report, email2.report etc., files without a prompt asking "do you want to replace the files? Yes, No?"
Is it possible to detect the new weekly emails and do this automatically?
The code I use to unzip and save:
Else
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "zip" Then
FileNameFolder = "C:\Users\..."
FileName = FileNameFolder & Left(Atmt.FileName, (InStr(1, Atmt.FileName, ".zip") - 1)) & ".txt"
Atmt.SaveAsFile FileName
FileNameT = FileNameFolder & Atmt.FileName
Name FileName As FileNameT
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace((FileNameFolder)).CopyHere oApp.NameSpace((FileNameT)).Items
Kill FileNameT
i = i + 1
End If
Next Atmt
'item.Close
End If
I won't develop the code for your specific problem, but I recently wrote something similar. Maybe you can go from here by altering to your criteria etc.
In my case I had two e-mails incoming shortly after another, within 60 seconds. Both mails had "FP" in their subject and a .pdf-attachment. The task was to concatenate these attachments using the installed PDF24, which luckily offers a shell command for this.
This was the code, placed in the "ThisOutlookSession" of the Outlook VBA project explorer.
Public btAttachmentMails As Byte
Public dtArrivalStamp As Date
Public strPathFirstMailAttachment As String
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(Item) = "MailItem" Then
Dim i As Integer
Dim strDocumentsFolder As String
strDocumentsFolder = CreateObject("WScript.Shell").SpecialFolders(16)
strPathFirstMailAttachment = strDocumentsFolder & "\attachment_mail1.pdf"
If Item.Subject Like "FP*" Then
If btAttachmentMails = 0 Then
'first mail -> save attachment and set counter to 1
btAttachmentMails = 1
dtArrivalStamp = Time
For i = 1 To Item.Attachments.Count
If InStr(Item.Attachments.Item(i).DisplayName, ".PDF") > 0 Then
Item.Attachments.Item(i).SaveAsFile strPathFirstMailAttachment
End If
Next i
ElseIf btAttachmentMails = 1 Then
Dim dtNow As Date: dtNow = Time
If TimeDiff(dtArrivalStamp, dtNow) <= 60 Then
'second mail within 60 seconds with subject containing "FP" -> save attachment and concatenate both via pdf24, then delete both files
'save attachment of second mail
Dim strPathSecondMailAttachment As String
strPathSecondMailAttachment = strDocumentsFolder & "\attachment_mail2.pdf"
For i = 1 To Item.Attachments.Count
If InStr(Item.Attachments.Item(i).DisplayName, ".PDF") > 0 Then
Item.Attachments.Item(i).SaveAsFile strPathSecondMailAttachment
End If
Next i
'concatenate pdf documents via pdf24 shell
Dim strOutputPath As String
strOutputPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Year(Date) & Month(Date) & Day(Date) & "_Wartungsplan_" & Replace(CStr(Time), ":", "-") & ".PDF"
Shell ("""C:\Program Files (x86)\PDF24\pdf24-DocTool.exe"" -join -profile ""default/good"" -outputFile " & strOutputPath & " " & strPathFirstMailAttachment & " " & strPathSecondMailAttachment)
'inform user
MsgBox ("Files have been successfully concatenated. You can find the combined file on your desktop.")
'reset status, delete temporary documents
btAttachmentMails = 0
If CreateObject("Scripting.FileSystemObject").fileexists(strPathFirstMailAttachment) Then Kill strPathFirstMailAttachment
If CreateObject("Scripting.FileSystemObject").fileexists(strPathSecondMailAttachment) Then Kill strPathSecondMailAttachment
Else
'second mail did not arrive within 60 seconds -> treat as first mail
'save new arrival time and overwrite old firstMailAttachment with this one
dtArrivalStamp = Time
For i = 1 To Item.Attachments.Count
If InStr(Item.Attachments.Item(i).DisplayName, ".PDF") > 0 Then
Item.Attachments.Item(i).SaveAsFile strPathFirstMailAttachment 'overwrites existing file
End If
Next i
End If
End If
End If
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description & " - please contact XY"
Resume ExitNewItem
End Sub
Function TimeDiff(StartTime As Date, StopTime As Date)
TimeDiff = Abs(StopTime - StartTime) * 86400
End Function
cr44sh has posted an answer while I was creating mine. He has recommended using a new item event while I have recommended using a rule. I prefer rules but you can choose which ever approach you favour.
It is impossible to fully answer your question but I believe I can give enough help for you to construct the macros you need yourself.
You say that these emails can be identified with VBA. That suggests the best approach is an Outlook rule which uses the “run a script” option where “run a script” means “run a macro”. I will discuss the rule later but first you need the macros that will be run.
You will need two macros like this:
Public Sub Type1Email(ByRef ItemCrnt As MailItem)
' Relevant code
End Sub
Public Sub Type2Email(ByRef ItemCrnt As MailItem)
' Relevant code
End Sub
I am sure you can create better names for these macros. I have read that macros to be run by a rule must be in ThisOutlookSession. In my experience, they can be in an ordinary module providing they are declared as Public. I only use ThisOutlookSession for code that has to be in that code area. If code can be in a module, that is where I place it. I suggest creating a new module which will be named Module1 or Module2. Use function key F4 to access its properties and rename it as “ModRuleMacros” or similar. Giving modules meaningful names makes it so much easier to find the code you want to look at today.
Although the aim is to create a macro to be run by a rule, you need a way of testing the macro. If you have some of these emails saved somewhere, you can activate the rule by moving one of those emails to Inbox. However, I generally find it easier to use a macro like this:
Sub TestType1Email()
Dim Exp As Explorer
Dim ItemCrnt As MailItem
Set Exp = Outlook.Application.ActiveExplorer
If Exp.Selection.Count = 0 Then
Call MsgBox("Pleaase select one or more emails then try again", vbOKOnly)
Exit Sub
Else
For Each ItemCrnt In Exp.Selection
Call Type1Email(ItemCrnt)
Next
End If
End Sub
To use this macro, you select one or more Type1 emails and then run macro TestType1Email. This macro will pass the selected emails, one at a time, to the macro Type1Email. This will allow you to single step through macro Type1Email and ensure that it works to your entire satisfaction. I find this to be the easier method of testing a new Outlook macro.
It may be helpful to check what a rule can do for you. Select one of these emails and then click on Rules, which is in the middle of the Home tab, and then Create rule …. Selecting one of these emails means the first window is filled out with some options. Click Advanced options …. The new window lists all the options for selecting an email. Are all the options you need to select a type 1 or a type 2 email listed? The list is comprehensive but not complete. For example, you cannot select by the presence of attachments. Identify the options you can use and identify the options you need that are missing. Click Cancel twice to exist from rule creation.
You will need include code for any missing options in your macro.
Your question implies you have all the code you need for processing the emails except for suppressing the replace question. You need to check if there is an existing file before creating the new file. This is the routine that I use to check if a file exists:
Public Function FileExists(ByVal PathName As String, ByVal FileName As String) As Boolean
' Returns True if file exists. Assumes path already tested.
' Coded by Tony Dallimore
' Based on code written by iDevlop: http://stackoverflow.com/a/28237845/973283
' Ensure only one "\" between path and filename
If Right$(PathName, 1) <> "\" Then
PathName = PathName & "\"
End If
If Left$(FileName, 1) = "\" Then
FileName = Mid$(FileName, 2)
End If
FileExists = False
On Error Resume Next
FileExists = ((GetAttr(PathName & FileName) And vbDirectory) <> vbDirectory)
On Error GoTo 0
End Function
If the file exists, you can:
Use VBA statement Kill (https://learn.microsoft.com/en-gb/office/vba/Language/Reference/user-interface-help/kill-statement) to delete the old file.
Use VBA statement Name (https://learn.microsoft.com/en-gb/office/vba/language/reference/user-interface-help/name-statement) to move the old file to another folder or rename it perhaps by adding a date at the beginning of the name.
I favour the second option because I do not like deleting a file until I am really, really sure I will not need it again. I saw too many situations during my career where a file deleted as no longer needed was found to be incorrectly or incompletely processed a few months later.
Once you have fully tested the macros, you can create the rules to execute them. For each type of email:
Select an email of the required type.
Click on Rules and then Create rule ….
Tick any relevant boxes on the first window.
Click Advanced options ….
Tick all relevant boxes on the second window.
Click Next.
Tick the box against “Run a script”.
Click a script.
You will be shown a list of all the macros that can be run from a rule. Select the required macro.
Click Next.
Tick the box against any appropriate exceptions and enter any additional information required.
Click Next.
Name the rule. Tick “run this rule against any messages already in Inbox” if required. Review the rule and edit if necessary.
Click Finish.
I hope the above is enough to plug the holes in your knowledge.

Read item titles from SharePoint Document Library into Array using Excel VBA

I need to read all the item titles for all the documents in a SharePoint document library directly into an Array using Excel VBA. I can't seem to successfully use FileSystemObject and I do not want to map the document library to a drive letter as the macro will be distributed and widely used.
The SharePoint site has an https address
I have looked at this thread about referencing scrrun.dll but it does not work because I cannot change the trust settings on my local domain
This thread looked promising, but again it seems to use FileSystemObject which might be my hang up.
This thread on the SharePoint stackexchange site works well for reading in a list of files as a worksheet object, but I don't know how it could be adapted to be pushed directly into an array.
I tend to receive Error 76 "Bad Path", but I am easily able to execute on local (C:) files.
I have tried using a WebDAV address - like the answer I gave to this thread - but it too encounters a "Bad Path" error.
There must be a way to read in the contents of a SharePoint document library directly into an array that does not violate my local security policies and doesn't depend upon an excel worksheet.
Ok I am going to self answer. I'm not 100% thrilled with my solution, but it does suffice within my constraints. Here are the high level points:
Use VBA to create BAT files that have the "Net Use" command within them.
Reference the WebDAV address of the document library and find an available drive letter
I doubt that any of my users already have 26 mapped drives...).
Once the document library is mapped it can be iterated through using FileSystemObject commands and the item titles can be loaded into a two dimensional array.
The code will have to be modified to allow for 3 the listing of subfolders
The location of the file count in the ListMyFiles sub would have to be changed or another dimension would have to be added to the array.
Here is the code - I will try to credit all Stack solutions that were integrated into this answer:
Private Sub List_Files()
Const MY_FILENAME = "C:\BAT.BAT"
Const MY_FILENAME2 = "C:\DELETE.BAT"
Dim i As Integer
Dim FileNumber As Integer
Dim FileNumber2 As Integer
Dim retVal As Variant
Dim DriveLetter As String
Dim TitleArray()
FileNumber = FreeFile
'create batch file
For i = Asc("Z") To Asc("A") Step -1
DriveLetter = Chr(i)
If Not oFSO.DriveExists(DriveLetter) Then
Open MY_FILENAME For Output As #FileNumber
'Use CHR(34) to add escape quotes to the command prompt line
Print #FileNumber, "net use " & DriveLetter & ": " & Chr(34) & "\\sharepoint.site.com#SSL\DavWWWRoot\cybertron\HR\test\the_lab\Shared Documents" & Chr(34) & " > H:\Log.txt"
Close #FileNumber
Exit For
End If
Next i
'run batch file
retVal = Shell(MY_FILENAME, vbNormalFocus)
' NOTE THE BATCH FILE WILL RUN, BUT THE CODE WILL CONTINUE TO RUN.
'This area can be used to evaluate return values from the bat file
If retVal = 0 Then
MsgBox "An Error Occured"
Close #FileNumber
End
End If
'This calls a function that will return the array of item titles and other metadata
ListMyFiles DriveLetter & ":\", False, TitleArray()
'Create code here to work with the data contained in TitleArray()
'Now remove the network drive and delete the bat files
FileNumber2 = FreeFile
Open MY_FILENAME2 For Output As #FileNumber2
Print #FileNumber2, "net use " & DriveLetter & ": /delete > H:\Log2.txt"
Close #FileNumber2
retVal = Shell(MY_FILENAME2, vbNormalFocus)
'Delete batch file
Kill MY_FILENAME
Kill MY_FILENAME2
End Sub
Here is the function that will read through the directory and return the array of file information:
Sub ListMyFiles(mySourcePath As String, IncludeSubFolders As Boolean, TitleArray())
Dim MyObject As Object
Dim mySource As Object
Dim myFile As File
Dim mySubFolder As folder
Dim FileCount As Integer
Dim CurrentFile As Integer
'Dim TitleArray()
Dim PropertyCount As Integer
CurrentFile = 0
Set MyObject = New Scripting.FileSystemObject
Set mySource = MyObject.GetFolder(mySourcePath)
FileCount = mySource.Files.Count
ReDim TitleArray(0 To FileCount - 1, 4)
'On Error Resume Next
For Each myFile In mySource.Files
PropertyCount = 1
TitleArray(CurrentFile, PropertyCount) = myFile.Path
PropertyCount = PropertyCount + 1
TitleArray(CurrentFile, PropertyCount) = myFile.Name
PropertyCount = PropertyCount + 1
TitleArray(CurrentFile, PropertyCount) = myFile.Size
PropertyCount = PropertyCount + 1
TitleArray(CurrentFile, PropertyCount) = myFile.DateLastModified
CurrentFile = CurrentFile + 1
Next
'The current status of this code does not support subfolders.
'An additional dimension or a different counting method would have to be used
If IncludeSubFolders = True Then
For Each mySubFolder In mySource.SubFolders
Call ListMyFiles(mySubFolder.Path, True, TitleArray())
Next
End If
End Sub
Thank you to Chris Hayes for his answer to find empty network drives; thank you to Kenneth Hobson on ozgrid for his expanded answer on listing files in a directory. The rest of the code is ancient and I dredged it out of a folder I last touched in 2010.

VBScript - How to make program wait until process has finished?

I have a problem in a VBScript that I am using with a VBA/Excel macro and a HTA. The problem is just the VBScript, I have the other two components, i.e. the VBA macro and HTA front-end working perfectly. But before I explain the problem, I think for you to help me I must help you understand the context of the VBScript.
So, basically all components (VBScript, VBA macro and HTA) are parts of a tool that I am building to automate some manual chores. It pretty much goes like this:
A - HTA
~~~~~~~~~~~~
User selects some files from the HTA/GUI.
Within the HTML of the HTA there is some VBScript within the "SCRIPT" tags which passes the users 4 input files as arguments to a VBScript (executed by WScript.exe - you may refer to note #1 for clarity here)
The script, lets call it myScript.vbs from now on then handles the 4 arguments, 3 of which are specific files and the 4th is a path/folder location that has multiple files in it - (also see note #2 for clarity)
B - myScript.vbs
~~~~~~~~~~~~
myScript.vbs opens up the first 3 arguments which are Excel files. One of them is a *.xlsm file that has my VBA macro.
myScript.vbs then uses the 4th argument which is a PATH to a folder that contains multiple files and assigns that to a variable for passing to a FileSystemObject object when calling GetFolder, i.e.
... 'Other code here, irrelevant for this post
Dim FSO, FLD, strFolder
... 'Other code here, irrelevant for this post
arg4 = args.Item(3)
strFolder = arg4
Set FSO = CreateObject("Scripting.FileSystemObject"
'Get a reference to the folder you want to search
Set FLD = FSO.GetFolder(strFolder)
...
From here I create a loop so that I can sequentially open the files within the folder
and then run my macro, i.e.
...
Dim strWB4, strMyMacro
strMyMacro = "Sheet1.my_macro_name"
'loop through the folder and get the file names
For Each Fil In FLD.Files
Set x4WB = x1.Workbooks.Open(Fil)
x4WB.Application.Visible = True
x1.Run strMyMacro
x4WB.close
Next
...
Please note that when the first 3 Excel files have opened (controlled by code prior to the loop, and not shown here as I am having no problem with that part) I must keep them open.
It is the files in the folder (that was passed as the 4th argument) which must sequentially open and close. But inbetween opening and closing, I require the VBA/macro (wrote in one of the 3 Excel files previously opened) to run each time the loop iterates and opens a new file from the folder (I hope you follow - if not please let me know :) ).
The problem I am having is that the files in the folder open and close, open and close, n number of times (n = # of files in folder, naturally) without waiting for the macro to run. This is not what I want. I have tried the WScript.sleep statement with a 10 second delay after the 'x1.Run strMyMacro' statement, but to no avail.
Any ideas?
Thanks,
QF.
NOTES:
1 - For simplicity/clarity this is how:
strCMD = cmd /c C:\windows\system32\wscript.exe myScript.vbs <arg1> <arg2> <arg3> <arg4>
'FYI - This is run by creating a WShell object, wsObj, and using the .run method, i.e. WShell.run(strCMD)
2 The HTA employs a piece of JavaScript that strips the users 4th input file (HTML: INPUT TYPE="file") and passes that to the the VBScript within the HTA. This gets me round the problem of not being able to exclusively select a FOLDER in HTML.
You need to tell the run to wait until the process is finished. Something like:
const DontWaitUntilFinished = false, ShowWindow = 1, DontShowWindow = 0, WaitUntilFinished = true
set oShell = WScript.CreateObject("WScript.Shell")
command = "cmd /c C:\windows\system32\wscript.exe <path>\myScript.vbs " & args
oShell.Run command, DontShowWindow, WaitUntilFinished
In the script itself, start Excel like so. While debugging start visible:
File = "c:\test\myfile.xls"
oShell.run """C:\Program Files\Microsoft Office\Office14\EXCEL.EXE"" " & File, 1, true
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2:Win32_Process")
objWMIService.Create "notepad.exe", null, null, intProcessID
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colMonitoredProcesses = objWMIService.ExecNotificationQuery _
("Select * From __InstanceDeletionEvent Within 1 Where TargetInstance ISA 'Win32_Process'")
Do Until i = 1
Set objLatestProcess = colMonitoredProcesses.NextEvent
If objLatestProcess.TargetInstance.ProcessID = intProcessID Then
i = 1
End If
Loop
Wscript.Echo "Notepad has been terminated."
This may not specifically answer your long 3 part question but this thread is old and I found this while searching today. Here is one shorter way to: "Wait until a process has finished." If you know the name of the process such as "EXCEL.EXE"
strProcess = "EXCEL.EXE"
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colProcesses = objWMIService.ExecQuery ("Select * from Win32_Process Where Name = '"& strProcess &"'")
Do While colProcesses.Count > 0
Set colProcesses = objWMIService.ExecQuery ("Select * from Win32_Process Where Name = '"& strProcess &"'")
Wscript.Sleep(1000) 'Sleep 1 second
'msgbox colProcesses.count 'optional to show the loop works
Loop
Credit to: http://crimsonshift.com/scripting-check-if-process-or-program-is-running-and-start-it/
Probably something like this? (UNTESTED)
Sub Sample()
Dim strWB4, strMyMacro
strMyMacro = "Sheet1.my_macro_name"
'
'~~> Rest of Code
'
'loop through the folder and get the file names
For Each Fil In FLD.Files
Set x4WB = x1.Workbooks.Open(Fil)
x4WB.Application.Visible = True
x1.Run strMyMacro
x4WB.Close
Do Until IsWorkBookOpen(Fil) = False
DoEvents
Loop
Next
'
'~~> Rest of Code
'
End Sub
'~~> Function to check if the file is open
Function IsWorkBookOpen(FileName As String)
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNo
End Select
End Function

Source control of Excel VBA code modules

I'd like to be able to source control my Excel spreadsheet's VBA modules (currently using Excel 2003 SP3) so that I can share and manage the code used by a bunch of different spreadsheets - and therefore I'd like to re-load them from files when the spreadsheet is opened.
I've got a module called Loader.bas, that I use to do most of the donkey work (loading and unloading any other modules that are required) - and I'd like to be able to load it up from a file as soon as the spreadsheet is opened.
I've attached the following code to the Workbook_Open event (in the ThisWorkbook class).
Private Sub Workbook_Open()
Call RemoveLoader
Call LoadLoader
End Sub
Where RemoveLoader (also within the ThisWorkbook class) contains the following code:
Private Sub RemoveLoader()
Dim y As Integer
Dim OldModules, NumModules As Integer
Dim CompName As String
With ThisWorkbook.VBProject
NumModules = ThisWorkbook.VBProject.VBComponents.Count
y = 1
While y <= NumModules
If .VBComponents.Item(y).Type = 1 Then
CompName = .VBComponents.Item(y).Name
If VBA.Strings.InStr(CompName, "Loader") > 0 Then
OldModules = ThisWorkbook.VBProject.VBComponents.Count
.VBComponents.Remove .VBComponents(CompName)
NumModules = ThisWorkbook.VBProject.VBComponents.Count
If OldModules - NumModules = 1 Then
y = 1
Else
MsgBox ("Failed to remove " & CompName & " module from VBA project")
End If
End If
End If
y = y + 1
Wend
End With
End Sub
Which is probably a bit overcomplicated and slightly crude - but I'm trying everything I can find to get it to load the external module!
Often, when I open the spreadsheet, the RemoveLoader function finds that there's a "Loader1" module already included in the VBA project that it is unable to remove, and it also fails to load the new Loader module from the file.
Any ideas if what I'm trying to do is possible? Excel seems very fond of appending a 1 to these module names - either when loading or removing (I'm not sure which).
There is an excellent solution to the vba version control problem here: https://github.com/hilkoc/vbaDeveloper
The nice part about this is that it exports your code automatically, as soon as you save your workbook. Also, when you open a workbook, it imports the code.
You don't need to run any build scripts or maven commands and you don't need to make any changes to your workbooks. It works for all.
It has also solved the import problem where modules such as ModName are being imported as ModName1 into a duplicate module. The importing works as it should, even when doing it multiple times.
As a bonus, it comes with a simple code formatter, that allows you to format your vba code as you write it within the VBA Editor.
Look at the VBAMaven page. I have a homegrown solution that uses the same concepts. I have a common library with a bunch of source code, an ant build and an 'import' VB script. Ant controls the build, which takes a blank excel file and pushes the needed code into it. #Mike is absolutely correct - any duplicate module definitions will automatically have a number appended to the module name. Also, class modules (as in Sheet and ThisWorkbook) classes require special treatment. You can't create those modules, you have to read the input file and write the buffer into the appropriate module. This is the VB script I currently use to do this. The section containing # delimited text (i.e. #build file#) are placeholders - the ant build replaces these tags with meaningful content. It's not perfect, but works for me.
''
' Imports VB Basic module and class files from the src folder
' into the excel file stored in the bin folder.
'
Option Explicit
Dim pFileSystem, pFolder, pPath
Dim pShell
Dim pApp, book
Dim pFileName
pFileName = "#build file#"
Set pFileSystem = CreateObject("Scripting.FileSystemObject")
Set pShell = CreateObject("WScript.Shell")
pPath = pShell.CurrentDirectory
If IsExcelFile (pFileName) Then
Set pApp = WScript.CreateObject ("Excel.Application")
pApp.Visible = False
Set book = pApp.Workbooks.Open(pPath & "\build\" & pFileName)
Else
Set pApp = WScript.CreateObject ("Word.Application")
pApp.Visible = False
Set book = pApp.Documents.Open(pPath & "\build\" & pFileName)
End If
'Include root source folder code if no args set
If Wscript.Arguments.Count = 0 Then
Set pFolder = pFileSystem.GetFolder(pPath & "\src")
ImportFiles pFolder, book
'
' Get selected modules from the Common Library, if any
#common path##common file#
Else
'Add code from subdirectories of src . . .
If Wscript.Arguments(0) <> "" Then
Set pFolder = pFileSystem.GetFolder(pPath & "\src\" & Wscript.Arguments(0))
ImportFiles pFolder, book
End If
End If
Set pFolder = Nothing
Set pFileSystem = Nothing
Set pShell = Nothing
If IsExcelFile (pFileName) Then
pApp.ActiveWorkbook.Save
Else
pApp.ActiveDocument.Save
End If
pApp.Quit
Set book = Nothing
Set pApp = Nothing
'' Loops through all the .bas or .cls files in srcFolder
' and calls InsertVBComponent to insert it into the workbook wb.
'
Sub ImportFiles(ByVal srcFolder, ByVal obj)
Dim fileCollection, pFile
Set fileCollection = srcFolder.Files
For Each pFile in fileCollection
If Right(pFile, 3) = "bas _
Or Right(pFile, 3) = "cls _
Or Right(pFile, 3) = "frm Then
InsertVBComponent obj, pFile
End If
Next
Set fileCollection = Nothing
End Sub
'' Inserts the contents of CompFileName as a new component in
' a Workbook or Document object.
'
' If a class file begins with "Sheet", then the code is
' copied into the appropriate code module 1 painful line at a time.
'
' CompFileName must be a valid VBA component (class or module)
Sub InsertVBComponent(ByVal obj, ByVal CompFileName)
Dim t, mName
t = Split(CompFileName, "\")
mName = Split(t(UBound(t)), ".")
If IsSheetCodeModule(mName(0), CompFileName) = True Then
ImportCodeModule obj.VBProject.VBComponents(mName(0)).CodeModule, _
CompFileName
Else
If Not obj Is Nothing Then
obj.VBProject.VBComponents.Import CompFileName
Else
WScript.Echo "Failed to import " & CompFileName
End If
End If
End Sub
''
' Imports the code in the file fName into the workbook object
' referenced by mName.
' #param target destination CodeModule object in the excel file
' #param fName file system file containing code to be imported
Sub ImportCodeModule (ByVal target, ByVal fName)
Dim shtModule, code, buf
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Set buf = fso.OpenTextFile(fName, ForReading, False, TristateUseDefault)
buf.SkipLine
code = buf.ReadAll
target.InsertLines 1, code
Set fso = Nothing
End Sub
''
' Returns true if the code module in the file fName
' appears to be a code module for a worksheet.
Function IsSheetCodeModule (ByVal mName, ByVal fName)
IsSheetCodeModule = False
If mName = "ThisWorkbook" Then
IsSheetCodeModule = False
ElseIf Left(mName, 5) = "Sheet" And _
IsNumeric(Mid (mName, 6, 1)) And _
Right(fName, 3) = "cls Then
IsSheetCodeModule = True
End If
End Function
''
' Returns true if fName has a xls file extension
Function IsExcelFile (ByVal fName)
If Right(fName, 3) = "xls" Then
IsExcelFile = True
Else
IsExcelFile = False
End If
End Function
I've been working on exactly this for months. I think I figured it out.
If the VB Project is trying to remove a module containing something in the call stack, it delays the removal until the call stack pops the module being replaced.
To avoid a module being in the call stack, launch your code with Application.OnTime
Private Sub Workbook_Open()
'WAS: module_library (1)
Application.OnTime (Now + TimeValue("00:00:01")), "load_library_kicker_firstiter"
End Sub
If you are self-healing your code like I am, you'll also have to launch your code that overwrites the 'calling' code with that same strategy.
I did not perform extensive testing yet, I am in total celebration mode, but this gets me extremely close to straightforward 99.9% self-healing code within a standalone .xls file without any other tricks
Usually the "Loader1" thing happens when Excel is asked to import a module and a module already exists with the same name. So if you import "Loader", then load it again and you'll get "Loader1". This would be because Excel doesn't know (or maybe just doesn't care) if it's really the same thing or a new chunk of functionality that just happens have the same module name, so it imports it anyway.
I can't think of a perfect solution, but I think I'd be inclined to try putting the load/unload logic in an add-in - that Workbook_Open thing looks a little vulnerable and having it in all workbooks is going to be a huge pain if the code ever needs to change (never say never). The XLA logic might be more complex (trickier to trap the necessary events, for one thing) but at least it'll only exist in one place.
Can't leave comment to comment
There is an excellent solution to the vba version control problem
here: https://github.com/hilkoc/vbaDeveloper
About saving custom VBAProjects using this XLAM.
Try this in Build.bas:
'===============
Public Sub testImport()
Dim proj_name As String
Dim vbaProject As Object
'proj_name = "VBAProject"
'Set vbaProject = Application.VBE.VBProjects(proj_name)
Set vbaProject = Application.VBE.ActiveVBProject
proj_name = vbaProject.name
Build.importVbaCode vbaProject
End Sub
'===============
Public Sub testExport()
Dim proj_name As String
Dim vbaProject As Object
'proj_name = "VBAProject"
'Set vbaProject = Application.VBE.VBProjects(proj_name)
Set vbaProject = Application.VBE.ActiveVBProject
proj_name = vbaProject.name
Build.exportVbaCode vbaProject
End Sub
'===============
This will export/import Active VBA Project.
The following is an easy-to-implement answer if you don't need to export your VBA code automatically. Just Call the following sub and it will export (as text) the VBA code of the current active workbook in a subfolder named "VC_nameOfTheWorkBook". If your project is a .xlam, you need to temporarily set the IsAddin property to false. Then you can easily add the new subfolder to Git. It is a slight modification of the code found here made by Steve Jansen. For a more complete solution see Ron de Bruin post.
You need to set a reference to "Microsoft Visual Basic For Applications Extensibility 5.3" and to "Microsoft Scripting Runtime" in the VBE Editor.
Public Sub ExportVisualBasicCode()
Const Module = 1
Const ClassModule = 2
Const Form = 3
Const Document = 100
Const Padding = 24
Dim VBComponent As Object
Dim path As String
Dim directory As String
Dim extension As String
Dim fso As New FileSystemObject
directory = ActiveWorkbook.path & "\VC_" & fso.GetBaseName(ActiveWorkbook.Name)
If Not fso.FolderExists(directory) Then
Call fso.CreateFolder(directory)
End If
Set fso = Nothing
For Each VBComponent In ActiveWorkbook.VBProject.VBComponents
Select Case VBComponent.Type
Case ClassModule, Document
extension = ".cls"
Case Form
extension = ".frm"
Case Module
extension = ".bas"
Case Else
extension = ".txt"
End Select
On Error Resume Next
Err.Clear
path = directory & "\" & VBComponent.Name & extension
Call VBComponent.Export(path)
If Err.Number <> 0 Then
Call MsgBox("Failed to export " & VBComponent.Name & " to " & path, vbCritical)
Else
Debug.Print "Exported " & Left$(VBComponent.Name & ":" & Space(Padding), Padding) & path
End If
On Error GoTo 0
Next
End Sub