I got the code to copy the contents of a website into notepad:
With CreateObject("InternetExplorer.Application")
.Visible = False
.Navigate "https://example.com"
Do Until .ReadyState = 4
Wscript.Sleep 100
Loop
For Each Tag In .Document.GetElementsByTagName("script")
Tag.OuterHtml = ""
Next
For Each Tag In .Document.GetElementsByTagName("noscript")
Tag.OuterHtml = ""
Next
Content = .Document.GetElementsByTagName("body")(0).InnerText
Do While InStr(Content, vbCrLf & vbCrLf)
Content = Replace(Content, vbCrLf & vbCrLf, vbCrLf)
Loop
ShowInNotepad Content
.Quit
End With
Sub ShowInNotepad(Content)
With CreateObject("Scripting.FileSystemObject")
TempPath = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%TEMP%") & "\" & .GetTempName
With .CreateTextFile(TempPath, True, True)
.WriteLine (Content)
.Close
End With
CreateObject("WScript.Shell").Run "notepad.exe " & TempPath, 1, True
.DeleteFile (TempPath)
End With
End Sub
I am stuck with above script to save the text as file.txt.
Please help.
Try something like that :
Option Explicit
Dim LogFile,Ws,Tag,Content
LogFile = Left(Wscript.ScriptFullName,InstrRev(Wscript.ScriptFullName, ".")) & "txt"
Set Ws = CreateObject("wscript.Shell")
With CreateObject("InternetExplorer.Application")
.Visible = False
.Navigate "https://example.com"
Do Until .ReadyState = 4
Wscript.Sleep 100
Loop
For Each Tag In .Document.GetElementsByTagName("script")
Tag.OuterHtml = ""
Next
For Each Tag In .Document.GetElementsByTagName("noscript")
Tag.OuterHtml = ""
Next
Content = .Document.GetElementsByTagName("body")(0).InnerText
Do While InStr(Content, vbCrLf & vbCrLf)
Content = Replace(Content, vbCrLf & vbCrLf, vbCrLf)
Loop
WriteLog Content,LogFile
.Quit
End With
Ws.Run LogFile
'*******************************************************************
Sub WriteLog(strText,LogFile)
Dim fso,ts
Const ForWriting = 2
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.OpenTextFile(LogFile,ForWriting,True,-1)
ts.WriteLine strText
ts.Close
End Sub
'******************************************************************
Related
I need a program the will check a file for a string input from the user and if the string exists then display a message but if it does not exist then add it to the list.
Here is what I have so far:
Const ForReading = 1
Dim strSearchFor
strSearchFor = inputbox("What is the url of the song?",,"")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile("autoplaylist.txt", ForAppending)
do until objTextFile.AtEndOfStream
strLine = objTextFile.ReadLine()
If InStr(strLine, strSearchFor) <> 0 then
Wscript.Echo "That song is already in the list."
Else
Wscript.Echo "That song was added to end of list."
End If
loop
objTextFile.Close
But I'm not sure how to add text to the file.
Also it displays a message every single line, there are like 3000 lines. Is there any way to fix this too?
How about this...
Const ForReading = 1
Const ForAppending = 8
Dim strSearchFor, strFileText, strFileName
strSearchFor = inputbox("What is the url of the song?",,"")
Set objFSO = CreateObject("Scripting.FileSystemObject")
strFileName = "autoplaylist.txt"
' Check file exists and ReadAll
' ------------------------------
If objFSO.FileExists(strFileName) Then
On Error Resume Next
With objFSO.OpenTextFile(strFileName, ForReading)
strFileText = .ReadAll
.Close
End With
If Err.Number <> 0 Then
WScript.Echo "File access error"
WScript.Quit
End If
On Error Goto 0
Else
Wscript.Echo "File does not exists"
Wscript.Quit
End If
' Search for input string
' If found append user input
' ----------------------------
If Instr(strFileText, strSearchFor) = 0 Then
With objFSO.OpenTextFile(strFileName, ForAppending)
.WriteLine(strSearchFor)
.Close
End With
Wscript.Echo strSearchFor & " was not found in " & strFileName & " and has been appended"
Else
Wscript.Echo strSearchFor & " has been found in " & strFileName
End If
WScript.Quit
I managed to find this script to use and backup my files, this is a little more complicated then I need it to be.
I do not need to enter a backup path - from and too every time I run it however this is a handy option for other projects but I would like to backup from a set file path and save to a set file path to save time.
The other issue with this script is the Cancel button does not work, this is an issue I have had before and fixed but I cannot remember how to make the Cancel button function.
Option Explicit
Dim objFSO, strSourceFolder, strDestFolder, strExclusion, strPrompt
Set objFSO = CreateObject("Scripting.FileSystemObject")
strSourceFolder = InputBox("Enter the Source directory path you wish to backup")
strDestFolder = InputBox("Enter the Destination directory path you wish to backup your Data to... (C:/Backup, //Backup-Server/Remotebackup")
Wscript.Echo "Click (OK) to start the Backup!"
CopyFolderStructure strSourceFolder, strDestFolder, strExclusion
Function CopyFolderStructure(strSource, strDestination, strExcludedExt)
Const OVER_WRITE_FILES = True
Dim objDir, objFolder, objFiles, strCurExt, intX, arrExt, blnExclude
Set objDir = objFSO.GetFolder(strSource)
If Not objFSO.FolderExists(strDestination & "\" & objDir.Name) Then
objFSO.CreateFolder(strDestination & "\" & objDir.Name)
End If
If Not IsNoData(strExcludedExt) Then
arrExt = Split(strExcludedExt, ",")
blnExclude = False
End If
For Each objFiles In objFSO.GetFolder(strSource).Files
If Not IsNoData(strExcludedExt) Then
strCurExt = objFSO.GetExtensionName(objFiles.Name)
For intX = 0 To UBound(arrExt)
If LCase(strCurExt) = arrExt(intX) Then
blnExclude = True
Exit For
Else
blnExclude = False
End If
Next
If Not blnExclude Then
objFSO.CopyFile strSource & "\" & objFiles.Name, strDestination & "\" & objDir.Name & "\" & objFiles.Name, OVER_WRITE_FILES
End If
Else
objFSO.CopyFile strSource & "\" & objFiles.Name, strDestination & "\" & objDir.Name & "\" & objFiles.Name, OVER_WRITE_FILES
End If
Next
For Each objFolder In objFSO.GetFolder(strSource).SubFolders
CopyFolderStructure objFolder.Path, strDestination & "\" & objDir.Name, strExcludedExt
Next
End Function
Function BrowseForFolderDialogBox(strTitle)
Const WINDOW_HANDLE = 0
Const NO_OPTIONS = &H0001
Dim objShellApp
Dim objFolder
Dim objFldrItem
Dim objPath
Set objShellApp = CreateObject("Shell.Application")
Set objFolder = objShellApp.BrowseForFolder(WINDOW_HANDLE, strTitle , NO_OPTIONS)
If IsNoData(objFolder) Then
WScript.Echo "You choose to cancel. This will stop this script."
Wscript.Quit
Else
Set objFldrItem = objFolder.Self
objPath = objFldrItem.Path
BrowseForFolderDialogBox = objPath
Set objShellApp = Nothing
Set objFolder = Nothing
Set objFldrItem = Nothing
End If
End Function
Function IsNoData(varVal2Check)
On Error Resume Next
If IsNull(varVal2Check) Or IsEmpty(varVal2Check) Then
IsNoData = True
Else
If IsDate(varVal2Check) Then
IsNoData = False
Elseif varVal2Check = "" Then
IsNoData = True
ElseIf Not IsObject(varVal2Check) Then
IsNoData = False
Else
IsNoData = False
End If
End If
End Function
Wscript.Echo "Backup Has Completed Successfully"
Next code snippet could help (see Arguments Property (WScript Object), InputBox Function and MsgBox Function reference). Note that the Echo method behaves differently depending on which WSH engine you are using.
Option Explicit
Dim objFSO, strSourceFolder, strDestFolder, strExclusion, strPrompt
Dim iBut, sRes, sMes, objArgs
sRes = Wscript.ScriptName
sMes = vbCRLF & "(click (Cancel) button to discard)"
Set objArgs = WScript.Arguments
If objArgs.Count > 1 Then
strSourceFolder = objArgs( 0)
strDestFolder = objArgs( 1)
Else
strSourceFolder = "C:/DataToBackup"
strDestFolder = "D:/Backup"
strSourceFolder = InputBox( "Path you wish to backup" & sMes _
, "Source directory", strSourceFolder)
sRes = sRes & vbNewLine & "strSourceFolder """ & strSourceFolder & """"
If strSourceFolder = "" Then
strDestFolder = ""
Else
strDestFolder = InputBox( "Path you wish to backup your Data to" & sMes _
, "Destination directory", strDestFolder)
sRes = sRes & vbNewLine & "strDestFolder """ & strDestFolder & """"
End If
End If
If strDestFolder = "" Then
sRes = sRes & vbNewLine & "Backup Cancelled!"
Wscript.Echo sRes
Wscript.Quit
Else
iBut=MsgBox(sRes & sMes, vbOKCancel + vbQuestion _
, "Click (OK) to start the Backup!")
If iBut <> vbOK Then Wscript.Quit
End If
'''' for debugging only:
Wscript.Quit '''' for debugging only:
'''' for debugging only:
Set objFSO = CreateObject("Scripting.FileSystemObject")
CopyFolderStructure strSourceFolder, strDestFolder, strExclusion
'''''' and so on...
Please advice how changes the current single incoming log file to search multiple files.
Dim strTextToFind, strInputFile, strOutputFile, boolMatchCaseSensitive
Dim objFSO, objInputFile, strFoundText, strLine, objOutputFile
strTextToFind = Inputbox("Enter the text you would like to search for.")
strInputFile = "C:\Users\mmmanima\Desktop\mani\Day_16.txt"
iF YOU CAN NOTICED, IM ONLY ACCESS THE day_16 FILE
strOutputFile = "C:\Users\mmmanima\Desktop\texting As\result.txt"
Set objFSO = CreateObject("Scripting.FilesystemObject")
Const intForReading = 1
Const intForWriting = 2
Const intForAppending = 8
Set objInputFile = objFSO.OpenTextFile(strInputFile, intForReading, False)
Do until objInputFile.atEndOfStream
strLine = objInputFile.ReadLine
If InStr(strLine,strTextToFind) > 0 Then
strFoundText = strLine
If strFoundText <> "" Then
Set objOutputFile = objFSO.OpenTextFile(strOutputFile,intForAppending, True)
objOutputFile.WriteLine strFoundText
objOutputFile.Close
Set objOutputFile = Nothing
End If
End If
loop
objInputFile.Close
Set objInputFile = Nothing
WScript.Quit
VBScript required to search userinput string into the share folder and there is 60 files.
As I believe you want to search through the all files in a particular folder. Then I suggest you to loop you action while all files are read
to do that it's easier to maintain sub or function
pseudo:
var inputFolder = ".\myfolder"
foreach file in the inputFolder
{
inputFile = file
searchIn(inputFile)
}
sub searchIn(inputFile)
{
'do your current works here
}
code:
This part will give you the all file names
Set fso = CreateObject("Scripting.FileSystemObject")
inputFldr = Replace(wscript.scriptfullname,wscript.scriptname,".\")
Set fldr = fso.getFolder(inputFldr)
For Each file In fldr.Files
'call to your function
Next
----------plese aware of typos------
Dim strTextToFind, strInputFile, strOutputFile, boolMatchCaseSensitive
Dim objFSO, objInputFile, strFoundText, strLine, objOutputFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
inputFldr = Replace(wscript.scriptfullname,wscript.scriptname,".\")
Set fldr = objFSO.getFolder(inputFldr)
strTextToFind = Inputbox("Enter the text you would like to search for.")
For Each file In fldr.Files
yourFunctionName(file )
Next
sub yourFunctionName(inputFile)
strInputFile = inputFile
strOutputFile = ".\result.txt"
Const intForReading = 1
Const intForWriting = 2
Const intForAppending = 8
Set objInputFile = objFSO.OpenTextFile(strInputFile, intForReading, False)
Do until objInputFile.atEndOfStream
strLine = objInputFile.ReadLine
If InStr(strLine,strTextToFind) > 0 Then
strFoundText = strLine
If strFoundText <> "" Then
Set objOutputFile = objFSO.OpenTextFile(strOutputFile,intForAppending, True)
objOutputFile.WriteLine strFoundText
objOutputFile.Close
Set objOutputFile = Nothing
End If
End If
loop
objInputFile.Close
Set objInputFile = Nothing
end sub
WScript.echo "done"
WScript.Quit
You can try this vbscript, i added a function BrowseForFolder()
Option Explicit
Dim strTextToFind,inputFldr,strInputFile,strOutputFile,path,fldr
Dim objFSO, objInputFile,strFoundText,strLine,objOutputFile,file,ws
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("wscript.Shell")
path = objFSO.GetParentFolderName(wscript.ScriptFullName)
strOutputFile = path & "\result.txt"
If objFSO.FileExists(strOutputFile) Then
objFSO.DeleteFile(strOutputFile)
End if
inputFldr = BrowseForFolder()
Set fldr = objFSO.getFolder(inputFldr)
strTextToFind = Inputbox("Enter the text you would like to search for it !","Enter the text you would like to search for it !","wscript")
For Each file In fldr.Files
Call Search(file,strTextToFind)
Next
ws.run strOutputFile
'***************************************************************************************************************
Sub Search(inputFile,strTextToFind)
strInputFile = inputFile
Const intForReading = 1
Const intForWriting = 2
Const intForAppending = 8
Set objInputFile = objFSO.OpenTextFile(strInputFile,intForReading, False)
Do until objInputFile.atEndOfStream
strLine = objInputFile.ReadLine
If InStr(strLine,strTextToFind) > 0 Then
strFoundText = strLine
If strFoundText <> "" Then
Set objOutputFile = objFSO.OpenTextFile(strOutputFile,intForAppending, True)
objOutputFile.WriteLine "The Path of file ===> "& DblQuote(strInputFile) & VbCRLF &_
"String found "& DblQuote(strTextToFind) & " ===> "& DblQuote(strFoundText) & VbCRLF & String(100,"*")
objOutputFile.Close
Set objOutputFile = Nothing
End If
End If
loop
objInputFile.Close
Set objInputFile = Nothing
End sub
'***************************************************************************************************************
Function BrowseForFolder()
Dim ws,objFolder,Copyright
Set ws = CreateObject("Shell.Application")
Set objFolder = ws.BrowseForFolder(0,"Choose the folder to search on it ",1,"c:\Programs")
If objFolder Is Nothing Then
Wscript.Quit
End If
BrowseForFolder = objFolder.self.path
end Function
'****************************************************************************************************************
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'*****************************************************
A bit late in the day after such a long time gap to address Mara Raj's problem with Hackoo's script but here it is for any others who may be interested. On starting the script it automatically deletes any existing result.txt file. Should the script subsequently go on to find "no match" it fails to generate a results.txt file as it would normally do if there were a match. The simplest way to correct this is to insert:
If objFSO.FileExists(strOutputFile) Then
else
wscript.echo "No Matches Found"
wscript.Quit
end if
between "next" and "ws.run strOutputFile"
Could someone please suggest the best way to grab the pst file sizes and write them out to the same text file next to the pst path.
Could someone please suggest the best way to grab the pst file sizes and write them out to the same text file next to the pst path.
Dim objNetworkSet, objFSO, objFolder, objShell, objTextFile, objFile, objWMISysEnv,ObjItem, objTextFileUNC
Dim strHomePath, strDirectory, strFile, strText, strComputerName,strDirectoryUNC,strFileUNC
dim colItems
On Error Resume Next
Set objNetwork = CreateObject("WScript.Network")
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
objNS.Logon "Mike", "" , False, True
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set wshShell = WScript.CreateObject("WScript.Shell")
' Setting file names
strDirectory = "C:\Export"
strFile = "\" & ObjNetwork.Username & "-" & ObjNetwork.ComputerName & "-PST-Files.txt"
' Check to see if the file already exists exists
If objFSO.FolderExists(strDirectory) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFolder = objFSO.CreateFolder(strDirectory)
End If
If objFSO.FileExists(strDirectory & strFile) Then
Set objFolder2 = objFSO.GetFolder(strDirectory)
Else
Set objFile = objFSO.CreateTextFile(strDirectory & strFile)
objFile.Close
End If
' OpenTextFile Method needs a Const value
' ForAppending = 8 ForReading = 1, ForWriting = 2
Const ForAppending = 8
' Opening text file
Set objTextFile = objFSO.OpenTextFile(strDirectory & strFile, ForAppending, True)
For Each objFolder2 In objNS.Folders
objTextFile.WriteLine(GetPSTpath(objFolder2.StoreID))
Next
Function GetPSTPath(input)
For i = 1 To Len(input) Step 2
strSubString = Mid(input,i,2)
If Not strSubString = "00" Then strPath = strPath & ChrW("&H" & strSubString)
Next
Select Case True
Case InStr(strPath,":\") > 0
GetPSTPath = Mid(strPath,InStr(strPath,":\")-1)
Case InStr(strPath,"\\") > 0
GetPSTPath = Mid(strPath,InStr(strPath,"\\"))
End Select
End Function
If your GetPSTPath() function is returning the proper paths to the files you seek, and you just want to write the file sizes along with the file paths, you can do this:
For Each objFolder2 In objNS.Folders
' Get the file path...
strPath = GetPSTpath(objFolder2.StoreID)
' Get the file's size...
intSize = objFSO.GetFile(strPath).Size
' Write both pieces of information to the output file...
objTextFile.WriteLine strPath & " = " & intSize
Next
Thanks for your help and suggestions. I came up with the following which grabs the users default Outlook profile launches Outlook, verifies the attached PSTs then outs to file, including username, PST location and size. The .MDC files are excluded which relate to Enterprise Vault local cache.
Dim objNetworkSet, objFSO, objFolder, objShell, objTextFile, objFile, objWMISysEnv,ObjItem, objTextFileUNC
Dim strHomePath, strDirectory, strFile, strText, strComputerName,strDirectoryUNC,strFileUNC
dim colItems
'On Error Resume Next
Set objNetwork = CreateObject("WScript.Network")
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Set WSHShell = WScript.CreateObject("WScript.Shell")
DefaultOutlookProfile = WSHShell.RegRead("HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\DefaultProfile")
'MsgBox("DefaultOutlookProfile: " & DefaultOutlookProfile)
objNS.Logon DefaultOutlookProfile, "", False, True
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Setting file names
strDirectory = "\\NetworkShare\pstlog\"
strFile = ObjNetwork.Username & "-" & ObjNetwork.ComputerName & "-PST-Files.txt"
' Check to see if the file already exists exists
If objFSO.FolderExists(strDirectory) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFolder = objFSO.CreateFolder(strDirectory)
End If
If objFSO.FileExists(strDirectory & strFile) Then
Set objFolder2 = objFSO.GetFolder(strDirectory)
Else
Set objFile = objFSO.CreateTextFile(strDirectory & strFile)
objFile.Close
End If
' OpenTextFile Method needs a Const value
' ForAppending = 8 ForReading = 1, ForWriting = 2
Const ForWriting = 2
' Opening text file
Set objTextFile = objFSO.OpenTextFile(strDirectory & strFile, ForWriting, True)
For Each strNS In objNS.Folders
'objTextFile.WriteLine(GetPSTpath(strNS.StoreID))
strPath2 = GetPSTpath(strNS.StoreID)
'MsgBox("strPath2: " & strPath2)
If Not strPath2 = "" And Not Right(strPath2, 4) = ".mdc" Then
' Get the file's size...
intSize = FormatNumber((objFSO.GetFile(strPath2).Size/1048576), 2) & " MB"
'intSize = intSize/1024 & " MB"
' Write both pieces of information to the output file...
objTextFile.WriteLine(ObjNetwork.Username & ", " & strPath2 & ", " & intSize)
End If
Next
Public Function GetPSTPath(input)
For i = 1 To Len(input) Step 2
strSubString = Mid(input,i,2)
If Not strSubString = "00" Then strPath = strPath & ChrW("&H" & strSubString)
Next
Select Case True
Case InStr(strPath,":\") > 0
GetPSTPath = Mid(strPath,InStr(strPath,":\")-1)
Case InStr(strPath,"\\") > 0
GetPSTPath = Mid(strPath,InStr(strPath,"\\"))
End Select
End Function
If err.number = vbEmpty then
Else WScript.echo "VBScript Error: " & err.number
End If
I am trying to find a specific file on computer and delete it.
This is my code:
Const DeleteReadOnly = True
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oWshShell = CreateObject("WScript.Shell")
sDir = oWshShell.ExpandEnvironmentStrings("%temp%\dir.txt")
sFileName = "\date.vbs"
If oFSO.FileExists(sDir) Then oFSO.DeleteFile(sDir)
For Each oDrive In oFSO.Drives
if oDrive.DriveType = 2 Then Search oDrive.DriveLetter
Next
Set oFile = oFSO.OpenTextFile(sDir, 1)
aNames = Split(oFile.ReadAll, VbCrLf)
oFile.Close
For Each sName In aNames
If InStr(1, sName, sFileName, 1) > 0 Then WScript.Echo sName
Next
dim filesys
Set filesys = CreateObject("Scripting.FileSystemObject")
filesys.CreateTextFile "\date.vbs", True
If filesys.FileExists("\date.vbs") Then
filesys.DeleteFile "\date.vbs"
Wscript.Echo("File deleted")
End If
Sub Search(sDrive)
WScript.Echo "Scanning drive " & sDrive & ":"
oWshShell.Run "cmd /c dir /s /b " & sDrive & ":\" & sName & " >>" & sDir, 0, True
End Sub
The code is working only partially. When the file "date.vbs" is in root folder (C:\date.vbs) then it is deleted but when it is in folder (C:\backup\date.vbs) then it will not be deleted. Do you know which code changes I should make to be able to delete file even when it is not in root but anywhere in computer?
Thank you! V.
UPDATE:
The code is pretty much working right now. I just have a final problem of deleting the file. I am able to change the attributes from Read-only to normal but still i get the error of access denied.
This is my code:
Const DeleteReadOnly = True
Dim oFSO, oDrive, sFileName, ws, WshS, fso, usrProfile, oFolder, skypefolder
Set oFSO = CreateObject("Scripting.FileSystemObject")
sFileName = "Skype.exe"
Set WshS = WScript.CreateObject("WScript.Shell")
usrProfile = WshS.ExpandEnvironmentStrings("%UserProfile%")
skypefolder = "C:\Program Files (x86)\Skype\"
For Each oDrive In oFSO.Drives
If oDrive.DriveType = 2 Then Recurse oFSO.GetFolder(skypefolder)
Next
Sub Recurse(oFolder)
Set oFile = CreateObject("Scripting.FileSystemObject")
Dim oSubFolder, oFile
If IsAccessible(oFolder) Then
For Each oSubFolder In oFolder.SubFolders
Recurse oSubFolder
Next
WScript.Echo oFolder.Path
For Each oFile In oFolder.Files
If oFile.Name = sFileName And oFile.Attributes And 1 Then
oFile.Attributes = 0
oFile.Delete True
End If
Next
End If
End Sub
Function IsAccessible(oFolder)
On Error Resume Next
IsAccessible = oFolder.SubFolders.Count >= 0
End Function
Thank you for help!
Code I use to run the script as ADMIN. After this it started to show the MessageBoxes. Before it was running in a console.
If WScript.Arguments.Named.Exists("elevated") = False Then
CreateObject("Shell.Application").ShellExecute "wscript.exe", """" & WScript.ScriptFullName & """ /elevated", "", "runas", 1
WScript.Quit
Else
Set oShell = CreateObject("WScript.Shell")
oShell.CurrentDirectory = CreateObject("Scripting.FileSystemObject").GetParentFolderName(WScript.ScriptFullName)
'WScript.Echo("Now running with elevated permissions")
End If
So I believe there is something wrong in this code.
Your approach is much too complicated. Use a simple recursive function:
Option Explicit
Const DeleteReadOnly = True
Dim oFSO, oDrive, sFileName
Set oFSO = CreateObject("Scripting.FileSystemObject")
sFileName = "date.vbs"
For Each oDrive In oFSO.Drives
If oDrive.DriveType = 2 Then Recurse oDrive.RootFolder
Next
Sub Recurse(oFolder)
Dim oSubFolder, oFile
If IsAccessible(oFolder) Then
For Each oSubFolder In oFolder.SubFolders
Recurse oSubFolder
Next
For Each oFile In oFolder.Files
If oFile.Name = sFileName Then
'oFile.Delete ' or whatever
End If
Next
End If
End Sub
Function IsAccessible(oFolder)
On Error Resume Next
IsAccessible = oFolder.SubFolders.Count >= 0
End Function
To achieve case-insensitive file name comparison, you could use
If StrComp(oFile.Name, sFileName, vbTextCompare) = 0 Then
As an exercise: You can also use the WMI Service to find certain files. You don't have to go through all folders, you just query the file on any drive, on any folder:
Function find_file(filename)
Dim objWMIService, colItems, objItem, strComputer
strComputer = "."
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM CIM_DataFile WHERE FileName='" & filename & "'",,48)
For Each objItem in colItems
msgbox "Found " & objItem.Name & " in " objItem.Path
Next
End Function
Note: It can take long before the function has returned its results.