I want to add a file to a folder and save it as a compressed folder in VBScript.
I've written the following code, but it only creates the ZIP file and doesn't add the files to it. What can be the problem with this code?
Option Explicit
dim wshShell
Const MoveMode = True
Const BackupDir = "D:\csv\Image\"
Const Outfilename = "MyZip.zip"
Const TimeoutMins = 10 ' Timeout for individual file compression operation
'Set wshShell = CreateObject("WScript.shell")
Dim FSO : set FSO = CreateObject("Scripting.FileSystemObject")
Dim Folder : Set Folder = FSO.GetFolder("D:\csv\Image")
Dim Files : Set Files = Folder.Files
Dim File
Dim Counter : Counter=0
Dim Timeout : Timeout = 0
FSO.CreateTextFile "D:\csv\" & OutFilename,true '.WriteLine "PK" & Chr(5) & Chr(6) & String(18, 0)
Dim Shell : Set Shell = CreateObject("Shell.Application")
Dim ZipFile: Set ZipFile = Shell.NameSpace("D:\csv\"& OutFilename)
If Not ZipFile Is Nothing Then
Shell.NameSpace("D:\csv\"&Outfilename).CopyHere "D:\csv\Image\calender.png"
End If
This shows waiting 500 ms after creating a new ZIP file before attempting to copy data into it. Have you tried using WScript.Sleep(500)?
Dim FSO : set FSO = CreateObject("Scripting.FileSystemObject")
Dim Shell : Set Shell = CreateObject("Shell.Application")
If Not FSO.FileExists("D:\csv\" & OutFilename) Then
NewZip("D:\csv\" & OutFilename)
End If
If Not ZipFile Is Nothing Then
Shell.NameSpace("D:\csv\" & Outfilename).CopyHere BackupDir & "calender.png"
End If
Sub NewZip(sNewZip)
'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
Set oNewZipFSO = CreateObject("Scripting.FileSystemObject")
Set oNewZipFile = oNewZipFSO.CreateTextFile(sNewZip)
oNewZipFile.Write Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, 0)
oNewZipFile.Close
Set oNewZipFSO = Nothing
Wscript.Sleep(500)
End Sub
(Untested)
Related
In continuation of Call VBScript from Windows Explorer Context Menu, I managed to get a VBScript file running from SendTo in the Windows Explorer.
I've changed my code to copy the file that invokes the script to my Temp folder. The new problem is that if the path is over 256 characters, I can't loop through WScript.Arguments to get all of it. Is there another way to get the full path (including the file name and it's extension)?
Option Explicit
Call OpenDocuWorksFile
Sub OpenDocuWorksFile()
Const sTitle = "Open DocuWorks File"
Dim iArgumentsCount
Dim iArgument
Dim sFilePath
Dim sTempFolder
Dim oFileScriptingObject
Dim sFileName
Dim oShell
iArgumentsCount = WScript.Arguments.Count
On Error Resume Next
For iArgument = 0 To iArgumentsCount
sFilePath = sFilePath & WScript.Arguments(iArgument)
Next
On Error GoTo 0
Set oFileScriptingObject = CreateObject("Scripting.FileSystemObject")
With oFileScriptingObject
sFileName = .GetFileName(sFilePath)
sTempFolder = oFileScriptingObject.GetSpecialFolder(2) 'Temp Folder
If .GetExtensionName(sFileName) = "xdw" Then
.CopyFile sFilePath, sTempFolder & "\", True 'Overwrite
Set oShell = CreateObject("Shell.Application")
oShell.Open sTempFolder & "\" & sFileName
Else
MsgBox "Please select a DocuWorks file.（.xdw)", vbCritical, sTitle
End If
End With
Set oFileScriptingObject = Nothing
Set oShell = Nothing
End Sub
'I have 2 scripts but could not combine them
'create multiple folders script:
Dim objFSO, objFolder, strDirectory, i
strDirectory = "C:\Users\test\Desktop\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
i = 1 ''
While i < 150
Set objFolder = objFSO.CreateFolder(strDirectory & i)
i = i+1
''WScript.Quit ''
Wend
'desktop path script
set WshShell = WScript.CreateObject("WScript.Shell")
strDesktop = WshShell.SpecialFolders("Desktop")
wscript.echo(strDesktop)
I want the code to automatically find the desktop path and then create the folders, some one help me please ?
To get the desktop folder path string and create a sub directory you can do this:
Set objShell = Wscript.CreateObject("Wscript.Shell")
strPath = objShell.SpecialFolders("Desktop")
Dim objFso
Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
If Not objFso.FolderExists(strPath + "\NewFolder") Then
objFso.CreateFolder strPath + "\NewFolder"
I was trying to build a VBS to test creating files because a larger script I wrote isn't creating an output file. The point of the following script is to test functionality; which I'm not currently seeing.
Option Explicit
Dim objFSO, objFSOText, objFolder, objFile
Dim strDirectory, strFile
strDirectory = "C:\Test\next"
strFile = "\Try.txt"
' Create the File System Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Create the Folder specified by strDirectory on line 10
Set objFolder = objFSO.CreateFolder(strDirectory)
' -- The heart of the create file script
'-----------------------
'Creates the file using the value of strFile on Line 11
' -----------------------------------------------
Set objFile = objFSO.CreateTextFile(strDirectory & strFile)
Wscript.Echo "Just created " & strDirectory & strFile
Wscript.Quit
While running this code, everything works the first time but there isn't an output file in the destination directory. When I run it again it throws an error that the file already exists.
I think the problem is that you are trying to create the path "C:\Test\next", which is a structure of two nested folders) in one go and also do not test if that path already exists.
To create a nested folder structure, I have added a small helper function CreateNestedFolder to your code and tidied it up a bit:
Option Explicit
Dim strDirectory, strFile, overwrite
strDirectory = "C:\Test\next"
strFile = "Try.txt"
overwrite = True 'set this to False if you do not wish to overwrite an existing file
'Create the (nested) Folder Structure specified by strDirectory if it does not exist yet
If Not CreateNestedFolder(strDirectory) Then
Wscript.Echo "Could not create folder " & strDirectory
Else
Dim objFSO, objFile
' Create the File System Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
' -- The heart of the create file script
'-----------------------
'Creates the file using the value of strFile
' -----------------------------------------------
'combine the directory and filename
strFile = strDirectory & "\" & strFile
'Create the new file and write something in it
Set objFile = objFSO.CreateTextFile(strFile, overwrite)
objFile.WriteLine("This is a test.")
objFile.Close
Wscript.Echo "Just created " & strFile
'Clean up the used objects
Set objFile = Nothing
Set objFSO = Nothing
End If
Function CreateNestedFolder(ByVal sPath)
'Helper function to create a nested folder structure.
'Returns True on success, False otherwise
Dim aFolders, oFso, i, firstIndex
On Error Resume Next
Set oFso = CreateObject("Scripting.FileSystemObject")
'Check if the path already exists
If Not oFso.FolderExists(sPath) Then
'Find the root drive and split the path in subfolder parts
aFolders = Split(sPath, "\")
'Get the root path from the complete path
If Left(sPath, 2) = "\\" Then
'If this is a UNC path then the root will be "\\server\share"
sPath = "\\" & aFolders(2) & "\" & aFolders(3)
firstIndex = 4
Else
'For a local path, the root is "X:"
aFolders = Split(sPath, "\")
sPath = aFolders(0)
firstIndex = 1
End If
'Loop through the aFolders array and create new folders if needed
For i = firstIndex to UBound(aFolders)
If Len(aFolders(i)) > 0 Then
sPath = sPath & "\" & aFolders(i)
If Not oFso.FolderExists(sPath) Then oFso.CreateFolder sPath
End If
Next
End If
CreateNestedFolder = (Err.Number = 0)
On Error GoTo 0
Set oFso = Nothing
End Function
Using the following code that I pulled from the web, I'm able to do a search in a single directory for excel files containing a string in a certain row. How would I allow this to be recursive in all the subfolders as well? I've found a few answers but I just don't understand how I would implement them in my code. I only started messing with VBScript yesterday and I'm pretty confused about how to make this work.
strComputer = "CAA-W74109188"
Set objExcel = CreateObject("Excel.Application", strComputer)
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set FileList = objWMIService.ExecQuery _
("ASSOCIATORS OF {Win32_Directory.Name='c:\TDRS'} Where " _
& "ResultClass = CIM_DataFile")
For Each objFile In FileList
If (objFile.Extension = "xlsm" or objFile.Extension = "xls") Then
Set objWorkbook = objExcel.Workbooks.Open(objFile.Name)
Set objWorksheet = objWorkbook.Worksheets(1)
If objExcel.Cells(3,10) = "Complete" or objExcel.Cells(3,9) = "Released" Then
Wscript.Echo objFile.FileName
End If
objExcel.DisplayAlerts = False
objworkbook.Saved = False
objWorkbook.Close False
End If
Next
objExcel.Quit
Here is an script that I used to delete files with, which I have modified for your needs. A recursive function is what you need to get the job done and I have always found them to be interesting and kind of hard to wrap my head around.
Dim Shell : Set Shell = WScript.CreateObject( "WScript.Shell" )
Dim oFSO : Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim objExcel : Set objExcel = CreateObject("Excel.Application")
Dim Paths(0)
Paths(0) = "c:\temp"
For Each Path in Paths
FolderScan(Path)
Next
Sub FolderScan(Folder)
Set base = oFSO.GetFolder(Folder)
If base.SubFolders.Count Then
For Each folder in Base.SubFolders
FolderScan(folder.Path)
Next
End If
Set files = base.Files
If files.Count Then
For Each File in files
If LCase(oFSO.GetExtensionName(File.Path) = "xlsm") or _
LCase(oFSO.GetExtensionName(File.Path) = "xls") Then
Dim objWorkbook : Set objWorkbook = objExcel.Workbooks.Open(File.Path)
Dim objWorkSheet : Set objWorkSheet = objWorkbook.Worksheets(1)
If (objExcel.Cells(3,10) = "Complete" or _
objExcel.Cells(3,9) = "Released") Then
Wscript.echo File.Path
End if
objExcel.DisplayAlerts = False
objExcel.Quit
End If
Next
End If
End Sub
Here's a generic, recursive function that iterates all files and subfolders of a given folder object.
Dim FileSystem
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder("c:\somefolder")
Sub DoFolder(Folder)
Dim SubFolder
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
Dim File
For Each File In Folder.Files
' Operate on each file
Next
End Sub
I have used similar before and I have local admin rights on every computer in our network. The following code generates an error on line 16 char 1.
line 16 For Each objsubfolder In objFSO.GetFolder("\" & strComputer & "%HOMEPATH%").subfolders
If the file exists it should write a line in the text file to indicate so for each user with a profile. If the file doesn't exist is should write a line in the same text file.
The error I get is Path not found 800A004C.
The computers.txt file contains a list of all the computers I want to check.
InputFile = "computers.txt"
Const DeleteReadOnly = True
Const ForAppending = 8
Dim goFS : Set goFS = CreateObject("Scripting.FileSystemObject")
Dim gsLog : gsLog = ".\logdemo.log"
WScript.Echo gsLog, "exists:", CStr(goFS.FileExists(gsLog))
' .OpenTextFile(filename[, iomode[, create[, format]]])
Dim goLog : Set goLog = goFS.OpenTextFile(gsLog, ForAppending, True)
goLog.WriteLine Now & " start"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(InputFile)
Do While Not (objFile.AtEndOfStream)
strComputer = objFile.ReadLine
For Each objsubfolder In objFSO.GetFolder("\\" & strComputer & "%HOMEPATH%").subfolders
If objFSO.FileExists(objsubfolder.Path & "\desktop\program1.LNK") Then
golog.WriteLine Join(Array(Now, strComputer, objsubfolder, "This Computer has Program 1"))
Else
golog.WriteLine Join(Array(Now, strComputer, objsubfolder, "None"))
End If
Next
Loop
golog.WriteLine Now & " End"
golog.WriteLine "-----------------------------------------------------------"
golog.Close
MsgBox "Done"
To prove that the FSO does not expand environment strings automagically:
Dim oFS : Set oFS = CreateObject("Scripting.FileSystemObject")
Dim oWS : Set oWS = CreateObject("WScript.Shell")
Dim sPath
sPath = "%windir%\addins"
WScript.Echo qq(sPath), CStr(oFS.FolderExists(sPath))
sPath = oWS.ExpandEnvironmentStrings("%windir%\addins")
WScript.Echo qq(sPath), CStr(oFS.FolderExists(sPath))
output:
"%windir%\addins" False
"C:\WINDOWS\addins" True
So put some work into feeding a valid path to .GetFolder().