Monitor Directory

When programming, I will use what ever languages/Tools required to get the job done, as long you know? that
using native VBA cannot get the job done.

The following question caught my eye in that I thought it would be interesting to look into.

Q. How can you monitor a directory for changes i.e. new file created or deleted, and enter the details into
a spread sheet? (Well not the exact wording but along those lines.)

For this I looked into WMI ( Microsoft have excellent references here)
Normally I would look into APIs, but this looked easier using scripting.

For some downloads and tools I use, look here

The WMI code to monitor a Dir converted to VBA was not viable as there is a performance hit.
Running it as a vb script was called for, this is where scripting comes in handy.

To cut a long story short, yes it did take a while :) and I won’t bore you with the scripting details, look @ above sites.
1) Get user Directory to Monitor – Use Shell32 object
2) Get Events to monitor (WMI) = 3; Create, Delete, Modify (use some Boolean logic to distinguish)
3) Get XL file to put Data into (Late bound COM) .. default ActiveWorkbook
eg script code

    Dim MyExcel
    Set MyExcel = GetObject(" & Chr(34) & strThisWorkBook & Chr(34) & ")"
    With MyExcel.Worksheets(1)
             .Range("
A65536").End(-4162).Offset(1, 0).Value = strchange & FileChange
    End With

:Note use of constants -4162 =XlDown,

4) vbs uses self terminating code if required i.e. no need to Terminate script process.
(Use Filesystem Object & Wscript engine)
5) Create script file (VBA Print#) -> vbs file
6) Run script file (API of course) rather then Shell (See here why )
7) Monitor every (User determined time) seconds
8) I include a Terminating code incase you run this continuously …. should also place in Workbook close Event.

The following code does all the above ……

Open the Windows Task Manger to see the wscript.exe running.
Then try creating a file …. if you monitor continuously and change a files name
the script will report a Deletion AND Creation Event.

Notes:
Tested Xl2000, Xl2003 WinXP Service pack 2, Norton Antivirus 2005
I cannot vouch it will run on other OS configurations.

Would appreciate any feedback concerning this.

Have I missed something ? Let me know

Option Explicit
‘—————————————————————————————
‘ Module    : basCreate
‘ DateTime  : 3/07/2006 22:02
‘ Author    : Ivan F Moala
‘ Purpose   : Monitor a Directory for Creation & Deletion of Files
‘           : Creates the vbs code dynamically, allowing user to select Dir & Time
‘           : Xl File to update to, Run continuous or just once
‘           : NB: Changes in files not working ??
‘           : XL2000 & 2003 OS Win XP Service pack 2
‘—————————————————————————————
Private Declare Function ShellExecute _
        Lib "shell32.dll" _
            Alias "ShellExecuteA" ( _
                ByVal Hwnd As Long, _
                ByVal lpOperation As String, _
                ByVal lpFile As String, _
                ByVal lpParameters As String, _
                ByVal lpDirectory As String, _
                ByVal nShowCmd As Long) _
As Long

Private Const SW_HIDE As Long = 0

Private Const m_cstrVbsFileName As String = "MonitorChangeInDir.vbs"
‘// Script Host
Private Const m_cWsh As String = "wscript.exe"
Private Const m_cCsh As String = "cscript.exe"

Private m_strScriptRunPath As String
‘// DCM

Sub CreateScriptCode()
    Dim intFreeFile As Integer
    Dim blnCont As Boolean
    Dim strTmp As String
    Dim lngRet As Long
    Dim strDirToMonitor As String
    Dim iSecs As Integer
    Dim CreationEvent
    Dim MsgRet As Integer
    Dim vWorkbookToUpDateTo As Variant

    ‘// Get Dir to monitor
   strDirToMonitor = fnBrowseForFolderShell
    If strDirToMonitor = vbNullString Then GoTo UserOptedOut
    strTmp = strDirToMonitor
    ‘// Format is 4 forward slashs
   strDirToMonitor = Replace(strDirToMonitor, "", "\\", 1)

    ‘// What Event do we monitor
   CreationEvent = fnGetEventInput
    If CreationEvent = 0 Then GoTo UserOptedOut
   
    ‘// Get iSecs > specifies that events should be dispatched within iSecs of the actual event occurring.
   iSecs = Application.InputBox("Enter time in secs", "Monitor time for: " & strTmp, 10, Type:=1)
    If iSecs = 0 Then GoTo UserOptedOut

    ‘// Where do we up date this to – XL Workbook
   vWorkbookToUpDateTo = Application.GetOpenFilename(("XL Files (*.xls), *.xls"), , "Select XL File to put Data into")
    ‘// If user cancels then default to ThisWorkBook
   If TypeName(vWorkbookToUpDateTo) = "Boolean" Then vWorkbookToUpDateTo = ThisWorkbook.FullName

    ‘// Run continuous or Once
   MsgRet = MsgBox("Run script Continuous (Yes) or Once (No) Cancel (Cancel)", vbYesNoCancel, "Script to run")
    Select Case MsgRet
        Case vbYes: blnCont = True
        Case vbNo:  blnCont = False
        Case vbCancel: GoTo UserOptedOut
    End Select

    intFreeFile = FreeFile
    m_strScriptRunPath = ThisWorkbook.Path & Application.PathSeparator & m_cstrVbsFileName

    ‘// Open file for output.
   Open m_strScriptRunPath For Output As #intFreeFile

    Print #intFreeFile, "Dim objFSO"
    Print #intFreeFile, "Dim MyExcel"
    Print #intFreeFile, "Dim FileChange"
    Print #intFreeFile, "Dim strChange"
    Print #intFreeFile, "Dim strScript"
    Print #intFreeFile, "Dim strComputer"
    Print #intFreeFile, ""
    Print #intFreeFile, ""

    Print #intFreeFile, "strComputer = ""."""
    Print #intFreeFile, ""
    Print #intFreeFile, "’// Note 4 forward slashes!"

    ‘// Dir to Monitor
   Print #intFreeFile, "strDirToMonitor = " & Chr(34) & strDirToMonitor & Chr(34)
    Print #intFreeFile, ""
    ‘// Monitored every Secs secs
   Print #intFreeFile, "strTime = " & Chr(34) & iSecs & Chr(34)
    Print #intFreeFile, ""

    ‘// Where we place the Data – The Excel workbook = Thisworkbook!
   Print #intFreeFile, "Set MyExcel = GetObject(" & Chr(34) & vWorkbookToUpDateTo & Chr(34) & ")"
    Print #intFreeFile, "Set objWMIService = GetObject(""winmgmts:\"" & strComputer & ""
ootcimv2"
")"
    Print #intFreeFile, ""
    Print #intFreeFile, "Set colMonitoredEvents = objWMIService.ExecNotificationQuery _"
    Print #intFreeFile, "    (""SELECT * FROM __InstanceOperationEvent WITHIN "" & strTime & "" WHERE "" _"
    Print #intFreeFile, "        & ""Targetinstance ISA ‘CIM_DirectoryContainsFile’ and "" _"
    Print #intFreeFile, "            & ""TargetInstance.GroupComponent= "" _"
    Print #intFreeFile, "                & ""’Win32_Directory.Name="" & Chr(34) & strDirToMonitor & Chr(34) & ""’"")"
    Print #intFreeFile, ""
    Print #intFreeFile, "Do While True"
    Print #intFreeFile, "    Set objEventObject = colMonitoredEvents.NextEvent()"
    Print #intFreeFile, ""
    Print #intFreeFile, "    Select Case objEventObject.Path_.Class"
    Print #intFreeFile, ""

    If (CreationEvent And 2) Then
        ‘// Creation Event
       Print #intFreeFile, "        Case ""__InstanceCreationEvent"""
        Print #intFreeFile, "            MsgBox ""A new file was just created: "" & _"
        Print #intFreeFile, "                objEventObject.TargetInstance.PartComponent"
        Print #intFreeFile, "            strChange = " & Chr(34) & "Created:=" & Chr(34)
        ‘// Run continuous or not?
       Print #intFreeFile, "            " & IIf(blnCont, "", "Exit Do")
        Print #intFreeFile, ""
    End If

    If (CreationEvent And 1) Then
        ‘// Deletion Event
       Print #intFreeFile, "        Case ""__InstanceDeletionEvent"""
        Print #intFreeFile, "            MsgBox ""A file was just deleted: "" & _"
        Print #intFreeFile, "                 objEventObject.TargetInstance.PartComponent"
        Print #intFreeFile, "            strChange = " & Chr(34) & "Deleted:=" & Chr(34)
        ‘// Run continuous or not?
       Print #intFreeFile, "            " & IIf(blnCont, "", "Exit Do")
        Print #intFreeFile, ""
    End If

    If (CreationEvent And 4) Then
        ‘// Modification Event > couldn’t get to work
       Print #intFreeFile, "        Case ""__InstanceModificationEvent"""
        Print #intFreeFile, "            MsgBox ""A file was just modified: "" & _"
        Print #intFreeFile, "                 objEventObject.TargetInstance.PartComponent"
        Print #intFreeFile, "            strChange = " & Chr(34) & "Modified:=" & Chr(34)
        ‘// Run continuous or not?
       Print #intFreeFile, "        " & IIf(blnCont, "", "Exit Do")
        Print #intFreeFile, ""
    End If

    Print #intFreeFile, "   End Select"
    Print #intFreeFile, "" & IIf(blnCont, "", "Loop")
    Print #intFreeFile, ""
    ‘//
   ‘// Write the data to a XL Workbook starting @ A2 SheetIndex 1
   ‘//
   ‘Typical format we need to decipher from \IVANPC
ootcimv2:CIM_DataFile.Name="C:\A_BOOK\New Text Document.txt"
   Print #intFreeFile, "    FileChange = StrReverse(objEventObject.TargetInstance.PartComponent)"
    Print #intFreeFile, "    ‘// Get the string to the left of the first and reverse it"
    Print #intFreeFile, "    FileChange = (StrReverse(Left(FileChange, InStr(FileChange, ""\"") – 1)))"
    Print #intFreeFile, "    FileChange = Mid(FileChange, 1, Len(FileChange) – 1)"
    Print #intFreeFile, "    With MyExcel.Worksheets(1)"
    Print #intFreeFile, "         .Range(""A65536"").End(-4162).Offset(1, 0).Value = strchange & FileChange"
    Print #intFreeFile, "    End With"
    ‘// Run continuous or not?
   Print #intFreeFile, "" & IIf(blnCont, "Loop", "")
    ‘// If continuous then we don’t need the self terminating code.
   ‘// Note we DO have the terminating code in the ThisWorkbook_Close routine in case you close down
   If blnCont Then GoTo Xit
    ‘//
   ‘// Self deleting routine – This script DELETES itself after running!
   ‘//
   Print #intFreeFile, "    ‘// Lets delete this script!"
    Print #intFreeFile, "    Set objFSO = CreateObject(" & Chr(34) & "Scripting.FileSystemObject" & Chr(34) & ")"
    Print #intFreeFile, "    strScript = Wscript.ScriptFullName"
    Print #intFreeFile, "    objFSO.DeleteFile (strScript)"
Xit:
    Close intFreeFile

    ‘// Run the script now
   lngRet = ShellExecute(0&, "Open", m_strScriptRunPath, 0&, 0&, SW_HIDE)
    If lngRet < = 32 Then
        MsgBox "Couldn’t Run " & m_strScriptRunPath
    Else
        MsgBox "Script: " & m_strScriptRunPath & " is running now.", vbInformation, "Script status"
    End If

Exit Sub
UserOptedOut:
MsgBox "Script creation cancelled", vbInformation, "Script status"

End Sub

Private Function fnBrowseForFolderShell() As String
    ‘// Cut down version of Browse for Dir
   Dim objShell As Object
    Dim objFolder As Variant
    Dim strFolderFullPath As String

    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "Select a Directory to Monitor", &H20, 0)

    If (Not objFolder Is Nothing) Then
        ‘// NB: If SpecFolder= 0 = Desktop then ….
       On Error Resume Next
        If IsError(objFolder.Items.Item.Path) Then strFolderFullPath = CStr(objFolder): GoTo GotIt
        On Error GoTo 0
        ‘// Is it the Root Dir?…if so change
       If Len(objFolder.Items.Item.Path) > 3 Then
            strFolderFullPath = objFolder.Items.Item.Path
        Else
            strFolderFullPath = objFolder.Items.Item.Path
        End If
    Else
        ‘// User cancelled
       GoTo XitProperly
    End If

GotIt:
    fnBrowseForFolderShell = strFolderFullPath

XitProperly:
    Set objFolder = Nothing
    Set objShell = Nothing

End Function

Function fnGetEventInput() As Byte
‘// Get Event input
   Dim Tmp
    Dim Val As Byte

    Tmp = UCase(Application.InputBox("Event – Enter;" & vbCrLf & vbCrLf & _
            "Enter any combination of letters that represent" & vbCrLf & _
            "any one of the events below" & vbCrLf & _
            "D (Delete), C (Create), M (Modify)", _
            "Event to Monitor for: ", _
            "DCM", _
            Type:=2))

    ‘// Use default ALL
   If Tmp = "False" Then fnGetEventInput = 7: Exit Function

    If InStr(1, Tmp, "D") > 0 Then Val = 1
    If InStr(1, Tmp, "C") > 0 Then Val = Val + 2
    If InStr(1, Tmp, "M") > 0 Then Val = Val + 4

    ‘// Use default ALL
   ‘If Val = 0 Then Val = 7

    ‘MsgBox Val
   ‘MsgBox "1st bit set = " & (Val And 1) & CBool((Val And 1))
   ‘MsgBox "2nd bit set = " & (Val And 2) & CBool((Val And 2))
   ‘MsgBox "3rd bit set = " & (Val And 4) & CBool((Val And 4))

    fnGetEventInput = Val

End Function

Sub TerminateOurRunningScript()
‘—————————————————————————————
‘ Procedure : TerminateOurRunningScript
‘ DateTime  : 3/07/2006 10:58
‘ Author    : Ivan F Moala
‘ Purpose   : See IF OUR Script is running JUST IN CASE there is another script running!
‘           : BEFORE Terminating it.
‘—————————————————————————————
   
    Dim objWMIService As Object
    Dim colItems As Object
    Dim objItem As Object
    Dim Msg As String
   
    On Error Resume Next
    Set objWMIService = GetObject("winmgmts:\" & "." & "
ootCIMV2"
)
    Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", "WQL", 48)

    For Each objItem In colItems
        ‘// The name of the program = "wsscript.exe" or "cscript.exe"
       If objItem.Caption = m_cWsh Or objItem.Caption = m_cCsh Then
            ‘// msg Contains the path of the exercutable script
           Msg = objItem.CommandLine
            MsgBox Msg & vbCrLf & m_strScriptRunPath
            ‘// See if this is OUR SCRIPT
           If InStr(1, Msg, m_strScriptRunPath) > 0 Then
                MsgBox "True"
                objItem.terminate
            End If
        End If
    Next

    Set objWMIService = Nothing
    Set colItems = Nothing

End Sub

Quick Launch Toolbar

Here is a function that will set-up your application in your quick launch bar.
You will need to have this visible in order to view it.

quick launch toolbar

[From MS]
“The Quick Launch toolbar is really an extension of the Start menu. It allows you to
quickly and easily launch applications and specialized utilities right from the taskbar
just by clicking an icon. By default, the Internet Explorer 4.0 installation procedure
places icons on the Quick Launch toolbar that let you launch Internet Explorer and
Outlook Express. In addition, the toolbar contains icons for accessing the desktop and
launching the new Internet Explorer 4.0 Channel Viewer. “

Couple of things to note:

1) When I did this I could have used API’s to get the AppData dir, how ever I found that
WSH also can get this DESPITE the help file (SCRIPT56.CHM) not mentioning it!
It is mention here however “Scripting guide”
In fact I got 17 listings as opposed to helps 16
Just goes to show that you should look deeper :)

2) I only tested it on XP

3) I used Enum, so runs xl2000+

4) The Arguments option is where you should look to enhancing waht you could load up

Option Explicit
‘//—————————————————————————————
‘// Project   : WinXPQuickLaunchToolbar
‘// DateTime  : 28/08/2005 18:22
‘// Author    : Ivan F Moala
‘// Site      : http://www.xcelfiles.com
‘// Purpose   : Add Application EXE to the Quick Launch Toolbar
‘// For OS    : WinXP
‘// Tested    : Tested Xl2000
‘// In        : Path to executable
‘//           :
‘//           :
‘// Out/Return: Quick launch shortcut
‘//—————————————————————————————

Public Enum eWinStyle
    eNormal = 1 ‘// Restores Window to its original size and position.
   eMax = 3    ‘// Displays Window as a maximized window.
   eMin = 7    ‘// Minimizes the Window and activates the next top-level window.
End Enum

Public Enum tHotKey
    tCTRL = 1  ‘// CTRL
   tALT = 2   ‘// ALT
   tSHIFT = 4 ‘// SHIFT
End Enum

Public Function fnCreateQuickLaunchToolBarShortCut( _
    strPathToEXE As String, _
    Optional strLnkName As String, _
    Optional strDescription As String, _
    Optional strArguments As String = vbNullString, _
    Optional strWindowsStyle As eWinStyle, _
    Optional strIconLocation As String, _
    Optional strTargetPath As String = vbNullString, _
    Optional HotKey1 As tHotKey, _
    Optional strHotKeyLetter As String = “”, _
    Optional strWorkingDirectory As String = vbNullString)
   
Dim objShell As Object, objLnk As Object
Dim strLnkPath As String, strAppDataDir As String
Dim strExe As String

Set objShell = CreateObject(“WScript.Shell”)

‘// Prepare the path to the Quick Launch folder
‘// Note: AppData is missing from CHM File help! it is NOT mentioned.
strAppDataDir = objShell.SpecialFolders(“AppData”)
strLnkPath = strAppDataDir & “MicrosoftInternet ExplorerQuick Launch”

‘// Note:If duplicate link name then it replaces it.
‘// set Link name otherwise default to the App Name
If strLnkName = “” Then strLnkName = fnExeName(strPathToEXE)
‘// Set Hot key combination Letter
If HotKey1 > 0 Then
    If strHotKeyLetter = “” Then GoTo NoHotKeyLetter
    strHotKeyLetter = fnGetHotKeyCombString(ByVal HotKey1) & “+” & strHotKeyLetter
End If

‘// Creates the shortcut
Set objLnk = objShell.CreateShortcut(strLnkPath & “” & strLnkName & “.lnk”)

With objLnk
    .TargetPath = strPathToEXE ‘”C:Program FilesMicrosoft OfficeOfficeexcel.exe”
   .WindowStyle = strWindowsStyle ‘1,3,7
   .HotKey = strHotKeyLetter  ‘ eg > “CTRL+ALT+SHIFT+h”
   .WorkingDirectory = strWorkingDirectory ‘”C:ExcelFilesUseful”
   ‘// used 0 index for icon, you can change this IF there are more then 1 and you want to use another.
   .IconLocation = strIconLocation & “,0” ‘”C:Program FilesMicrosoft OfficeOfficeexcel.exe, 0″
   ‘// Note: you could have added the arguments to the Target path with a Space between
   .Arguments = strArguments     ‘Load this up “C:ExcelFilesUseful22.xls”
   .Description = strDescription ‘”My Shortcut to Excel”
   .Save
End With

Set objShell = Nothing
Set objLnk = Nothing

Exit Function
NoHotKeyLetter:
MsgBox “You have NOT defined a hotkey letter!”, vbCritical
End Function

Public Function fnGetHotKeyCombString(ByVal HotKey1 As Integer) As String
‘// Return the HotKey combination
‘// 1=CTRL 2=ALT 4=SHIFT + combinations
Select Case HotKey1
    Case 1
        fnGetHotKeyCombString = “CTRL”
    Case 2
        fnGetHotKeyCombString = “ALT”
    Case 3
        fnGetHotKeyCombString = “CTRL+ALT”
    Case 4
        fnGetHotKeyCombString = “SHIFT”
    Case 5
        fnGetHotKeyCombString = “CTRL+SHIFT”
    Case 6
        fnGetHotKeyCombString = “ALT+SHIFT”
    Case 7
        fnGetHotKeyCombString = “CTRL+ALT+SHIFT”
    Case Else
        fnGetHotKeyCombString = vbNullString
End Select

End Function

Public Function fnExeName(strPath As String) As String
‘// return the Executable name only given the fullpath
Dim vArray As Variant

vArray = Split(strPath, “”)
fnExeName = vArray(UBound(vArray))

End Function

‘// Test routines

Sub Tester1()
‘// Test create launch for Excel
fnCreateQuickLaunchToolBarShortCut _
    Application.Path & “Excel.exe” _
    , “MyExcel”, “This is my version of Excel”, , eMax

End Sub

Sub CreateCab()
‘// Try this !
fnCreateQuickLaunchToolBarShortCut “C:WINDOWSsystem32iexpress.exe”
End Sub

Get Executable path

A while ago I was developing an addin that utilised Winzip and realised that not every one puts the Winzip exe file (or even uses winzip, perhaps opting for another zip utility) in the default setup location, so I needed to come up with a way to get this.
eg on my system the exec file or default application to open it……..
C:Program FilesWinZipWINZIP32.EXE

This is what I came up with ….. I’d be interested in other ways you may have to get the files asscociated exec
program & location, possibly using the Registry, let us all know.

So if you ever need to know the default or current user setup application and location to run a particular document then give this a try.

Just plug in the file extension or the path to a document to get the executable file & location that opens it.

Try plugging in your own to see what you get………….

PROS: Utilises core API so every Win32 OS should be able to run this.
CONS: It gets the ASSOCIATED Application i.e what ever the user has set-up to run a particular file extension
so don’t assume they run the same application as you. i.e if you expect them to be using winzip then
check the associated program before utilising your code that may depend on winzip.

I have left the extraction of the various elements of “Path only” & “Executable only” up to you. There are a number of ways out there to get these elements :)

Option Explicit
‘—————————————————————————————
‘ Module    : basGetExe
‘ DateTime  : 05/12/04 19:18
‘ Author    : Ivan F Moala
‘ Purpose   : Gets the path to the Executable file as defined
‘           : in the associated files Extension
‘—————————————————————————————

Private Declare Function FindExecutable _
    Lib “shell32.dll” _
        Alias “FindExecutableA” ( _
            ByVal lpFile As String, _
            ByVal lpDirectory As String, _
            ByVal lpResult As String) _
As Long

Private Const MAX_PATH = 260

‘//—————————————————————————————
‘// Project    : VBAProject
‘// DateTime   : 05/12/04 21:07
‘// Author     : Ivan F Moala
‘// Site       : http://www.xcelfiles.com
‘// Purpose    : Gets Executable file path
‘// In         : [File extension] OR [Path to File]
‘//            : Note: Path to File doesn’t need to exist
‘//            : as it is just the extension we are after
‘// Out/Return : Short Path notation to executable file
‘—————————————————————————————

Public Function fnGetExePath(strFileExt_OrPathToFile As String) As String
‘// NB: I included Error lines JustInCase !
‘// Take them out + Errh, I used them for debugging
   Dim lRet As Long, strBuffer As String
    Dim strFn As String, strExt As String
    Dim handle As Integer
    Dim Pos As Long
   
    Pos = InStr(1, strFileExt_OrPathToFile, “.”)
    If Pos = 0 Then
        strExt = strFileExt_OrPathToFile
    Else
        strExt = Right(strFileExt_OrPathToFile, Len(strFileExt_OrPathToFile) – Pos)
    End If
   
    strFn = fnTmpFolderLocation & “zTmp.” & strExt
    handle = FreeFile

    On Error GoTo Errh
    ‘// Create a new File to use as our reference
1   Open strFn For Output As #handle
    ‘// Write to File
2   Print #handle, vbNullString
    ‘// Close the File
3   Close #handle
   
    ‘// Create a buffer to hold the string path
4   strBuffer = String(MAX_PATH, 32)
    ‘// Retrieve the name and handle of the executable, associated with this file
5   lRet = FindExecutable(strFn, vbNullString, strBuffer)
6   If lRet > 32 Then
        ‘// Found!
7       fnGetExePath = Application.WorksheetFunction.Clean(strBuffer)
    Else
        ‘// NOT found
8       fnGetExePath = vbNullString
    End If
   
    ‘// Delete the File
9   Kill strFn

Exit Function
Errh:
    fnGetExePath = “An Error occured! “ & ” @Line “ & Erl() & vbCrLf & _
        “ErrNumber “ & Err.Number & “:=” & Err.Description
   
End Function

Function fnTmpFolderLocation() As String
‘//—————————————————————————————
‘// Project   : VBAProject
‘// DateTime  : 05/12/04 21:19
‘// Author    : Ivan F Moala
‘// Site      : http://www.xcelfiles.com
‘// Purpose   : Gets a Temp directory location to work in
‘// In        : None
‘// Out/Return: Temp Directory either Tmp or default Workbook path
‘//—————————————————————————————
Dim Tmp As String, Fso As Object, TFolder As Object

‘// 1st Try getting via Environ
Tmp = Environ(“Tmp”)
If Len(Tmp) <> 0 Then GoTo Xit

‘// NoGo so try FSO
Set Fso = CreateObject(“Scripting.FileSystemObject”)
Set TFolder = Fso.getSpecialFolder(2)
Tmp = TFolder.Path

If Len(Tmp) = 0 Then
    ‘// Still No Go so use This workbooks path
   ‘// as long as it’s saved.
   fnTmpFolderLocation = ThisWorkbook.Path
End If

Set Fso = Nothing
Set TFolder = Nothing

Exit Function
Xit:
fnTmpFolderLocation = Tmp

End Function

Sub Tester()
Dim Msg As String
Dim aExt As Variant
Dim i As Integer
Dim Tmp As String

Const strNoAss As String = “No associated program”

‘// Lets test these file Extensions… try your own
aExt = Array(“hlp”, “.gif”, “hta”, “url”, “Dao350.dll”, “doc”, “.pdf”, “zzzasda”)
i = 0
     
Do Until i > UBound(aExt)
    ‘// Do the job, giving appropriate reply
   Tmp = fnGetExePath(CStr(aExt(i)))
    Tmp = IIf(Tmp <> vbNullString, Tmp, strNoAss)
    ‘// Build str message
   Msg = “The current application associated with File extension:= “
    Msg = Msg & aExt(i) & vbCrLf & vbCrLf
    Msg = Msg & “Is located @” & vbCrLf
    MsgBox Msg & vbCrLf & Tmp, vbInformation, “Exercutable path”
    i = i + 1
Loop

End Sub