The following script I found somewhere is zipping a folder:
Set Args = Wscript.Arguments
source = Args(0)
target = Args(1)
ArchiveFolder source, target
Sub ArchiveFolder (sFolder, zipFile)
With CreateObject("Scripting.FileSystemObject")
zipFile = .GetAbsolutePathName(zipFile)
sFolder = .GetAbsolutePathName(sFolder)
With .CreateTextFile(zipFile, True)
.Write Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, chr(0))
End With
End With
With CreateObject("Shell.Application")
.NameSpace(zipFile).CopyHere .NameSpace(sFolder).Items
Do Until .NameSpace(zipFile).Items.Count = _
.NameSpace(sFolder).Items.Count
WScript.Sleep 1000
Loop
End With
End Sub
However, when trying to zip empty sub-folders.
I receive an error saying:
Windows was unable to add one or more empty directories...
I tried adding a condition where if the sFolder is empty, skip copying it, but same result.
If .NameSpace(sFolder).Items.Count <> 0 Then
.NameSpace(zipFile).CopyHere .NameSpace(sFolder).Items
Else
WScript.Quit
End If
Ideas?
Related
How to replace a specific string with the filename? Example: I have several files with different names (like: Test.asp, Constant.asp, Letter.asp, etc.) within a subfolder that contain the text "ABC123". I would like to replace the "ABC123" in each file with the filename.
Below is the code I have that finds string and replaces it with a specific string but it doesn't do the job that I listed above.
Option Explicit
Dim objFilesystem, objFolder, objFiles, objFile, tFile, objShell, objLogFile,objFSO, objStartFolder, colFiles
Dim SubFolder, FileText, bolWriteLog, strLogName, strLogPath, strCount, strCount2, strOldText, strNewText, strEXT
bolWriteLog = True
Const ForReading = 1
Const ForWriting = 2
Const TriStateUseDefault = -2
Set objFilesystem = WScript.CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")
strLogName = "log.txt"
strLogPath = "C:\" & strLogName
strCount = 0
strCount2 = 0
strOldText = "ABC123"
strNewText = ""
strEXT = "asp"
'Initialize log file
If bolWriteLog Then
On Error Resume Next
Set objLogFile = objFileSystem.OpenTextFile(strLogPath, 2, True)
WriteLog "############### Start Log ##################"
If Not Err.Number = 0 Then
MsgBox "There was a problem opening the log file for writing." & Chr(10) & _
"Please check whether """ & strLogPath & """ is a valid file and can be openend for writing." & _
Chr(10) & Chr(10) & "If you're not sure what to do, please contact your support person.", vbCritical, "Script Error"
WScript.Quit
End If
On Error Goto 0
End If
Set objFSO = CreateObject("Scripting.FileSystemObject")
objStartFolder = "D:\MyFolder"
Set objFolder = objFSO.GetFolder(objStartFolder)
WScript.Echo objFolder.Path
Set colFiles = objFolder.Files
For Each objFile In colFiles
'WScript.Echo objFile.Name
' Now we have an exception for all files that can not be opened in text modus: all extensions such as "exe" should be listed upfront.
ReplaceText(objFile)
Next
ShowSubfolders objFSO.GetFolder(objStartFolder)
Sub ReplaceText(objFile)
If InStr(1, strEXT, Right(LCase(objFile.Name), 3)) = 0 Or objFile.Size = 0 Then
Else
strCount = strCount + 1
WriteLog("Opening " & objFile.Name)
Set tFile = objFile.OpenAsTextStream(ForReading, TriStateUseDefault)
FileText = tFile.ReadAll
tFile.Close
If InStr(FileText, strOldText) Then
WriteLog("Replacing " & strOldText & " with " & strNewText & ".")
FileText = Replace(FileText, strOldText, strNewText)
WriteLog("Text replaced")
Else
WriteLog(strOldText & " was not found in the file.")
strCount2 = strCount2 + 1
End If
Set tFile = objFile.OpenAsTextStream(ForWriting, TriStateUseDefault)
tFile.Write FileText
tFile.Close
FileText = ""
strCount = 0
strCount2 = 0
End If
End Sub
Sub ShowSubFolders(Folder)
For Each Subfolder in Folder.SubFolders
'WScript.Echo Subfolder.Path
Set objFolder = objFSO.GetFolder(Subfolder.Path)
Set colFiles = objFolder.Files
For Each objFile in colFiles
'WScript.Echo objFile.Name
ReplaceText(objFile)
Next
ShowSubFolders Subfolder
Next
End Sub
WriteLog "############### EndLog ##################"
WScript.Echo "Script Complete"
objShell.Run "C:\" & strLogName
'Clear environment and exit
On Error Resume Next
Set tFile = Nothing
Set objFile = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objLogFile = Nothing
Set objFilesystem = Nothing
Set objShell = Nothing
WScript.Quit
'Subs and functions ********** DO NOT EDIT ***************
Sub WriteLog(sEntry)
If bolWriteLog Then objLogFile.WriteLine(Now() & ": Log: " & sEntry)
End Sub
I can give you a one line Ruby solution, should be not too difficult to translate that in Python but somewhat more extensive in VbScript I am afraid. First a generic search and replace version.
ARGV[0..-3].each{|f| File.write(f, File.read(f).gsub(ARGV[-2],ARGV[-1]))}
Save it in a script, eg replace.rb
You start in on the command line (here cmd.exe) with
replace.rb *.txt <string_to_replace> <replacement>
broken down so that I can explain what's happening but still executable
# ARGV is an array of the arguments passed to the script.
ARGV[0..-3].each do |f| # enumerate the arguments of this script from the first to the last (-1) minus 2
File.write(f, # open the argument (= filename) for writing
File.read(f) # open the argument (= filename) for reading
.gsub(ARGV[-2],ARGV[-1])) # and replace all occurances of the beforelast with the last argument (string)
end
And finally your request to replace ABC123 with the filename.
Of course tested and working
ARGV[0..-1].each{|f| File.write(f, File.read(f).gsub('ABC123', f))}
Contents of one of my testfiles (1.txt) after executing
test phrase
1.txt
EDIT
I see you want subfolder recursion on a fixed folder, no problem
Dir['**/*'].each{|f| File.write(f, File.read(f).gsub('ABC123', f)) unless File.directory?(f) }
I have a script in VBScript that gets the content of a folder and gets it into a zip. It is mainly based on what I found in another post, as I am no VBS expert. This is the function:
Sub ArchiveFolder (zipFile, sFolder)
With CreateObject("Scripting.FileSystemObject")
zipFile = .GetAbsolutePathName(zipFile)
sFolder = .GetAbsolutePathName(sFolder)
With .CreateTextFile(zipFile, True)
.Write Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, chr(0))
End With
End With
With CreateObject("Shell.Application")
.NameSpace(zipFile).CopyHere .NameSpace(sFolder).Items
Do Until .NameSpace(zipFile).Items.Count = _
.NameSpace(sFolder).Items.Count
WScript.Sleep 1000
Loop
End With
End Sub
I need to divide the resulting file in size limited files (80MB). Is there a way to do this?
As I understand it, the Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, chr(0)) part is indicating to create a zip file, but I am not able to find an explanation of what this means and how to parametrize the action.
The simplest approach to limiting the size of a zip file is to continue adding files until the maximum size is exceeded, then remove the last item added.
Sub ArchiveFolder (zipFile, sFolder)
With CreateObject("Scripting.FileSystemObject")
zipFile = .GetAbsolutePathName(zipFile)
sFolder = .GetAbsolutePathName(sFolder)
With .CreateTextFile(zipFile, True)
.Write Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, chr(0))
End With
Set oZip = .GetFile(zipFile)
End With
With CreateObject("Shell.Application")
cnt = 0
For Each currentItem In .NameSpace(sFolder).Items
cnt = cnt + 1
.NameSpace(zipFile).CopyHere currentItem
Do Until .NameSpace(zipFile).Items.Count = cnt
WScript.Sleep 1000
Loop
If oZip.Size > 83886080 Then
Set lastItem = .NameSpace(zipFile).ParseName(f.Name)
.NameSpace("C:\temp").MoveHere lastItem
Exit For
End If
Next
End With
End Sub
Of course there are more intelligent strategies than this to optimize space usage, but exploring them would be far too broad for an answer here.
I have finally solved it by using 7zip's portable version. There I can create the zip file with the parameters I need:
Set oShell = CreateObject("WScript.Shell")
strCmd = "7-Zip\7z.exe a -v80m " & zipFile & " " & sFolder
oShell.Run(strCmd)
Set oShell = Nothing
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 am trying to ZIP up a folder in VBScript and it doesn't seem to work. I'm certain I am creating the header file correctly.
It creates the actual file correctly, just doesn't zip the folder.
Anyone got any ideas:
Sub ArchiveFolder (folder)
Dim fso, wShell, sApp, zipFile
Set fso = CreateObject("Scripting.FileSystemObject")
Set wShell = CreateObject("WScript.Shell")
Set sApp = CreateObject("Shell.Application")
Set zipFile = fso.CreateTextFile(folder & ".zip")
' Write zip file header.
zipFile.Write "PK" & Chr(5) & Chr(6) & String(18, 0)
zipFile.Close
sApp.NameSpace(folder & ".zip").CopyHere folder
End Sub
The answer I found here. The magic is in the last Do..Loop where the script wait the Shell to do it job.
ArchiveFolder "sub\foo.zip", "..\baz"
Sub ArchiveFolder (zipFile, sFolder)
With CreateObject("Scripting.FileSystemObject")
zipFile = .GetAbsolutePathName(zipFile)
sFolder = .GetAbsolutePathName(sFolder)
With .CreateTextFile(zipFile, True)
.Write Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, chr(0))
End With
End With
With CreateObject("Shell.Application")
.NameSpace(zipFile).CopyHere .NameSpace(sFolder).Items
Do Until .NameSpace(zipFile).Items.Count = _
.NameSpace(sFolder).Items.Count
WScript.Sleep 1000
Loop
End With
End Sub
Check your argument. folder must be the path to the object you want to put into the zip file. If it's a folder object you have to use folder.Path, because the default method of folder objects is Name, and CopyHere can't find the object with just the name.
You could add some debugging statements to your function to check that:
WScript.Echo TypeName(folder)
If fso.FolderExists(folder) Then
WScript.Echo folder & " exists."
Else
WScript.Echo folder & " doesn't exist."
End If
you could call an external zip file via %comspec%
oShell.Run "%comspec% /c c:\windows\7za.exe a " & oFile &".zip " & oFile & " -tzip",,True
Source http://www.scriptlook.com/zip-large-files-in-a-directory-2/
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.