I am running MS Office 2013, and I'm trying to list files in an smb directory from Excel VBA code.
unix_path = "\\smb" & unix_path
ListBox3.Clear
Dim fil As file
On Error Resume Next
If Dir(unix_path, vbDirectory) <> "" Then
Set MyObject = New Scripting.FileSystemObject
Set mysource = MyObject.GetFolder(unix_path)
For Each myFile In mysource.Files
If InStr(myFile.Name, ".xlsx") > 0 Then
UserForm1.ListBox3.AddItem myFile.Name
End If
This takes about 15 seconds. The directory itself has only 5 files in it.
It is worth mentioning that accessing the directory directly from explorer is much faster (less than 1 second).
FSO has a lot of overhead from my experience and I have experienced some odd issues over our network with it. I do not frequently use it unless I am doing something more specific than this situation.
Please test the following code and see if it still hangs,
unix_path = "\\smb" & unix_path
ListBox3.Clear
Dim fil As file
On Error Resume Next
If Dir(unix_path, vbDirectory) <> "" Then
mySource = Dir(unix_path & "*.xlsx")
Do until mySource = ""
UserForm1.ListBox3.AddItem mySource
mySource = Dir()
loop
end if
Related
I'm writing a program to open and run multiple VBA modules on a server to upload new data to the cloud. I need to run the modules every 5 minutes at least (preferably every 2 minutes) without stopping 24/7 for an extended period of time. So far, my code will work for 1000-4000 loops, but fails every 1-4 days. How can I make my program more robust?
I'm pretty new to VBScripts, but have pieced together some code that works pretty well from other examples I've found through my research. I've added some error handling (On Error Resume Next and an error check after each major operation) but there are still occasional errors that sneak through and stop the program.
The errors I've been seeing include "unknown VBA runtime error," permission errors (when opening the local log), and server errors. I've tried to mitigate or ignore these with pings and error handling, but some still manage to stop the code from looping.
I've also tried using the Windows Task Scheduler, but that can only go at most every 5 minutes and I couldn't get it to run reliably.
On Error Resume Next
Set WshShell = CreateObject("WScript.Shell")
Dim objFSO
Dim myLog
Dim myLocalLog
Dim pingResultV
Dim pingResultN
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objExcel = CreateObject("Excel.Application")
objExcel.DisplayAlerts = False
objExcel.Visible = True
Set myLog = objFSO.OpenTextFile("location of log on server", 8)
Set myLocalLog = objFSO.OpenTextFile("location of log on local hard drive", 8)
Dim i
i = 0
Do While i < 1000000
'Ping the server to check if the connection is open
PINGFlagV = Not CBool(WshShell.run("ping -n 1 server",0,True))
pingResultV = "Null"
'if the ping was successful, open each file in sequence and run the VBA modules
If PINGFlagV = True Then
timeStamp = Now()
Set Wb = objExcel.WorkBooks.Open("excel file on server",,True)
objExcel.Application.Run "VBA module to copy data to cloud"
objExcel.Application.Quit
If Err.Number <> 0 Then
myLocalLog.WriteLine(timeStamp & " Error in running VBA Script: " & Err.Description)
Err.Clear
End If
Set Wb2 = objExcel.WorkBooks.Open("second excel file on server",,True)
objExcel.Application.Run "VBA module to copy this data to cloud"
objExcel.Application.Quit
If Err.Number <> 0 Then
myLocalLog.WriteLine(timeStamp & " Error in running VBA Script 2: " & Err.Description)
Err.Clear
End If
'Write to the server log that it succeeded or failed
pingResultV = "Server Ping Success"
myLog.WriteLine(timeStamp & " i=" & i & " --- " & pingResultV)
Else
pingResultV = "Server Ping Failed"
timeStamp = Now()
End If
'Write to a local log whether the server was available or not
myLocalLog.WriteLine(timeStamp & " i=" & i & " --- " & pingResultV)
If Err.Number <> 0 Then
myLog.WriteLine(timeStamp & " Error in writing to local log: " & Err.Description)
Err.Clear
End If
'Time between iterations in milliseconds. 120000 ms = 2 minutes
WScript.Sleep(30000)
i = i + 1
Loop
I'm not asking for someone to overhaul my code, but I would appreciate any suggestions on improvements. I'm also open to methods other than VBScript if they're more robust.
Some additional background on the system that might be helpful: I have 2 computers that upload data to a server every few minutes, but these computers can't be connected to the internet for security reasons. I need to upload the data these computers generate to an internet database every few minutes so it can be accessed remotely. The code I wrote runs on a separate computer that's connected to the server and internet, and it periodically opens the excel files on the server in read-only mode and runs a VBA script that uploads new data lines to the cloud.
It's hard to tell whether your VBScript or your VBA module or both fail. From your error descriptions, I somewhat expect the latter to be the case. So I'd also suggest to check your VBA coda (again). As for this script, one thing I'd suggest to get rid off the permission / log file error would be to move the logging to its own method, e.g.
' *** VBScript (FSO) ***
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
' Log file
Const LOG_FILE = "C:\MyData\MyLog.txt"
Sub WriteLog (ByVal sLogFile, ByVal sText)
Dim oFso
Dim oLogFile
Set oFso = CreateObject("Scripting.FileSystemObject")
Set oLogFile = oFso.OpenTextFile(sLogFile, ForAppending, True)
' Prefix log message with current date/time
sText = Now & " " & sText
oLogFile.WriteLine sText
oLogFile.Close
' Free resources
Set oLogFile = Nothing
Set oFso = Nothing
End Sub
And call it like
If Err.Number <> 0 Then
WriteLog LOG_FILE, "Error in writing to local log: " & CStr(Err.Number) & ", " & Err.Description
Err.Clear
End If
I also suggest to release all resources at the end of the loop, e.g. the Excel object, for which you need to move the object creation into the loop:
Dim i
i = 0
Do While i < 1000000
' Start of loop
Set objExcel = CreateObject("Excel.Application")
objExcel.DisplayAlerts = False
objExcel.Visible = True
' Do your stuff ...
' End of Loop -> free resources
Set Wb = Nothing
Set Wb2 = Nothing
objExcel.WorkBooks.Close
Set objExcel = Nothing
' Time between iterations in milliseconds. 120000 ms = 2 minutes
WScript.Sleep(30000)
i = i + 1
Loop
And as I'm not an Excel expert, I wonder if objExcel.Visible = True does make sense here or if it would better be set to False?
I'm trying to have windows run this vbs file at the start of windows so that the computer can greet me with phrases that I've made and saved as wav files.
I already have one vbs file where it plays a sound file but I want it to randomly pick one from a specific directory so that it doesn't get old hearing the same thing over and over again, plus add a surprise factor because I don't know which one it'll use each time I start the computer.
Dim oPlayer
Set oPlayer = CreateObject("WMPlayer.OCX")
' Play audio
oPlayer.URL = "C:\Users\david\OneDrive\Desktop\GLaDOS
wav\Edited\hello_david_youre_back_i_see.wav"
oPlayer.controls.play
While oPlayer.playState <> 1 ' 1 = Stopped
WScript.Sleep 100
Wend
' Release the audio file
oPlayer.close
Thanks for your help in advance.
Option Explicit
Dim oFolderItems
Dim oFolderItem
Dim aFiles
Set oFolderItems = CreateObject("Shell.Application").NameSpace("C:\Users\david\OneDrive\Desktop\GLaDOSwav\Edited").Items
oFolderItems.Filter 64 + 128, "*.wav"
With CreateObject("Scripting.Dictionary")
For Each oFolderItem In oFolderItems
.Item(.Count) = oFolderItem.Path
Next
aFiles = .Items
End With
Randomize
With CreateObject("WMPlayer.OCX")
.URL = aFiles(Int(Rnd * UBound(aFiles) + 1))
.controls.play
Do While .playState <> 1
WScript.Sleep 100
Loop
.close
End With
I've written a small VBScript to creates a .zip file and then copies the contents of a specified folder into that .zip file.
I copy the files over one by one for a reason (I know I can do the whole lot at once). However my problem is when I try to copy them one by one without a WScript.Sleep between each loop iteration I get a "File not found or no read permission." error; if I place a WScript.Sleep 200 after each write it works but not 100% of the time.
Pretty much I'd like to get rid of the Sleep function and not rely on that because depending on the file size it may take longer to write therefore 200 milliseconds may not be enough etc.
As you can see with the small piece of code below, I loop through the files, then if they match the extension I place them into the .zip (zipFile)
For Each file In folderToZip.Items
For Each extension In fileExtensions
if (InStr(file, extension)) Then
zipFile.CopyHere(file)
WScript.Sleep 200
Exit For
End If
Next
Next
Any suggestions on how I can stop relying on the Sleep function?
Thanks
This is how we do it in VB6. After calling CopyHere on the zip we wait for async compression to complete like this
Call Sleep(100)
Do
Do While Not pvCanOpenExclusive(sZipFile)
Call Sleep(100)
Loop
Call Sleep(100)
Loop While Not pvCanOpenExclusive(sZipFile)
where the helper function looks like this
Private Function pvCanOpenExclusive(sFile As String) As Boolean
Dim nFile As Integer
nFile = FreeFile
On Error GoTo QH
Open sFile For Binary Access Read Lock Write As nFile
Close nFile
pvCanOpenExclusive = True
QH:
End Function
Nice side-effect is that even if zipping fails this will not end up in infinite loop.
The trouble comes when accessing the zip-file when it's closed by zipfldr.dll, that is when pvCanOpenExclusive returns true.
You are correct, CopyHere is asynchronous.
When I do this in a vbscript, I sleep until the count of files in the zip, is greater than or equal to the count of files copied in.
Sub NewZip(pathToZipFile)
WScript.Echo "Newing up a zip file (" & pathToZipFile & ") "
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim file
Set file = fso.CreateTextFile(pathToZipFile)
file.Write Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, 0)
file.Close
Set fso = Nothing
Set file = Nothing
WScript.Sleep 500
End Sub
Sub CreateZip(pathToZipFile, dirToZip)
WScript.Echo "Creating zip (" & pathToZipFile & ") from (" & dirToZip & ")"
Dim fso
Set fso= Wscript.CreateObject("Scripting.FileSystemObject")
If fso.FileExists(pathToZipFile) Then
WScript.Echo "That zip file already exists - deleting it."
fso.DeleteFile pathToZipFile
End If
If Not fso.FolderExists(dirToZip) Then
WScript.Echo "The directory to zip does not exist."
Exit Sub
End If
NewZip pathToZipFile
dim sa
set sa = CreateObject("Shell.Application")
Dim zip
Set zip = sa.NameSpace(pathToZipFile)
WScript.Echo "opening dir (" & dirToZip & ")"
Dim d
Set d = sa.NameSpace(dirToZip)
' for diagnostic purposes only
For Each s In d.items
WScript.Echo s
Next
' http://msdn.microsoft.com/en-us/library/bb787866(VS.85).aspx
' ===============================================================
' 4 = do not display a progress box
' 16 = Respond with "Yes to All" for any dialog box that is displayed.
' 128 = Perform the operation on files only if a wildcard file name (*.*) is specified.
' 256 = Display a progress dialog box but do not show the file names.
' 2048 = Version 4.71. Do not copy the security attributes of the file.
' 4096 = Only operate in the local directory. Don't operate recursively into subdirectories.
WScript.Echo "copying files..."
zip.CopyHere d.items, 4
Do Until d.Items.Count <= zip.Items.Count
Wscript.Sleep(200)
Loop
End Sub
You can try accessing the file you've just copied, for example with an "exists" check:
For Each file In folderToZip.Items
For Each extension In fileExtensions
If LCase(oFSo.GetExtensionName(file)) = LCase(extension) Then
zipFile.CopyHere(file)
Dim i: i = 0
Dim target: target = oFSO.BuildPath(zipFile, oFSO.GetFileName(file))
While i < 100 And Not oFSO.FileExists(target)
i = i + 1
WScript.Sleep 10
Wend
Exit For
End If
Next
Next
I'm not sure if target is calculated correctly for this use context, but you get the idea. I'm a bit surprised that this error occurs in the first place... FileSystemObject should be strictly synchronous.
If all else fails, do this:
For Each file In folderToZip.Items
For Each extension In fileExtensions
If LCase(oFSo.GetExtensionName(file)) = LCase(extension) Then
CompressFailsafe zipFile, file
Exit For
End If
Next
Next
Sub CompressFailsafe(zipFile, file)
Dim i: i = 0
Const MAX = 100
On Error Resume Next
While i < MAX
zipFile.CopyHere(file)
If Err.Number = 0 Then
i = MAX
ElseIf Err.Number = xxx ''# use the actual error number!
Err.Clear
WScript.Sleep 100
i = i + 1
Else
''# react to unexpected error
End Of
Wend
On Error GoTo 0
End Sub
The solution we used after much debugging and QA on various windows flavours, including fast and slow machines and machines under heavy CPU load was the following snippet.
Critique and improvements welcome.
We were not able to find a way of doing this without a loop, that is, if you wanted to do some validation or post zipping work.
The goal was to build something that ran reliably on as many windows flavours as possible. Ideally as natively as possible too.
Be advised that this code is still is NOT 100% reliable but its seems to be ~99%. As stable as we could get it with the dev and QA time available.
Its possible that increasing iSleepTime could make it 100%
Points of note:
The unconditional sleep seems to be the most reliable and compatible approach we found
The iSleepTime should not be reduced, it seems the more frequently the loop runs, the higher the probability of an error, seemingly related to the internal operations of the zip/copy process
iFiles is the source file count
The more simplistic the loop was, the better, for example outputting oZippp.Items().Count in the loop caused inexplicable errors that looked like they could be related to file access/sharing/locking violations. We didn't spend time tracing to find out.
It seems on Windows 7 anyway, that the internals of the zipping process use a temp file located in the cwd of the compressed zip folder, you can see this during long running zips by refreshing your explorer window or listing dir with cmd
We had success with this code on Windows 2000, XP, 2003, Vista, 7
You'd probably want to add a timeout in the loop, to avoid infinite loops
'Copy the files to the compressed folder
oZippp.CopyHere oFolder.Items()
iSleeps = 0
iSleepTime = 5
On Error Resume Next
Do
iSleeps = iSleeps + 1
wScript.Sleep (iSleepTime * 1000)
Loop Until oZippp.Items().Count = iFiles
On Error GoTo 0
If iFiles <> oZippp.Items().Count Then
' some action to handle this error case
Else
' some action to handle success
End If
Here is a trick I used in VB; get the length of the zip file before the change and wait for it to change - then wait another second or two. I only needed two specific files but you could make a loop out of this.
Dim s As String
Dim F As Object 'Shell32.Folder
Dim h As Object 'Shell32.Folder
Dim g As Object 'Shell32.Folder
Dim Flen As Long, cntr As Long, TimerInt As Long
Err.Clear
s = "F:\.zip"
NewZipFolder s
Flen = FileLen(s)
Set F = CreateObject("Shell.Application").namespace(CVar(s))
TimerInt = FileLen("F:\MyBigFile.txt") / 100000000 'set the loop longer for bigger files
F.CopyHere "F:\DataSk\DemoData2010\Test.mdf"
Do
cntr = Timer + TimerInt
Do
DoEvents: DoEvents
Loop While cntr > Timer
Debug.Print Flen
Loop While Flen = FileLen(s)
cntr = Timer + (TimerInt / 2)
Do
DoEvents: DoEvents
Loop While cntr > Timer
Set F = Nothing
Set F = CreateObject("Shell.Application").namespace(CVar(s))
F.CopyHere "F:\MynextFile.txt"
MsgBox "Done!"
How do I save an entire VB6 project to a new folder? Modules and all. I'm in a position where I need to work with some old VB6 projects. I'd like to save them to a new folder but when I save the project, all that is saved is the vbp file. No modules, no frm files. I want to be able to save all the info to a single folder without moving each BAS file one at a time. Is this even possible?
Addition: The first 2 replies make good sense. But my problem is that the BAS modules seem to be scattered all over the place. Making Windows Explorer do the work a bit tricky. If I have to I will but was looking for an easier way.
Thanks
Given the new "addition" to the question:
Move the VBP and the files in Windows Explorer to a completely new directory.
Open the VBP in a text editor and change any absolute paths to relative paths. VBP files are simple text files, and the format is even documented in the VB6 manual.
Here's an example. This evil VBP below has many absolute paths
Type=Exe
Form=c:\who\knows\where\B_Form.frm
Module=CModule; z:\magic\mapped\network\drive\heehee\C_Module.bas
Class=DClass; x:\personal\usb\stick\D_Class.cls
It would be changed to this benign VBP, which references local copies of the files. You can use relative paths for subdirectories.
Type=Exe
Form=B_Form.frm
Module=CModule; C_Module.bas
Class=DClass; subdirectory\D_Class.cls
If you mean from within Visual Studio, I don't think you can except by doing Save As for each file...
But the simpler approach is to just use Windows Explorer and copy the whole folder structure for the solution into another folder, (or do a recursive "Get" from your source code repository to a different local destination), and then open the solution or project file in the new location... The pointers in the project file that tell Visual Studio where 5all the individual source code and other files are located are generally all stored as relative paths, relative to the folder that the project file is in...
It's been a while since I used VB6, but I'd be tempted to move them using Windows Explorer, then manually edit the VBP file to point to the new locations afterwards. If I remember right, relative paths are fine in the VBP, so you may not even need to manke any changes.
Unbind from source control, if capable/appropriate.
Check into source control as a brand new solution/project
Recursive 'get' from your SCM into a new directory.
There's your new copy.
Create a VB6 Add-in. You can download it from: http://pan.baidu.com/s/1CXO3k
Or you can use below code to create your own.
Option Explicit
Public VBInstance As VBIDE.VBE
Public Connect As Connect
Private Sub CancelButton_Click()
Connect.Hide
End Sub
Private Sub OKButton_Click()
On Error Resume Next
Dim strProject As String
Dim strPath As String
Dim strPath2 As String
Dim strFile As String
Dim strPrjFile As String
Dim rst As VbMsgBoxResult
Dim m, n As Long
Dim col2 As Collection, col As Collection
Dim vbCom As VBComponent
Dim fso As FileSystemObject
Dim ts As TextStream
Dim f1 As String, f2 As String
strProject = Me.VBInstance.ActiveVBProject.FileName
strPath = ParseFileName(strProject, strPrjFile)
strPath2 = setFolder
If strPath = "" Or strPath = strPath2 Then
MsgBox "target folder is invalid or same as the project folder. Can't copy."
Exit Sub
End If
Set col2 = New Collection
Set col = New Collection
Set fso = New FileSystemObject
Set ts = fso.CreateTextFile(strPath2 & "\wemeet.log", False)
For m = Me.VBInstance.ActiveVBProject.VBComponents.Count To 1 Step -1
Set vbCom = Me.VBInstance.ActiveVBProject.VBComponents(m)
For n = 1 To vbCom.FileCount
f1 = vbCom.FileNames(n)
ParseFileName f1, strFile
f2 = strPath2 & "\" & strFile
fso.CopyFile f1, f2
col.Add f1
col2.Add f2
ts.WriteLine "" & Now() & " [Move]: " & f1
ts.WriteLine "" & Now() & " [To ]: " & f2
ts.WriteBlankLines 1
Next
Me.VBInstance.ActiveVBProject.VBComponents.Remove vbCom
Next
For m = 1 To col2.Count
Me.VBInstance.ActiveVBProject.VBComponents.AddFile col2.Item(m)
ts.WriteLine "" & Now() & " [Add]: " & col2.Item(m)
ts.WriteBlankLines 1
Next
Me.VBInstance.ActiveVBProject.SaveAs strPath2 & "\" & strPrjFile
ts.WriteLine "" & Now() & " [SaveAs]: " & strPath2 & "\" & strPrjFile
ts.WriteBlankLines 1
ts.Close
fso.OpenTextFile strPath2 & "\wemeet.log"
Set fso = Nothing
Set col = Nothing
Set col2 = Nothing
Set vbCom = Nothing
Connect.Hide
End Sub
Private Function ParseFileName(ByVal sPath As String, ByRef sFile As String) As String
Dim fso As New FileSystemObject
If fso.FileExists(sPath) Then
ParseFileName = fso.GetParentFolderName(sPath)
sFile = fso.GetFileName(sPath)
Else
ParseFileName = ""
sFile = ""
End If
Set fso = Nothing
End Function
Private Function setFolder() As String
Dim objDlg As Object
Dim objStartFolder As Object
Set objDlg = CreateObject("Shell.Application")
Set objStartFolder = objDlg.BrowseForFolder(&H0, "Select a folder", &H10 + &H1)
If InStr(1, TypeName(objStartFolder), "Folder") > 0 Then
setFolder = objStartFolder.ParentFolder.ParseName(objStartFolder.Title).Path
End If
Set objDlg = Nothing
End Function
Is the ZIP compression that is built into Windows XP/Vista/2003/2008 able to be scripted at all? What executable would I have to call from a BAT/CMD file? or is it possible to do it with VBScript?
I realize that this is possible using WinZip, 7-Zip and other external applications, but I'm looking for something that requires no external applications to be installed.
There are VBA methods to zip and unzip using the windows built in compression as well, which should give some insight as to how the system operates. You may be able to build these methods into a scripting language of your choice.
The basic principle is that within windows you can treat a zip file as a directory, and copy into and out of it. So to create a new zip file, you simply make a file with the extension .zip that has the right header for an empty zip file. Then you close it, and tell windows you want to copy files into it as though it were another directory.
Unzipping is easier - just treat it as a directory.
In case the web pages are lost again, here are a few of the relevant code snippets:
ZIP
Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Function Split97(sStr As Variant, sdelim As String) As Variant
'Tom Ogilvy
Split97 = Evaluate("{""" & _
Application.Substitute(sStr, sdelim, """,""") & """}")
End Function
Sub Zip_File_Or_Files()
Dim strDate As String, DefPath As String, sFName As String
Dim oApp As Object, iCtr As Long, I As Integer
Dim FName, vArr, FileNameZip
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"
'Browse to the file(s), use the Ctrl key to select more files
FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True, Title:="Select the files you want to zip")
If IsArray(FName) = False Then
'do nothing
Else
'Create empty Zip File
NewZip (FileNameZip)
Set oApp = CreateObject("Shell.Application")
I = 0
For iCtr = LBound(FName) To UBound(FName)
vArr = Split97(FName(iCtr), "\")
sFName = vArr(UBound(vArr))
If bIsBookOpen(sFName) Then
MsgBox "You can't zip a file that is open!" & vbLf & _
"Please close it and try again: " & FName(iCtr)
Else
'Copy the file to the compressed folder
I = I + 1
oApp.Namespace(FileNameZip).CopyHere FName(iCtr)
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = I
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
End If
Next iCtr
MsgBox "You find the zipfile here: " & FileNameZip
End If
End Sub
UNZIP
Sub Unzip1()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim strDate As String
Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
MultiSelect:=False)
If Fname = False Then
'Do nothing
Else
'Root folder for the new folder.
'You can also use DefPath = "C:\Users\Ron\test\"
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create the folder name
strDate = Format(Now, " dd-mm-yy h-mm-ss")
FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"
'Make the normal folder in DefPath
MkDir FileNameFolder
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
'If you want to extract only one file you can use this:
'oApp.Namespace(FileNameFolder).CopyHere _
'oApp.Namespace(Fname).items.Item("test.txt")
MsgBox "You find the files here: " & FileNameFolder
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
End Sub
Yes, this can be scripted with VBScript. For example the following code can create a zip from a directory:
Dim fso, winShell, MyTarget, MySource, file
Set fso = CreateObject("Scripting.FileSystemObject")
Set winShell = createObject("shell.application")
MyTarget = Wscript.Arguments.Item(0)
MySource = Wscript.Arguments.Item(1)
Wscript.Echo "Adding " & MySource & " to " & MyTarget
'create a new clean zip archive
Set file = fso.CreateTextFile(MyTarget, True)
file.write("PK" & chr(5) & chr(6) & string(18,chr(0)))
file.close
winShell.NameSpace(MyTarget).CopyHere winShell.NameSpace(MySource).Items
do until winShell.namespace(MyTarget).items.count = winShell.namespace(MySource).items.count
wscript.sleep 1000
loop
Set winShell = Nothing
Set fso = Nothing
You may also find http://www.naterice.com/blog/template_permalink.asp?id=64 helpful as it includes a full Unzip/Zip implementation in VBScript.
If you do a size check every 500 ms rather than a item count it works better for large files. Win 7 writes the file instantly although it's not finished compressing:
set fso=createobject("scripting.filesystemobject")
Set h=fso.getFile(DestZip)
do
wscript.sleep 500
max = h.size
loop while h.size > max
Works great for huge amounts of log files.
Just for clarity: GZip is not an MS-only algorithm as suggested by Guy Starbuck in his comment from August.
The GZipStream in System.IO.Compression uses the Deflate algorithm, just the same as the zlib library, and many other zip tools. That class is fully interoperable with unix utilities like gzip.
The GZipStream class is not scriptable from the commandline or VBScript, to produce ZIP files, so it alone would not be an answer the original poster's request.
The free DotNetZip library does read and produce zip files, and can be scripted from VBScript or Powershell. It also includes command-line tools to produce and read/extract zip files.
Here's some code for VBScript:
dim filename
filename = "C:\temp\ZipFile-created-from-VBScript.zip"
WScript.echo("Instantiating a ZipFile object...")
dim zip
set zip = CreateObject("Ionic.Zip.ZipFile")
WScript.echo("using AES256 encryption...")
zip.Encryption = 3
WScript.echo("setting the password...")
zip.Password = "Very.Secret.Password!"
WScript.echo("adding a selection of files...")
zip.AddSelectedFiles("*.js")
zip.AddSelectedFiles("*.vbs")
WScript.echo("setting the save name...")
zip.Name = filename
WScript.echo("Saving...")
zip.Save()
WScript.echo("Disposing...")
zip.Dispose()
WScript.echo("Done.")
Here's some code for Powershell:
[System.Reflection.Assembly]::LoadFrom("c:\\dinoch\\bin\\Ionic.Zip.dll");
$directoryToZip = "c:\\temp";
$zipfile = new-object Ionic.Zip.ZipFile;
$e= $zipfile.AddEntry("Readme.txt", "This is a zipfile created from within powershell.")
$e= $zipfile.AddDirectory($directoryToZip, "home")
$zipfile.Save("ZipFiles.ps1.out.zip");
In a .bat or .cmd file, you can use the zipit.exe or unzip.exe tools. Eg:
zipit NewZip.zip -s "This is string content for an entry" Readme.txt src
There are both zip and unzip executables (as well as a boat load of other useful applications) in the UnxUtils package available on SourceForge (http://sourceforge.net/projects/unxutils). Copy them to a location in your PATH, such as 'c:\windows', and you will be able to include them in your scripts.
This is not the perfect solution (or the one you asked for) but a decent work-a-round.
to create a compressed archive you can use the utility MAKECAB.EXE
Here'a my attempt to summarize built-in capabilities windows for compression and uncompression - How can I compress (/ zip ) and uncompress (/ unzip ) files and folders with batch file without using any external tools?
with a few given solutions that should work on almost every windows machine.
As regards to the shell.application and WSH I preferred the jscript
as it allows a hybrid batch/jscript file (with .bat extension) that not require temp files.I've put unzip and zip capabilities in one file plus a few more features.