I am writing a VBScript to copy file from source to target. It works copy from source to target but if we are trying to overwrite the file to target and if any user open that same file in target it's not overwriting it.
Note: the user open the file has write access.
Could someone please help on this? Below is the function but have to delete file that are also open in destination.
Sub Clear_All_Files_And_SubFolders_In_Folder()
'Delete all files and subfolders
'Be sure that no file is open in the folder
Dim FSO As Object
Dim MyPath As String
Set FSO = CreateObject("scripting.filesystemobject")
MyPath = "C:\Users\Ron\Test" '<< Change
If Right(MyPath, 1) = "\" Then
MyPath = Left(MyPath, Len(MyPath) - 1)
End If
If FSO.FolderExists(MyPath) = False Then
MsgBox MyPath & " doesn't exist"
Exit Sub
End If
On Error Resume Next
'Delete files
FSO.DeleteFile MyPath & "\*.*", True
'Delete subfolders
FSO.DeleteFolder MyPath & "\*.*", True
On Error GoTo 0
End Sub
Related
I am using this code to zip all files in a folder into a newly created .zip file:
Dim FileNameZip, FolderName
Dim filename As String, DefPath As String
Dim oApp As Object
(defining all paths needed)
'Create empty Zip File
NewZip (FileNameZip)
Set oApp = CreateObject("Shell.Application")
'Copy the files to the compressed folder
oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = oApp.Namespace(FolderName).items.Count
Application.Wait (Now + TimeValue("0:00:01"))
Loop
This works without problems as long as my target folder is different from the folder where my files are.
But I have a problem when I try to take all files from a folder, put them into .zip and have the archive generated in the same folder - it creates the archive and then tries to put it into itself, which of course fails.
I am looking for a way to zip all files from a folder except this one newly created.
I looked here: https://msdn.microsoft.com/en-us/library/office/ff869597.aspx but this looks very Outlook-specific and I have no idea how to apply this to a Windows folder.
Rather than add all files at once, which will include the zip file you create, loop through the files with the FileSystemObject and compare their names against the zip file name before adding to the zip:
Sub AddFilesToZip()
Dim fso As Object, zipFile As Object, objShell As Object
Dim fsoFolder As Object, fsoFile As Object
Dim timerStart As Single
Dim folderPath As String, zipName As String
folderPath = "C:\Users\darre\Desktop\New folder\" ' folder to zip
zipName = "myzipfile.zip" ' name of the zip file
Set fso = CreateObject("Scripting.FileSystemObject") ' create an fso to loop through the files
Set zipFile = fso.CreateTextFile(folderPath & zipName) ' create the zip file
zipFile.WriteLine Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, 0)
zipFile.Close
Set objShell = CreateObject("Shell.Application")
Set fsoFolder = fso.GetFolder(folderPath)
For Each fsoFile In fsoFolder.Files ' loop through the files...
Debug.Print fsoFile.name
If fsoFile.name <> zipName Then ' and check it's not the zip file before adding them
objShell.Namespace("" & folderPath & zipName).CopyHere fsoFile.Path
timerStart = Timer
Do While Timer < timerStart + 2
Application.StatusBar = "Zipping, please wait..."
DoEvents
Loop
End If
Next
' clean up
Application.StatusBar = ""
Set fsoFile = Nothing
Set fsoFolder = Nothing
Set objShell = Nothing
Set zipFile = Nothing
Set fso = Nothing
MsgBox "Zipped", vbInformation
End Sub
I would create the zip file in the temporary folder and finally move it to the destination folder. Two notes worth mentioning:
1- The approach of looping until the Item counts are the same in the folder and the zip file is risky, because if the zipping fails for an individual item, it results in an infinite loop. For this reason it's preferable to loop as long as the zip file is locked by the shell.
2- I will use early binding with the Shell because late-binding the Shell32.Application seems to have issues on some installations. Add a reference to Microsoft Shell Controls and Automation
Sub compressFolder(folderToCompress As String, targetZip As String)
If Len(Dir(targetZip)) > 0 Then Kill targetZip
' Create a temporary zip file in the temp folder
Dim tempZip As String: tempZip = Environ$("temp") & "\" & "tempzip1234.zip"
CreateObject("Scripting.FileSystemObject").CreateTextFile(tempZip, True).Write _
Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
' compress the folder into the temporary zip file
With New Shell ' For late binding: With CreateObject("Shell32.Application")
.Namespace(tempZip).CopyHere .Namespace(folderToCompress).Items
End With
' Move the temp zip to target. Loop until the move succeeds. It won't
' succeed until the zip completes because zip file is locked by the shell
On Error Resume Next
Do Until Len(Dir(targetZip)) > 0
Application.Wait Now + TimeSerial(0, 0, 1)
Name tempZip As targetZip
Loop
End Sub
Sub someTest()
compressFolder "C:\SO\SOZip", "C:\SO\SOZip\Test.zip"
End Sub
I found zipping via VBA to be hard to control without third party tools, the below may not be a direct answer but may aid as a solution. The below is an excerpt of the code I used to generate epubs which are not much more than zip files with a different extension. This zipping section never failed in hundreds of runs.
Public Function Zip_Create(ByVal StrFilePath As String) As Boolean
Dim FSO As New FileSystemObject
Dim LngCounter As Long
If Not FSO.FileExists(StrFilePath) Then
'This makes the zip file, note the FilePath also caused issues
'it should be a local file, suggest root of a drive and then use FSO
'to open it
LngCounter = FreeFile
Open StrFilePath For Output As #LngCounter
Print #LngCounter, "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
Close #LngCounter
End If
Zip_Create = True
End Function
Public Function Zip_Insert(ByVal StrZipFilePath As String, ByVal StrObject As String) As Boolean
Dim BlnYesNo As Boolean
Dim LngCounter As Long
Dim LngCounter2 As Long
Dim ObjApp As Object
Dim ObjFldrItm As Object
Dim ObjFldrItms As Object
Dim StrContainer As String
Dim StrContainer2 As String
If Procs.Global_IsAPC Then
'Create the zip if needed
If Not FSA.File_Exists(StrZipFilePath) Then
If Not Zip_Create(StrZipFilePath) Then
Exit Function
End If
End If
'Connect to the OS Shell
Set ObjApp = CreateObject("Shell.Application")
'Pause, if it has just been created the next piece of
'code may not see it yet
LngCounter2 = Round(Timer) + 1
Do Until CLng(Timer) > LngCounter2
DoEvents
Loop
'Divide the path and file
StrContainer = Right(StrObject, Len(StrObject) - InStrRev(StrObject, "\"))
StrObject = Left(StrObject, Len(StrObject) - Len(StrContainer))
'Connect to the file (via the path)
Set ObjFldrItm = ObjApp.NameSpace(CVar(StrObject)).Items.Item(CVar(StrContainer))
'Pauses needed to avoid all crashes
LngCounter2 = CLng(Timer) + 1
Do Until CLng(Timer) > LngCounter2
DoEvents
Loop
'If it is a folder then check there are items to copy (so as to not cause and error message
BlnYesNo = True
If ObjFldrItm.IsFolder Then
If ObjFldrItm.GetFolder.Items.Count = 0 Then BlnYesNo = False
End If
If BlnYesNo Then
'Take note of how many items are in the Zip file
'Place item into the Zip file
ObjApp.NameSpace(CVar(StrZipFilePath)).CopyHere ObjFldrItm
'Pause to stop crashes
LngCounter2 = CLng(Timer) + 1
Do Until CLng(Timer) > LngCounter2
DoEvents
Loop
'Be Happy
Zip_Insert = True
End If
Set ObjFldrItm = Nothing
Set ObjApp = Nothing
End If
End Function
I have a vb script file - main.vbs. Its contents are:
Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
If fileSystemObject.FileExists("D:\a\source.doc") Then
fileSystemObject.CopyFile "D:\b\template.doc", "D:\c\source.doc"
fileSystemObject.MoveFile "D:\a\source.doc" , "D:\d\"
End If
What this script does is: It checks if a file by the name of 'source.doc' exists in folder 'D:\a' . if it does, then the script,
(i) copies the file 'template.doc' kept in folder 'D:\b'
(ii) renames 'template.doc' to 'source.doc'
(iii) and moves this renamed file to folder 'D:\c'.
(iv) and also moves the file 'source.doc' from 'D:\a' to 'D:\d'
The script is working fine. But I want that the script should run when the filename 'source' varies (but same extension .doc).
The filename 'template.doc' remains the same.
How can I do this ?
This uses the FSO object more like a dir. Do tests on the name to decide if to process it or not. fso.copyfile is same as thing.copy using a collection and a For Each loop.
'On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Dirname = InputBox("Enter Dir name")
ProcessFolder DirName
Sub ProcessFolder(FolderPath)
' On Error Resume Next
Set fldr = fso.GetFolder(FolderPath)
Set Fls = fldr.files
For Each thing in Fls
msgbox Thing.Name & " " & Thing.DateLastModified
Next
'Uncomment below lines to do sub folders
' Set fldrs = fldr.subfolders
' For Each thing in fldrs
' ProcessFolder thing.path
' Next
End Sub
I have successfully created a VBScript that renames a file as required when it is the only file in the folder. I cannot figure out how to have the script search past the most recent file.
Option Explicit
Dim fso, folder, file, tmFile
Dim folderName
folderName = "\\pcc\Int\PC\Inbox\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderName)
Set tmFile = Nothing
For each file In folder.Files
If (tmFile is Nothing) Then
Set tmFile = file
Exit For
End IF
Next
If InStr(tmfile.name, "TM") Then
TmFile.Name = Replace(tmFile.Name, ".txt", "A.txt")
End if
The above script correctly renames the file.
Here are a few modifications I have tried to go through all of the files in the folder to search for the file that has the prefix TM. This will always be the only file with the TM prefix.
For Each InStr(tmFile.name, "TM") Then
tmFile.Name = Replace(tmFile.Name, ".txt", "A.txt")
Exit for
and
If tmFile.fileexists(tmFile.name, "TM") Then
tmFile.Name = Replace(tmFile.Name, ".txt", "A.txt")
End if
You are close with your instr(), it's just that you need to put that test within your already existing For loop:
Option Explicit
Dim fso, folder, file, tmFile
Dim folderName
folderName = "\\pcc\Int\PC\Inbox\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderName)
For each file In folder.Files
If instr(file, "TM") > 0 THEN
file.name = replace(file.name, ".txt", "A.txt")
End IF
Next
I've removed the tmfile variable since it's simply not needed here.
I have a hard drive that is infected with a virus. The virus encrypts files and then asks for a ransom to unencrypt them. The files are HELP_DECRYPT.HTML, HELP_DECRYPT.PNG, HELP_DECRYPT.TXT and HELP_DECRYPT.URL.
There are thousands of infected files on the drive. I am trying to write a script to go through all the folders on the drive, and if it finds any of the malicious files it deletes them. I then want if to copy files from the backup drive in the same directory ie. if found in I\Folder\ if would get files from F\Folder\ .
In my case the infected drive is Y, and the backup drive is X.
I am relatively new to VBScripts and here is what I have so far:
set fso = CreateObject("Scripting.FileSystemObject")
ShowSubFolders FSO.GetFolder("Y:\"), 3
Sub ShowSubFolders(Folder, Depth)
If Depth > 0 then
For Each Subfolder in Folder.SubFolders
'Wscript.Echo Subfolder.Path
DeleteFiles(subFolder.path)
On Error Resume Next
ShowSubFolders Subfolder, Depth -1
Next
End if
End Sub
'deletes the malicious files and calls the copy function'
Function DeleteFiles(path)
'wscript.echo("in delete method")
set FSO2 = Createobject("Scripting.FileSystemObject")
set ofolder = createobject("Scripting.FileSystemObject")
set ofolder = FSO2.GetFolder(path)
if FSO2.FileExists("HELP_DECRYPT.URL") Then
ofolder.DeleteFile("HELP_DECRYPT.PNG")
ofolder.DeleteFile("HELP_DECRYPT.HTML")
ofolder.DeleteFile("HELP_DECRYPT.URL")
ofolder.DeleteFile("HELP_DECRYPT.TXT")
wscript.echo("DeletedFiles")
copyFiles(FSO.GetParentFolder)
end if
End Function
'copies files from the backup'
Function CopyFiles(from)
dim to1 'where we're copying to
to1=from 'where we're copying from
Call Replace (from, "Y:", "X:")
SET FSO3 = CreateObject("Scripting.FileSystemObject")
For Each file In from 'not sure about "file"
FSO3 = file
Call FSO3.CopyFile (from, to1, true)'copies file and overwrites if already there
Next
End Function
Here's what I would use:
Option Explicit
Dim FSO, badFiles
Set FSO = CreateObject("Scripting.FileSystemObject")
badFiles = Array("HELP_DECRYPT.PNG", "HELP_DECRYPT.URL", "HELP_DECRYPT.HTML", "HELP_DECRYPT.TXT")
Walk FSO.GetFolder("Y:\")
Sub Walk(folder)
Dim subFolder
For Each subFolder in folder.SubFolders
DeleteFiles subFolder, badFiles
RestoreFiles "X:", subFolder
Walk subFolder
Next
End Sub
Sub DeleteFiles(folder, filesToDelete)
Dim file
For Each file In filesToDelete
file = FSO.BuildPath(folder.Path, file)
If FSO.FileExists(file) Then FSO.DeleteFile file, True
Next
End Sub
Sub RestoreFiles(sourceRoot, destinationFolder)
Dim sourcePath, file
WScript.Echo "Restoring " & destinationFolder.Path & " ..."
sourcePath = Replace(destinationFolder.Path, destinationFolder.Drive, sourceRoot)
If FSO.FolderExists(sourcePath) Then
For Each file In FSO.GetFolder(sourcePath).Files
WScript.Echo file.Name
' maybe add a DateLastModified check here?
file.Copy FSO.BuildPath(destinationFolder.Path, file.Name), True
Next
Else
WScript.Echo "Warning! Folder not found: " & sourcePath
End If
End Sub
General tips for working with VBScript:
Always use Option Explicit
Avoid On Error Resume Next except in very closely confined situations. Simply suppressing any errors is never a good idea.
Run scripts like the above on the command line with cscript.exe so you can see the script's Echo output without having to click at 1000's of message boxes.
Use a global FSO object. No need to define a new one in every function
Try to be generic. Look how DeleteFiles() RestoreFiles() above are actually not at all tailored to your current problem. You might be able to re-use those functions in a different script without having to change them.
I need to recursively search for multiple files through the C:\Users directory tree recursively.
If I find any of the specified files in any of the sub-directories, I want to echo out the full path.
Here is what I have:
Dim fso,folder,files,sFolder,newFolder
Dim arr1
arr1 = Array("myFile1.pdf","myFile2.pdf","myFile3.pdf","nutbag.rtf","whoa.txt")
Set fso = CreateObject("Scripting.FileSystemObject")
sFolder = "C:\Users"
Set folder = fso.GetFolder(sFolder)
Set files = folder.SubFolders
For each folderIdx In files
IF (Instr(folderIdx.Name,"Default") <> 1) Then
If (Instr(folderIdx.Name,"All Users") <> 1) Then
newFolder = sfolder & "\" & folderIdx.Name
CopyUpdater fso.GetFolder(newFolder)
End If
End If
Next
Sub CopyUpdater(fldr)
For Each f In fldr.Files
For Each i in arr1
If LCase(f.Name) = i Then
WScript.echo(f.name)
End If
Next
Next
For Each sf In fldr.SubFolders
CopyUpdater sf
Next
End Sub
If I run it as 'Administrator', I get:
VBScript runtime error: Permission Denied
If I run it as 'Local System' user, I get:
VBScript runtime error: Path not found
If I add, 'On Error Resume Next' to the beginning to suppress the errors, I get nothing back.
I have placed a text file called 'whoa.txt' in numerous locations around the C:\Users sub-dirs.
My suspicion is that it is a Windows permissions thing, but I am unsure.
Thanks much.
First I didn't use your code, it confuses me what you are trying to accomplish.
Next you should run the script in Administrator mode command prompt. This should allow you to check if the file is there.
Then paste code below to a vbs file and cscript it. This code displays all the matched filenames.My idea is that instead of going through all files in any folder for a matching filename, check if those wanted files exists in that folder - this is generally faster as some folders contains hundreds of files if not thousands (check your Temp folder!).
Option Explicit
Const sRootFolder = "C:\Users"
Dim fso
Dim arr1
Dim oDict ' Key: Full filename, Item: Filename
Main
Sub Main
arr1 = Array("myFile1.pdf", "myFile2.pdf", "myFile3.pdf", "nutbag.rtf", "whoa.txt")
Set fso = CreateObject("Scripting.FileSystemObject")
Set oDict = CreateObject("Scripting.Dictionary")
' Call Recursive Sub
FindWantedFiles(sRootFolder)
' Display All Findings from Dictionary object
DisplayFindings
Set fso = Nothing
Set oDict = Nothing
End Sub
Sub FindWantedFiles(sFolder)
On Error Resume Next
Dim oFDR, oItem
' Check if wanted files are in this folder
For Each oItem In arr1
If fso.FileExists(sFolder & "\" & oItem) Then
oDict.Add sFolder & "\" & oItem, oItem
End If
Next
' Recurse into it's sub folders
For Each oFDR In fso.GetFolder(sFolder).SubFolders
FindWantedFiles oFDR.Path
Next
End Sub
Sub DisplayFindings()
Dim oKeys, oKey
oKeys = oDict.Keys
For Each oKey In oKeys
wscript.echo oKey
Next
End Sub