Hi I am working on a program that can search your entire C: Drive for a folder with a specific name. My program looks like this so far:
Const startDir = "c:\"
Set oFSO = CreateObject("Scripting.FileSystemObject")
sFileName = "setup.txt"
Set oFolder = oFSO.GetFolder(startDir)
Recurse(oFolder)
Sub Recurse(oFldr)
If IsAccessible(oFolder) Then
For Each oSubFolder In oFldr.SubFolders
Recurse oSubFolder
Next
For Each oFile In oFldr.Files
If LCase(oFile.Name) = sFileName Then WScript.Echo sFileName, "exists."
Next
End If
End Sub
Function IsAccessible(oFolder)
On Error Resume Next
IsAccessible = (oFolder.SubFolders.Count >= 0)
End Function
However when I run this I get an error on line: 10 For Each oSubFolder In oFldr.SubFolders Error: Permission denied. So I added some lines to make the script ask for admin access and it looked like this:
Sub RunAsAdmin()
if WScript.Arguments.length = 0 Then
CreateObject("Shell.Application").ShellExecute "WScript.exe", """" & _
WScript.ScriptFullName & """ AdminArg", "", "runas", 1
WScript.Quit
End If
End Sub : RunAsAdmin()
set owss = createobject("wscript.shell")
owss.run "cmd /k net user administrator /active:yes"
CreateObject("WScript.Shell").Run("C:\Users\alexh\OneDrive\Skrivbord\VBScript\fileSearching.vbs")
However I still got the same message. Anyone got any ideas on whats going on?
Related
I write a VBScript to copy file from E drive to C drive. There are many system files and damaged files in E drive, so when copy these files, the script will stop. Any method to pass or skip these files when the script is running?
the code is to copy all folders from E drive to C drive
Const hd = "E:\"
Const cd = "C:\"
Dim path
Sub GenPath()
path = cd
End Sub
Sub GenFolder()
Set objFso = CreateObject("Scripting.FileSystemObject")
objFso.CreateFolder path
Set objFso = Nothing
End Sub
Set fso=WScript.CreateObject("scripting.filesystemobject")
Set fs=fso.GetFolder("E:\")
Set f=fs.SubFolders
For Each uu In f
Set Ws = WScript.CreateObject("Scripting.filesystemobject")
Ws.CopyFolder uu,path & "\"
For Each uu In f
Set Ws = WScript.CreateObject("Scripting.filesystemobject")
Ws.CopyFolder hd & uu,path1
End If
Next
Becomes
Set Ws = WScript.CreateObject("Scripting.filesystemobject")
On Error Resume Next
For Each uu In f
Ws.CopyFolder uu.path, path1
If err.number <> 0 then err.clear
Next
Plus for an unknown reason you have an End If.
This does the basics but you can work on it to recreate the folder structure (this dumps all files in one folder).
On error resume next
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder("C:\Users\David Candy\Desktop")
fso.createfolder("C:\Users\David Candy\test123")
Folder2 = "C:\Users\David Candy\test123"
For Each thing in f.subfolders
msgbox thing.path
If err.number <> 0 then
msgbox err.description
err.clear
End If
For Each thingy in thing.files
msgbox thingy.path
thingy.copy(Folder2 & "\" & thingy.name)
If err.number <> 0 then
msgbox err.description
err.clear
End If
Next
Next
Only took an extra line and an edit on another line to recreate file structure.
On error resume next
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder("C:\Users\David Candy\Desktop")
fso.createfolder("C:\Users\David Candy\test123")
Folder2 = "C:\Users\David Candy\test123"
Set log = fso.CreateTextFile("c:\logfile.txt")
For Each thing in f.subfolders
fso.createfolder(folder2 & "\" & thing.name)
If err.number <> 0 then
log.writeline thing.path & err.description
err.clear
End If
For Each thingy in thing.files
thingy.copy(Folder2 & "\" & thing.name & "\" & thingy.name)
If err.number <> 0 then
log.writeline thingy.path & err.description
err.clear
End If
Next
Next
I’m trying to determine, whether the user clicked NO in the UAC-prompt and if so to not set up the nul-port.
I'm calling this script form a batch-file, which I'd like to exit, if the user clicked no.
The VBScript:
Option Explicit
Main
Sub Main
Dim oShell, objWMIService, servSpooler, objReg, objShellApp, result
Const PrinterPort = "NUL:"
Const HKLM = &h80000002
If Not WScript.Arguments.Named.Exists("elevate") Then
Set objShellApp = CreateObject("Shell.Application")
objShellApp.ShellExecute WScript.FullName, WScript.ScriptFullName & " /elevate", "", "runas", 0
WScript.Quit
End If
result = isElevated()
If result = True Then
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
set servSpooler = objWMIService.Get("Win32_Service.Name='spooler'")
Set objReg = GetObject("winmgmts:root\default:StdRegProv")
servSpooler.StopService
objReg.SetStringValue HKLM, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Ports", PrinterPort, ""
servSpooler.StartService
Else
WScript.Quit 1
End If
End Sub
Function isElevated
Dim shell, whoami, whoamiOutput, strWhoamiOutput
Set shell = CreateObject("WScript.Shell")
Set whoami = shell.Exec("whoami /groups")
Set whoamiOutput = whoami.StdOut
strWhoamiOutput = whoamiOutput.ReadAll
If InStr(1, strWhoamiOutput, "S-1-16-12288", vbTextCompare) Then
isElevated = True
Else
isElevated = False
End If
End Function
The batch:
cscript "set_port.vbs"
IF ERRORLEVEL 1 (
ECHO FAIL
PAUSE
EXIT
)
Now, I looked at this page:
http://www.robvanderwoude.com/errorlevel.php
and some others and I feel like I tried every possible combination. Probably, I just haven’t had the correct combination yet. Some tips and help would be highly appreciated!
The basic goal: Determine, whether the user clicked NO in the UAC-prompt and then end the VBScript and batch-file.
UPDATE:
Okay, thanks for all the answers so far. I'm pretty certain now it's the script. I use the errorlevel again in the batch-file and there it works just fine now.
As for the VBScript:
In Order to have an error code of let's say 1 when the user clicks NO in the UAC prompt (meaning the current file is not elevated), I need to put it like this:
If result = True Then
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
set servSpooler = objWMIService.Get("Win32_Service.Name='spooler'")
Set objReg = GetObject("winmgmts:root\default:StdRegProv")
servSpooler.StopService
objReg.SetStringValue HKLM, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Ports", PrinterPort, ""
servSpooler.StartService
WScript.Quit(0)
Else
WScript.Quit(1)
End If
But: in the first WScript.Quit after the ShellExecute, I also need to put WScript.Quit(1), right? Because otherwise I never get an error to be passed to errorlevel (or at least not greater than 0).
So:
objShellApp.ShellExecute WScript.FullName, WScript.ScriptFullName & " /elevate", "", "runas", 0
WScript.Quit(1)
The big problen, I guess, is that clicking NO on the UAC promtp doesnt eally cause an error, so I need to put WSCript.Quit(1) there.
OR i do it the other way round and say: WScript.Quit(1) when the user clicked YES and the script is elevated and put WScript.Quit(0) everyhwere else.
However, in the first case I always get errorlevel 1 and in the second case always errorlevel 0.
----------- UPDATE:
My VBScript file looks like this now:
Option Explicit
Main
Sub Main
Dim objShell, objWMIService, servSpooler, objReg, objShellApp, result, oShell
Dim whoami, strWhoamiOutput, whoamiOutput
Const PrinterPort = "NUL:"
Const HKLM = &h80000002
If Not WScript.Arguments.Named.Exists("elevate") Then
Set objShellApp = CreateObject("Shell.Application")
objShellApp.ShellExecute WScript.FullName, WScript.ScriptFullName & " /elevate", "", "runas", 0
WScript.Quit 10
WScript.Echo("Done")
Else
Set oShell = CreateObject("WScript.Shell")
Set whoami = oShell.Exec("whoami /groups")
Set whoamiOutput = whoami.StdOut
strWhoamiOutput = whoamiOutput.ReadAll
If InStr(1, strWhoamiOutput, "S-1-16-12288", vbTextCompare) Then
Wscript.Echo("ADMIN")
WScript.Echo("Port")
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
set servSpooler = objWMIService.Get("Win32_Service.Name='spooler'")
Set objReg = GetObject("winmgmts:root\default:StdRegProv")
servSpooler.StopService
objReg.SetStringValue HKLM, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Ports", PrinterPort, ""
servSpooler.StartService
WScript.Quit 1
End if
WScript.Echo("Done 2")
End If
End Sub
And a test batch:
#echo off
cscript "test.vbs"
ECHO %errorlevel%
PAUSE
The errorlevel output is 10 and not 1, although the script is quit as intended and the message "Done" is never shown.
Debugging technique:
Write a VBS script that just sets the errorlevel and quits - and get that working with your batch script.
Then you can massage your full vbs script.
I'm new to VBScripting and have completely no knowledge on how to code but however i understand the basics of VBScripting.
I tried using the search function to find similar cases to mine but it doesn't have what i need.
I would really appreciate any help as my project is due soon.
Scenario:
I need to delete jpeg files that are more than 3months old that is in a directory with lots and lots of subfolders within each other. Furthermore there are 4 folders in the directory that i must not delete or modify.
How i manually did it was to navigate to the mapped drive, to the folder, use the "Search 'Folder'" from the window and type in this "datemodified:2006-01-01 .. 2013-08-31".
It will then show all the folders and subfolders and excel sheets within that folder, i'll then filter the shown list by ticking jpeg only from Type.
Code:
'**** Start of Code **********
Option Explicit
On Error Resume Next
Dim oFSO, oFolder, sDirectoryPath
Dim oFileCollection, oFile, sDir
Dim iDaysOld
' Specify Directory Path From Where You want to clear the old files
sDirectoryPath = "C:\MyFolder"
' Specify Number of Days Old File to Delete
iDaysOld = 15
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sDirectoryPath)
Set oFileCollection = oFolder.Files
For each oFile in oFileCollection
'This section will filter the log file as I have used for for test case
'Specify the Extension of file that you want to delete
'and the number with Number of character in the file extension
If LCase(Right(Cstr(oFile.Name), 4)) = "jpeg" Then
If oFile.DateLastModified < (Date() - iDaysOld) Then
oFile.Delete(True)
End If
End If
Next
Set oFSO = Nothing
enter code here`Set oFolder = Nothing
enter code here`Set oFileCollection = Nothing
enter code here`Set oFile = Nothing
'******* End of Code **********
I need to set an path that must be excluded + go through sub folders.
I'd like to thank you in advance for helping me out.
Thanks,
Working solution (Jobbo almost got it to work in generic form):
UPDATE: includes log file writing with number of folders skipped and files deleted.
Option Explicit
'set these constants to your requirements
Const DIR = "C:\Test"
Const LOGFILE = "C:\Log.txt" ' Location of Log file
Const MAX_AGE = 3 ' Unit: Months
Const FILEEXT = "jpeg"
Dim oFSO
Dim oLogFile
Dim aExclude
Dim lngDeletes, lngSkips
'add to this array to exclude paths
aExclude = Array("c:\Test\test 1", "c:\Test\test 2\test")
Set oFSO = CreateObject("Scripting.FilesystemObject")
Set oLogFile = oFSO.createtextfile(LOGFILE)
lngDeletes = 0
lngSkips = 0
LOGG "Script Start time: " & Now
LOGG "Root Folder: " & DIR
LOGG String(50, "-")
deleteFiles oFSO.GetFolder(DIR)
LOGG String(50, "-")
LOGG lngDeletes & " files are deleted"
LOGG lngSkips & " folders skipped"
LOGG "Script End time: " & Now
oLogFile.Close
Set oLogFile = Nothing
Set oFSO = Nothing
MsgBox "Logfile: """ & LOGFILE & """", vbInformation, wscript.scriptName & " Completed at " & Now
wscript.Quit
'=================================
Sub LOGG(sText)
oLogFile.writeline sText
End Sub
'=================================
Function isExclude(sPath)
Dim s, bAns
bAns = False
For Each s In aExclude
If InStr(1, sPath, s, vbTextCompare) = 1 Then
bAns = True
Exit For
End If
Next
isExclude = bAns
End Function
'=================================
Function isOldFile(fFile)
' Old file if "MAX_AGE" months before today is greater than the file modification time
isOldFile = (DateAdd("m", -MAX_AGE, Date) > fFile.DateLastModified)
End Function
'==================================
Function isFileJPEG(fFile)
Dim sFileName
sFileName = fFile.Name
' Mid(sFileName, InStrRev(sFileName, ".")) gives you the extension with the "."
isFileJPEG = (LCase(Mid(sFileName, InStrRev(sFileName, ".") + 1)) = FILEEXT)
End Function
'==================================
Sub deleteFiles(fFolder)
Dim fFile, fSubFolder
If Not isExclude(fFolder.Path) Then
'WScript.echo "==>> """ & fFolder.Path & """" ' Comment for no output
For Each fFile In fFolder.Files
If isFileJPEG(fFile) And isOldFile(fFile) Then
lngDeletes = lngDeletes + 1
LOGG lngDeletes & vbTab & fFile.Path
'WScript.echo vbTab & "DELETE: """ & fFile.Path & """" ' Comment for no output
fFile.Delete True ' Uncomment to really delete the file
End If
Next
' Only Process sub folders if current folder is not excluded
For Each fSubFolder In fFolder.SubFolders
deleteFiles fSubFolder
Next
Else
lngSkips = lngSkips + 1
'WScript.echo "<<-- """ & fFolder.Path & """" ' Comment for no output
End If
End Sub
Never ever use On Error Resume Next unless it absolutely cannot be avoided.
This problem needs a recursive function. Here's how I would do it:
Option Explicit
'set these constants to your requirements
Const DIR = "C:\MyFolder"
Const AGE = 15
Dim oFSO
Dim aExclude
'add to this array to exclude paths
aExclude = Array("c:\folder\exclude1", "c:\folder\another\exclude2")
Set oFSO = CreateObject("Scripting.FilesystemObject")
Call deleteFiles(oFSO.GetFolder(DIR))
Set oFSO = Nothing
WScript.Quit
'=================================
Function isExclude(sPath)
Dim s
For Each s in aExclude
If LCase(s) = LCase(sPath) Then
isExclude = True
Exit Function
End If
Next
isExclude = False
End Function
'==================================
Sub deleteFiles(fFolder)
Dim fFile, fSubFolder
If Not isExclude(fFolder.Path) Then
For Each fFile in fFolder.Files
If (LCase(Right(Cstr(fFile.Name),4)) = "jpeg") And (fFile.DateLastModified < (Date() - AGE)) Then
'WScript.echo fFile.Path 'I put this in for testing, uncomment to do the same
Call fFile.Delete(true)
End If
Next
End If
For Each fSubFolder in fFolder.SubFolders
Call deleteFiles(fSubFolder)
Next
End Sub
I'm not really able to fully test it out because I don't have an example data set, but really all you need to do is set DIR and change the aExclude array. Make sure you know what its going to delete before you run it though...
Also, it will only delete jpeg extensions, not jpg but I imagine you already know that
I have been trying to find the answer but no exact match for my question.
below is a snippet of the script just to rename the folder, this doesn't give me a err and continue it just stops.
at the beginning of the script and general most of my script have "Option Explicit"
so I thought maybe that stopped it and I used "On Error Resume Next" but it still stops.
I know how I get the error its because I have a file open in the directory I'm trying to 'rename' what I'm attempting to do its get the script to say 'sorry you have a file open in that directory' and continue to the next folder...
Can you please help me solve this,
objFSO.MoveFolder (folder1),(folder2)
If Err.Number <> 0 Then
WScript.Echo Err.Description
WScript.Echo Err.Number
End If
Cheers,
Pav
Did you put On Error Resume Next just below the Sub? You should also Clear the Error.
I believe you are running the vbs in command prompt using cscript:
Sub RenameFolders()
On Error Resume Next
' Add your codes
objFSO.MoveFolder (folder1),(folder2)
If Err.Number <> 0 Then
WScript.Echo "sorry you have a file open in that directory"
WScript.Echo Err.Description
WScript.Echo Err.Number
Err.Clear ' Clear the ERROR!
End If
End Sub
Dim SPath 'As String
Dim DPath 'As String
SPath = "d:\test1"
DPath = "E:\test1"
Call MoveFolders(SPath ,DPath)
Sub MoveFolders(PSPath,PDPath)
'-----------------------------
PSPath = Trim(PSPath)
PDPath = Trim(PDPath)
'-----------------------------
Dim objFso 'AS Object
Dim objFil 'As Object
Dim objMFld 'As Object
Dim objSFld 'As Object
'/*----------------------------
Dim DestFullPath 'As String
Dim DestFullFilePath 'As String
'----------------------------------------------------
Set objFso = CreateObject("Scripting.FileSystemObject")
'----------------------------------------------------
If objFso.FolderExists(PSPath) Then
Set objMFld = objFso.GetFolder(PSPath)
'----------------------------------------------------
If Not objFso.FolderExists(PDPath) Then
objFso.CreateFolder(PDPath)
End If
'----------------------------------------------------
For Each objSFld In objMFld.SubFolders
DestFullPath = Replace(objSFld, PSPath, PDPath ,1, 1, vbTextCompare)
'/*------------------------
Call MoveFolders(objSFld,DestFullPath)
'/*------------------------
Next
'/*------------------------
For Each objFil In objFso.GetFolder(PSPath).Files
'/*------------------------
DestFullFilePath = PDPath & "\" & objFil.Name
'/*------------------------
If objFso.FileExists(DestFullFilePath) Then
objFSO.DeleteFile(DestFullFilePath)
End If
'/*------------------------
objFso.MoveFile objFil , PDPath & "\"
Next
'/*------------------------
If objFso.GetFolder(PSPath).Files.Count = 0 And objFso.GetFolder(PSPath).SubFolders.Count = 0 Then
objFso.DeleteFolder PSPath
End If
'------------------------------
End If
End Sub
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.