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

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

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

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