vbs script upload only the file name without inside data - file-upload

The problem of this script is that it shows an unknown error Message while running the script.
I called the function by echo method in my ftp which is "filezilla".
every thing is working fine as it logs into the server check for the path, open channel for data writing. Still dont know where is the problem
Function FTPUpload(sSite, sUsername, sPassword, sLocalFile, sRemotePath)
'This script is provided under the Creative Commons license located
'at http://creativecommons.org/licenses/by-nc/2.5/ . It may not
'be used for commercial purposes with out the expressed written consent
'of NateRice.com
Const OpenAsDefault = -2
Const FailIfNotExist = 0
Const ForReading = 1
Const ForWriting = 2
Set oFTPScriptFSO = CreateObject("Scripting.FileSystemObject")
Set oFTPScriptShell = CreateObject("WScript.Shell")
sRemotePath = Trim(sRemotePath)
sLocalFile = Trim(sLocalFile)
'----------Path Checks---------
'Here we willcheck the path, if it contains
'spaces then we need to add quotes to ensure
'it parses correctly.
If InStr(sRemotePath, " ") > 0 Then
If Left(sRemotePath, 1) <> """" And Right(sRemotePath, 1) <> """" Then
sRemotePath = """" & sRemotePath & """"
End If
End If
If InStr(sLocalFile, " ") > 0 Then
If Left(sLocalFile, 1) <> """" And Right(sLocalFile, 1) <> """" Then
sLocalFile = """" & sLocalFile & """"
End If
End If
'Check to ensure that a remote path was
'passed. If it's blank then pass a "\"
If Len(sRemotePath) = 0 Then
'Please note that no premptive checking of the
'remote path is done. If it does not exist for some
'reason. Unexpected results may occur.
sRemotePath = "\"
End If
'Check the local path and file to ensure
'that either the a file that exists was
'passed or a wildcard was passed.
If InStr(sLocalFile, "*") Then
If InStr(sLocalFile, " ") Then
FTPUpload = "Error: Wildcard uploads do not work if the path contains a " & _
"space." & vbCRLF
FTPUpload = FTPUpload & "This is a limitation of the Microsoft FTP client."
Exit Function
End If
ElseIf Len(sLocalFile) = 0 Or Not oFTPScriptFSO.FileExists(sLocalFile) Then
'nothing to upload
FTPUpload = "Error: File Not Found."
Exit Function
End If
'--------END Path Checks---------
'build input file for ftp command
sFTPScript = sFTPScript & "USER " & sUsername & vbCRLF
sFTPScript = sFTPScript & sPassword & vbCRLF
sFTPScript = sFTPScript & "cd " & sRemotePath & vbCRLF
sFTPScript = sFTPScript & "binary" & vbCRLF
sFTPScript = sFTPScript & "prompt n" & vbCRLF
sFTPScript = sFTPScript & "put " & sLocalFile & vbCRLF
sFTPScript = sFTPScript & "quit" & vbCRLF & "quit" & vbCRLF & "quit" & vbCRLF
sFTPTemp = oFTPScriptShell.ExpandEnvironmentStrings("%TEMP%")
sFTPTempFile = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
sFTPResults = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
'Write the input file for the ftp command
'to a temporary file.
Set fFTPScript = oFTPScriptFSO.CreateTextFile(sFTPTempFile, True)
fFTPScript.WriteLine(sFTPScript)
fFTPScript.Close
Set fFTPScript = Nothing
oFTPScriptShell.Run "%comspec% /c FTP -n -s:" & sFTPTempFile & " " & sSite & _
" > " & sFTPResults, 0, TRUE
Wscript.Sleep 1000
'Check results of transfer.
Set fFTPResults = oFTPScriptFSO.OpenTextFile(sFTPResults, ForReading, _
FailIfNotExist, OpenAsDefault)
sResults = fFTPResults.ReadAll
fFTPResults.Close
oFTPScriptFSO.DeleteFile(sFTPTempFile)
oFTPScriptFSO.DeleteFile (sFTPResults)
If InStr(sResults, "226 Transfer complete.") > 0 Then
FTPUpload = True
ElseIf InStr(sResults, "File not found") > 0 Then
FTPUpload = "Error: File Not Found"
ElseIf InStr(sResults, "cannot log in.") > 0 Then
FTPUpload = "Error: Login Failed."
Else
FTPUpload = "Error: Unknown."
End If
Set oFTPScriptFSO = Nothing
Set oFTPScriptShell = Nothing
WScript.Echo "Process Completed (" & Now & ")"
End Function

Related

Checking Null Value in Access VBA recordset throws null exception?

I have tried this every different way, and it was working yesterday, so I really don't know what changed.
I import a spreadsheet to a temp table in an Access app. Then I set that to be the dao.recordset, and start looping through. I check for the ID to not be null and if not go through checking fields for values, and updating as appropriate. the minute I hit a null, I get a system error "94 - invalid use of null"
It doesn't offer a debug, but I have debugs throughout my code, so I can see where it fails. It fails when I do this check: If IsNull(rstImportCList("columnx")) = False Then
I have tried nz(rstImportCList("columnx"),"") <> "" I have tried rstImportCList("columnx") is not null, and everything else I can think of. Why is the check that is supposed to prevent this error, causing this error?
Edit:
This is the beginning where I declare the recordset I can't get past doing anything with the recordset field.
Dim db As DAO.Database
Dim rstImportCList As DAO.Recordset
Dim RSsql As String
Set db = CurrentDb()
RSsql = "Select * from tblTempImportCList"
Set rstImportCList = db.OpenRecordset(RSsql)
If rstImportCList.EOF Then Exit Sub
Do While Not rstImportCList.EOF
whether I try to check
IsNull(rstImportCList("xyz").Value) = False
or
nz(rstImportCList("xyz").Value,"") <> ""
or
dim x as string
x = rstImportCList!xyz.value
I get the same error 94 invalid use of null.
Any idea why this is?
--edit with more code.
I took some time to take a the beginning and some of each section of the code, so I could make it generic and see if anyone can help. Here is what I am working on. The Code1 and Code2 parts don't seem to be the issue. Sometimes it fails on a null value in a Yes/No column (I'm just looking for Y but the value is null), sometimes on the notes being null. It's not consistent, which is why I'm having a hard time nailing down the issue.
Private Sub cmdImportList_Click()
On Error GoTo cmdImportExcel_Click_err:
Dim fdObj As FileDialog
Set fdObj = Application.FileDialog(msoFileDialogFilePicker)
Dim varfile As Variant
Dim importCT As Integer
Dim dbu As DAO.Database
Dim cBadXVal, cBadYVal As Integer
Dim preNotes As String
Dim RSsql As String
Dim uNotesql, uVal1sql, uVal2sql As String
Dim db As DAO.Database
Dim rstImportCList As DAO.Recordset
Dim CheckB4Import As Integer
CheckB4Import = MsgBox("Are you SURE the sheet you are importing has the following column names in the same order:" & vbCrLf & vbCrLf & _
"IDName/ First/ Mid/ Last/ Sfx/ Age/ Telephone/ Code1/ Code2/ YN1/ YN2/ NY3/ Notes/ AsYN1edTo" & vbCrLf & vbCrLf & _
"AND that there are NO empty rows or empty columns?" & vbCrLf & vbCrLf & _
"Click OK to proceed, Click CANCEL to go double-check your CallSheet before importing.", vbOKCancel, "WITH GREAT POWER COMES GREAT RESPONSIBILITY TO QC DATA")
If CheckB4Import = vbOK Then
CurrentDb.Execute "DELETE * FROM tblTempImportCList", dbFailOnError
With fdObj
'CAN ONLY SELECT 1 FILE
.allowmultiselect = False
.Filters.Clear
.Filters.Add "Excel 2007+", "*.xlsx"
.Title = "Please select the completed list to import:"
.Show
If .SelectedItems.Count = 1 Then
varfile = .SelectedItems(1)
DoCmd.TransferSpreadsheet acImport, , "tblTempImportCList", varfile, True, "Sheet1!"
cBadXVal = DLookup("BadXCount", "qryImpCheckBadXVal")
Debug.Print "cBadXVal - " & cBadXVal
If cBadXVal <> 0 Then
DoCmd.OpenForm "frmImportError", acNormal
Forms!frmImportError.Form.lblErrorMsg.Caption = _
"Oh No! Your list import failed!" & vbCrLf & _
cBadXVal & " X values are not valid." & vbCrLf & _
"Don't worry. You can fix your sheet and re-import!" & vbCrLf & _
"Would you like to open the documentation for the valid codes" & vbCrLf & _
"Or are you all set?"
End If
cBadYVal = DLookup("BadYCount", "qryImpCheckBadYVal")
Debug.Print "cBadYVal - " & cBadYVal
If cBadYVal <> 0 Then
DoCmd.OpenForm "frmImportError", acNormal
Forms!frmImportError.Form.lblErrorMsg.Caption = _
"Oh No! Your list import failed!" & vbCrLf & _
cBadYVal & " YN1 values are not valid." & vbCrLf & _
"Don't worry. You can fix your sheet and re-import!" & vbCrLf & _
"Would you like to open the documentation for the valid codes" & vbCrLf & _
"Or are you all set?"
Exit Sub
End If
Else
MsgBox "No file was selected. Try again!", vbCritical, "Uh-oh Spaghettios!"
End If
End With
'PASSED CHECKS
Set db = CurrentDb()
RSsql = "Select * from tblTempImportCList"
Set rstImportCList = db.OpenRecordset(RSsql)
If rstImportCList.EOF Then Exit Sub
Debug.Print "got here"
Do While Not rstImportCList.EOF
Debug.Print "Start Processing: " & Nz(rstImportCList("IDName").Value, "")
'GET NOTES ALREADY ON RECORD
If Nz(rstImportCList("IDName").Value, "") <> "" Then
Debug.Print "got past if IDName is not null"
If Nz(rstImportCList("Notes").Value, "") <> "" Then
Debug.Print "got past if notes is not null"
preNotes = Replace(Nz(DLookup("Notes", "tblVFileImport", "IDName = " & rstImportCList("IDName").Value), ""), """", "")
'UPDATE NOTES
If Nz(preNotes, "") <> "" Then
uNotesql = "Update tblVFileImport SET tblVFileImport.Notes = '" & preNotes & "; " & Replace(Nz(rstImportCList("Notes").Value, ""), """", "") & "' " & _
"WHERE tblVFileImport.IDName = " & rstImportCList("IDName").Value
'debug.print "Notes"
'debug.print "uNotesql - " & uNotesql
Else
uNotesql = "Update tblVFileImport SET tblVFileImport.Notes = '" & Replace(Nz(rstImportCList("Notes").Value, ""), """", "") & "' " & _
"WHERE tblVFileImport.IDName = " & rstImportCList("IDName").Value
End If
RunMySql (uNotesql)
'DoCmd.RunSQL (uNotesql), dbFailOnError
End If
If Nz(rstImportCList("YN1").Value, "") = "Y" Then
'UPDATE YN1
uYN1sql = "Update tblVFileImport SET tblVFileImport.YN1 = '" & rstImportCList("YN1") & "', tblVFileImport.callprocessed = 'Y' " & _
"WHERE tblVFileImport.IDName = " & rstImportCList("IDName")
Debug.Print "YN1 = Y or y"
Debug.Print "uYN1sql - " & uYN1sql
RunMySql (uYN1sql)
'DoCmd.RunSQL (uYN1sql), dbFailOnError
End If
If Nz(rstImportCList("YN2").Value, "") = "Y" Then
'UPDATE YN2
uYN2sql = "Update tblVFileImport SET tblVFileImport.YN2 = '" & rstImportCList("YN2") & "', tblVFileImport.callprocessed = 'Y' " & _
"WHERE tblVFileImport.IDName = " & rstImportCList("IDName")
Debug.Print "YN2 = Y or y"
Debug.Print "uYN2sql - " & uYN2sql
RunMySql (uYN2sql)
'DoCmd.RunSQL (uYN2sql), dbFailOnError
End If
'START Code1 PROCESSING
If Nz(rstImportCList("Code1").Value, "") <> "" Then
'Code1 Case abc
vdispo = DLookup("Code1", "tblvFileImport", "IDName = " & rstImportCList("IDName"))
If rstImportCList("Code1") = "ABC" Then
Debug.Print "Dispo Case ABC"
'DELETE RECORD
dMDsql = "DELETE from tblVFileImport " & _
"WHERE tblVFileImport.IDName = " & rstImportCList("IDName")
Debug.Print "dMDsql - " & dMDsql
RunMySql (dMDsql)
'DoCmd.RunSQL (dMDsql), dbFailOnError
'Code1 Case DEF OR GHI OR JKL
ElseIf Nz(rstImportCList("Code1"), "") = "DEF" Or Nz(rstImportCList("Code1"), "") = "GHI" Or Nz(rstImportCList("Code1"), "") = "JKL" Then
Debug.Print "Dispo Case DEF OR GHI OR JKL "
'IF DEF
If rstImportCList("Code1") = "DEF" Then
'IF CELL SAME - UPDATE NULL
ccellsame = DLookup("IDName", "tblVFileImport", "IDName = " & rstImportCList("IDName") & " AND nz(Cell,'') = Phone ")
If ccellsame = rstImportCList("IDName") Then
uCellsql = "Update tblVFileImport SET tblVFileImport.Cell = NULL, tblVFileImport.CellString = NULL, tblVFileImport.mobileflag = NULL " & _
"WHERE tblVFileImport.IDName = " & rstImportCList("IDName")
Debug.Print "uCellsql - " & uCellsql
RunMySql (uCellsql)
'DoCmd.RunSQL (uCellsql), dbFailOnError
End If
End If
End If
End If
End If
Debug.Print "End Processing: " & rstImportCList("IDName")
rstImportCList.MoveNext
Loop
Debug.Print "Finished Looping"
rstImportCList.Close
importCT = DCount("IDName", "tblTempImportCList")
MsgBox importCT & " Records imported for list.", vbOKOnly, "List Processed"
Else
MsgBox "Good Call. Check twice, import once!", vbOKOnly, "Better Safe Than Sorry"
End If
Exit Sub
cmdImportExcel_Click_err:
Select Case Err.Number
Case Else
Call MsgBox(Err.Number & " – " & Err.Description, vbCritical + vbOKOnly, "System Error …")
End Select
End Sub
Any suggestions are greatly appreciated. I'm 1/2 tempted to suck this into a SQL table and just execute a stored procedure. I can get it to work in there, I think.
If IsNull(rstImportCList("columnx").Value) Then
otherwise you're checking if the Field object itself is null.
https://learn.microsoft.com/en-us/office/client-developer/access/desktop-database-reference/field-object-dao#:~:text=To%20refer%20to,Fields(%22name%22)
This is a case where relying on a default property (in this case Value) causes problems.

VBA in ACCESS how "Flag" and "Err05" got declared ?

I do not understand where "Flag and Err05" (at the bottom of the codes)have been declared ? I have searched the entire project and can not found where the two parameters got declared. When I try to use the below codes in another project , i got the error message "Run time error : items not found in this collection " Any answers?
>Private Sub SanityCheck_Click()
>Dim St As String, WrnFlag As Boolean, j As Integer
>Dim RS As Recordset, RS1 As Recordset, i As Integer, WrongRootCauses As String
>Dim Err01 As String, Err02 As String, Err03 As String, Err04 As String
>WrnFlag = False
>If IsNull(Me.FactoryList) Then
> MsgBox "Select valid Factory before proceeding.", vbExclamation
>Else
> St = "SELECT Factory, Step1, Step2, Step3, Step4, DateColumn FROM [tbl >Factory] WHERE Allowed = True and Factory = """ & Me.FactoryList.Value & """"
> Set RS = CurrentDb.OpenRecordset(St, dbOpenSnapshot)
'-- 12NC codes check --
> St = "SELECT Count([" & RS!Step2 & "].PLANT) AS 12NC_chk " & _
>"FROM [" & RS!Step2 & "] " & _
> "WHERE (((Len(Trim(IIf(Left(Trim([12NC_CODE]),3)=""000"",Right>([12NC_CODE],Len([12NC_CODE])-3),[12NC_CODE])))) Not In (0,1,12)));"
' "WHERE (((Len(Trim([12NC_CODE]))) Not In (0,1,12)));"
> Set RS1 = CurrentDb.OpenRecordset(St, dbOpenSnapshot)
>If RS1.BOF And RS1.EOF Then
> Err05 = "+ No 12NC issues found."
>Else
> RS1.MoveFirst
> RS1.MoveLast
> If RS1![12NC_chk] = 0 Then
> Err05 = "+ No 12NC issues found."
> Else
> Err05 = "- " & RS1![12NC_chk] & " Incorrect 12NCs found!"
> WrnFlag = True
> End If
> End If
'--
> If WrnFlag = True Then **Flag** = vbCritical Else **Flag** = vbInformation
> MsgBox RS!Factory & " input data sanity check:" & vbCrLf & vbCrLf & " " & >Err01 & vbCrLf & " " & Err02 & vbCrLf & " " & Err03 & _
> vbCrLf & " " & Err04 & vbCrLf & " " & Err05 & vbCrLf & vbCrLf & IIf>>(WrongRootCauses = "", "", " Unknown ADP Root Cause(s):" & vbCrLf & WrongRootCauses), Flag
> RS.Close
>RS1.Close
>End If
>End Sub
Two posibilities
Unless the file have Option explicit in the top, you are not forced to explicitely declare variables. Which means that Flag and Err05 have indeed never been declared. VBA will just create them on the fly with a Variant type and an initial value of Nothing.
They might be global variables declared outside of any sub in another file. Try right clicking the variable and then click definition in the menu, Access will show you the way.

Can't define f.WriteLine (vbscript)

I want to log my windows updates script, but I get the following error.
800a005b object variable not setline: 28, 1
which refers to:
f.WriteLine 'some text here'
I also tried Dim f.WriteLine and Dim f, neither of which solve my problem.
What should I do to resolve this?
Full code:
set test = CreateObject("Scripting.FileSystemObject")
set f = fso.CreateTextFile(write_to_File,8)
Dim fso
Set fso = WScript.CreateObject("Scripting.Filesystemobject")
Set f = fso.OpenTextFile("C:\output.txt", 2)
f.Close
'End of Script
'ServerSelection values
ssDefault = 0
ssManagedServer = 1
ssWindowsUpdate = 2
ssOthers = 3
strComputer = "." ' Local Computer
'InStr values
intSearchStartChar = 1
dim strTitle
Set updateSession = CreateObject("Microsoft.Update.Session")
Set updateSearcher = updateSession.CreateupdateSearcher()
updateSearcher.ServerSelection = ssWindowsUpdate
Set searchResult = updateSearcher.Search("IsInstalled=0 and Type='Software'")
f.WriteLine "Lijst met beschikbare updates op deze machine:"
For I = 0 To searchResult.Updates.Count-1
Set update = searchResult.Updates.Item(I)
WScript.Echo I + 1 & "> " & update.Title
Next
If searchResult.Updates.Count = 0 Then
f.WriteLine "Er zijn geen updates beschikbaar."
WScript.Quit
End If
f.WriteLine vbCRLF & "Aanmaken lijst met te downloaden updates:"
Set updatesToDownload = CreateObject("Microsoft.Update.UpdateColl")
For I = 0 to searchResult.Updates.Count-1
Set update = searchResult.Updates.Item(I)
addThisUpdate = false
If update.InstallationBehavior.CanRequestUserInput = true Then
WScript.Echo I + 1 & "> skipping: " & update.Title & _
" because it requires user input"
Else
If update.EulaAccepted = false Then
WScript.Echo I + 1 & "> note: " & update.Title & _
" has a license agreement that must be accepted:"
WScript.Echo update.EulaText
update.AcceptEula()
addThisUpdate = false
Else
addThisUpdate = false
End If
End If
If addThisUpdate = true Then
WScript.Echo I + 1 & "> adding: " & update.Title
updatesToDownload.Add(update)
End If
Next
If updatesToDownload.Count = 0 Then
f.WriteLine "All applicable updates were skipped."
WScript.Quit
End If
f.WriteLine vbCRLF & "Downloading updates..."
Set downloader = updateSession.CreateUpdateDownloader()
downloader.Updates = updatesToDownload
downloader.Download()
Set updatesToInstall = CreateObject("Microsoft.Update.UpdateColl")
rebootMayBeRequired = false
f.WriteLine vbCRLF & "Successfully downloaded updates:"
For I = 0 To searchResult.Updates.Count-1
set update = searchResult.Updates.Item(I)
If update.IsDownloaded = true Then
WScript.Echo I + 1 & "> " & update.Title
updatesToInstall.Add(update)
If update.InstallationBehavior.RebootBehavior > 0 Then
rebootMayBeRequired = true
End If
End If
Next
If updatesToInstall.Count = 0 Then
f.WriteLine "No updates were successfully downloaded."
WScript.Quit
End If
If rebootMayBeRequired = true Then
f.WriteLine vbCRLF & "These updates may require a reboot."
End If
f.WriteLine "Installing updates..."
Set installer = updateSession.CreateUpdateInstaller()
installer.Updates = updatesToInstall
Set installationResult = installer.Install()
'Output results of install
f.WriteLine "Installation Result: " & _
installationResult.ResultCode
f.WriteLine "Reboot Required: " & _
installationResult.RebootRequired & vbCRLF
f.WriteLine "Listing of updates installed " & _
"and individual installation results:"
For I = 0 to updatesToInstall.Count - 1
WScript.Echo I + 1 & "> " & _
updatesToInstall.Item(i).Title & _
": " & installationResult.GetUpdateResult(i).ResultCode
Next
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate,(Shutdown)}!\\" & _
strComputer & "\root\cimv2")
Set colOS = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
For Each objOS in colOS
objOS.Reboot()
Next
This code should enable you to use writeline, my example is to a log file
Firstly set test to be a "Scripting.FileSystemObject"
Next set your f to equal test and test points to a log file location (write_to_file), and append to it using value 8
Finally use the f.writeline line to write strings to the log file
set test = CreateObject("Scripting.FileSystemObject")
set f = test.OpenTextFile(write_to_File,8)
f.writeline "Some text here"

Monitor Drive. Using VB Script

I want to monitor a drive for file changes, using VBScript. I have the below code. It works fine for InstanceCreationEvent and InstanceDeletionEvent. But InstanceModificationEvent is not happening. From googling I got to know we need to use CIM_DataFile instead of CIM_DirectoryContainsFile to monitor InstanceModificationEvent. I am not sure how to modify the code. Can anyone help.
FYI: One script should monitor all the folders and subfolders in a drive.
PS: Any suggestion to improve the code and performance or other ideas also welcome.
My Code:
Dim arrFolders
Dim strComputer
Dim objWMIService
Dim strFolder
Dim strCommand
Dim i
Dim strQuery
strChangeFile = "MonitorFolder_Log.txt"
strMailIDFile = "MonitorFolder_MailIDs.txt"
'Check if the log file exists, if not ceate a new file and exit the script. Restart the script again.
Set oFSO = CreateObject("Scripting.FileSystemObject")
If not oFSO.FileExists(strChangeFile) then
'WScript.Echo "Change Log File Not Found. Creating new file..."
Set oTxtFile = oFSO.CreateTextFile(strChangeFile)
WScript.Echo strChangeFile & " File Created." & vbCrLf & "Please restart the script." & vbCrLf
WScript.Quit
End If
'Prompt for which drive should be monitored. If not a valid drive, then exit the script.
strDrive = InputBox("Enter the drive to monitor: " & vbCrLf & "E.g.: Input C to monitor C:\ drive.", "Monitor Folder - Oracle", "E")
If strDrive = "" then
WScript.Echo "Not a valid drive. Terminating the script."
WScript.Quit
End If
'Append ":" with the drive name.
strDrive = strDrive & ":"
'Read the mail IDs.
Set objFSOMailID = CreateObject("Scripting.FileSystemObject")
Set oTSMailID = objFSOMailID.OpenTextFile(strMailIDFile)
strMailIDsList = oTSMailID.ReadAll
oTSMailID.close
'WScript.Echo strMailIDsList
'Array to store the existing folder paths that should be monitored.
arrFolders = Array()
i = 0
Set FSO = CreateObject("Scripting.FileSystemObject")
ShowSubfolders FSO.GetFolder(strDrive)
Sub ShowSubFolders(Folder)
For Each Subfolder in Folder.SubFolders
i = i + 1
folderPath = "" & Subfolder.Path & ""
folderPath = Replace(folderPath ,"\","\\\\")
ReDim Preserve arrFolders(i)
arrFolders(i) = folderPath
'Wscript.Echo i & " " & arrFolders(i)
ShowSubFolders Subfolder
Next
End Sub
'Set the first path to be the drive.
arrFolders(0) = strDrive & "\\\\"
'Use WMI query to get the file changes.
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
'Loop throught the array of folders setting up the monitor for Each
i = 0
For Each strFolder In arrFolders
'Create the event sink
'WScript.Echo "setup for folder: " & strFolder & vbLf
strCommand = "Set EventSink" & i & " = WScript.CreateObject" & "(""WbemScripting.SWbemSink"", ""SINK" & i & "_"")"
ExecuteGlobal strCommand
'Setup Notification
strQuery = "SELECT * " _
& "FROM __InstanceOperationEvent " _
& "WITHIN 1 " _
& "WHERE Targetinstance ISA 'CIM_DirectoryContainsFile'" _
& " AND TargetInstance.GroupComponent = " & "'Win32_Directory.Name=""" & strFolder & """'"
strCommand = "objWMIservice.ExecNotificationQueryAsync EventSink" & i & ", strQuery"
ExecuteGlobal strCommand
'Create the OnObjectReady Sub
strCommand = "Sub SINK" & i & "_OnObjectReady(objObject, " & "objAsyncContext)" & vbLf _
& " 'Wscript.Echo objObject.TargetInstance.PartComponent" & vbLf _
& " SendNotification(objObject)" & vbLf _
& "End Sub"
'WScript.Echo strCommand
ExecuteGlobal strCommand
i = i + 1
Next
'Wait for events.
WScript.Echo "Waiting for events..."
i = 0
While (True)
Wscript.Sleep(1000)
Wend
Function SendNotification(objObject)
strEventType = objObject.Path_.Class
strPartComp = Split(objObject.TargetInstance.PartComponent, "=")
strFileName = Replace(strPartComp(1), "\\", "\")
WScript.Echo strEventType
WScript.Echo strFileName
'Some more code to send mail and logs...
End Function
Monitoring the entire filesystem for file creation is not feasible. It will eat up system resources and might severly affect system operation. Only ever monitor selected folders. The following should work:
Const Interval = 1
Set monitor = CreateMonitor("C:\foo")
Do
Set evt = monitor.NextEvent()
Select Case evt.Path_.Class
Case "__InstanceCreationEvent" : SendNotification evt.TargetInstance
Case "__InstanceModificationEvent" : ...
Case "__InstanceDeletionEvent" : ...
End Select
Loop
Function CreateMonitor(path)
Set wmi = GetObject("winmgmts://./root/cimv2")
Set fso = CreateObject("Scripting.FileSystemObject")
path = Split(fso.GetAbsolutePathName(path), ":")
drv = path(0) & ":"
dir = Replace(path(1), "\", "\\")
If Right(dir, 2) <> "\\" Then dir = dir & "\\"
query = "SELECT * FROM __InstanceOperationEvent" & _
" WITHIN " & Interval & _
" WHERE Targetinstance ISA 'CIM_DataFile'" & _
" AND TargetInstance.Drive='" & drv & "'" & _
" AND TargetInstance.Path='" & dir & "'"
Set CreateMonitor = wmi.ExecNotificationQuery(query)
End Function
Sub SendNotification(tgtInst)
'send notification
End Sub
You should run monitors for different folders as separate processes, because NextEvent() is a blocking operation.

Subscript out of range error in vbs script

I'm trying to move my entire User folder in Vista to a non-system partition. To do so with a minimum hassle I'm following the directions provided at Ben's Blog, specifically the vbs script he provides. However executing the script throws up an error which I can't resolve myself. Here's the vbs code followed by the text file it calls on, and finally my error message. Can someone help me correct the problem? (I really don't know much about VBS, so please write as simple as possible.)
VBS Code:
'# Perform dir /a c:\users > c:\dir.txt
'# place this script file in c:\ too
'# double click to run it
'# run resulting script.bat from recovery mode
repprefix = " Directory of..." ' Modify to your language
sourcedrive = "C:\"
targetdrive = "D:\"
altsourcedrive = "C:\" 'leave same as target drive unless otherwise indicated
alttargetdrive = "E:\" 'leave same as target drive unless otherwise indicated
inname = "dir.txt"
outname = "script.bat"
userroot = "Users"
set fso = CreateObject("Scripting.FileSystemObject")
' construct batch commands for saving rights, then link, the recreating rights
Function GetCommand(curroot, line, typ, keyword)
' first need to get source and target
pos = Instr(line, keyword) + Len(keyword)
tuple = Trim(Mid(line, pos))
arr = Split(tuple, "[")
oldtarget = Replace(arr(1), "]", "")
oldlink = curroot & "\" & Trim(arr(0))
' need to determine if we are pointing back to old disk
newlink = replace(oldlink, sourcedrive, targetdrive)
if(Instr(oldtarget, sourcedrive & userroot)) then
newtarget = Replace(oldtarget, sourcedrive, targetdrive)
else
newtarget = oldtarget ' still pointing to original target
end if
' comment
out = "echo " & newlink & " --- " & newtarget & vbCrLf
' save permissions
out = out & "icacls """ & replace(oldlink, sourcedrive, altsourcedrive) & """ /L /save " & altsourcedrive & "permissions.txt" & vbCrLf
' create link
newlink = replace(newlink, targetdrive, alttargetdrive)
if typ = "junction" then
out = out & "mklink /j """ & newlink & """ """ & newtarget & """" & vbCrLf
else ' typ = "symlink"
out = out & "mklink /d """ & newlink & """ """ & newtarget & """" & vbCrLf
end if
'set hidden attribute
out = out & "attrib +h """ & newlink & """ /L" & vbCrLf
' apply permissions
shortlink = Left(newlink, InstrRev(newlink, "\") - 1) 'icacls works strangely - non-orthogonal for restore
out = out & "icacls """ & shortlink & """ /L /restore " & altsourcedrive & "permissions.txt" & vbCrLf
GetCommand = out & vbCrLf
End Function
Sub WriteToFile(file, text)
ForWriting = 2
Create = true
set outfile = fso.OpenTextFile(file, ForWriting, Create)
Call outfile.Write(text)
Call outfile.Close()
End Sub
outtext = "ROBOCOPY " & altsourcedrive & userroot & " " & alttargetdrive & userroot & " /E /COPYALL /XJ" & vbCrLf & vbCrLf
set intext = fso.OpenTextFile(inname)
while not intext.AtEndOfStream
line = intext.ReadLine()
if Instr(line, repprefix) then
curroot = Replace(line, repprefix, "")
elseif Instr(line, juncname) then
outtext = outtext & GetCommand(curroot, line, "junction", juncname)
elseif Instr(line, linkname) then
outtext = outtext & GetCommand(curroot, line, "symlink", linkname)
end if
Wend
outtext = outtext & "icacls " & altsourcedrive & userroot & " /L /save " & altsourcedrive & "permissions.txt" & vbCrLf
outtext = outtext & "ren " & altsourcedrive & userroot & " _" & userroot & vbCrLf
outtext = outtext & "mklink /j " & altsourcedrive & userroot & " " & targetdrive & userroot & vbCrLf
outtext = outtext & "icacls " & altsourcedrive & " /L /restore " & altsourcedrive & "permissions.txt"
Call intext.Close()
Call WriteToFile(outname, outtext)
MsgBox("Done writing to " & outname)
dir.txt:
Volume in drive C is ACER
Volume Serial Number is 08D7-C0CC
Directory of c:\users
07/16/2009 12:29 PM <DIR
07/16/2009 12:29 PM <DIR> ..
11/02/2006 09:02 AM <SYMLINKD> All Users [C:\ProgramData]
11/02/2006 09:02 AM <DIR> Default
11/02/2006 09:02 AM <JUNCTION> Default User [C:\Users\Default]
08/21/2008 08:37 AM 174 desktop.ini
11/02/2006 08:50 AM <DIR> Public
07/19/2009 08:54 PM <DIR> Steve
1 File(s) 174 bytes
7 Dir(s) 5,679,947,776 bytes free
Error Message:
Windows Script Host
Script: C:\userlocationchange.vbs
Line: 25
Char: 2
Error: Subscript out of range: '[number: 1]'
Code: 800A0009
Source: Microsoft VBScript runtime error
The problem is at these lines:
arr = Split(tuple, "[")
oldtarget = Replace(arr(1), "]", "")
I assume that arr(1) is giving the error because arr has only one entry - and since arrays are zero-based in VBS, that entry should be accessed as arr(0).
Hmmm... if there's only one entry, then presumably no "[" was found. The code probably needs to check for that (by testing whether UBound(arr) > 1).
What that means in a wider context - i.e. why there's no "[" I can't say.
EDIT: OK, I took a look at the blog you referred to, and the exact same problem was reported. The blog author replied:
A couple of pointers: look in the txt
file output by the dir command. On my
system, the targets of the symlinks
are shown in square brackets [].
Apparently in your case there aren't
any - in any case that is a hypothesis
that would explain why the script
can't parse out the link targets.
...which pretty much confirms my theory. I suggest you do as he suggests and take a look at the txt file to see if some other character is used.
Note that this isn't really a problem with the script per se - it's just that the script expects some input that it's not getting.
#Gary, I'm the same one who reported the problem on that blog.
I posted the txt file here under the VBS code. My txt file also has the symlink-junction targets within square brackets. Is there anything else I'm missing?