I'm looking for a code to zip the folders of a path specified in my cells(1,1).value
After googling i found vba codes to zip the files of a folder but they are using WinZip.
My office machine does not have a WinZip installed and we are restricted to use WinZip. Could anyone please help with this. I need to use the default zip (Right click -> Send to compressed ZIP folder)
Thanks!
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
Powered by Ron De Bruin - http://www.rondebruin.nl/win/s7/win001.htm
I have found it helpful to make a couple of tweaks to make this more friendly for the user (which for this sort of thing is often myself).
Limit how long you're willing to wait for the file & message the user if that time limit was reached without success
Add a DoEvents so that you can ctrl+break to pause the code in case you want to inspect (otherwise - can sometimes have to crash Excel, in my experience)
Add a statusbar update so the user knows what's going on
Sub ZipTheFile(ByVal strPath As String, ByVal strFileNameXls As String, ByVal strFileNameZip As String)
'Taken largely from Ron De Bruin - https://www.rondebruin.nl/win/s7/win001.htm
'Create empty Zip File
NewZip (strPath & strFileNameZip)
'Copy the file in the compressed folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(strPath & strFileNameZip).CopyHere strPath & strFileNameXls
'Keep script waiting until Compressing is done (OR we waited more than 40 seconds...)
On Error Resume Next
i = 0
Do Until oApp.Namespace(strPath & strFileNameZip).Items.Count = 1 Or i > 40 '<-- set how long you're willing to wait here
Application.Wait (Now + TimeValue("0:00:01"))
DoEvents
Application.StatusBar = "Waiting for Zip - counter: " & i
i = i + 1
Loop
On Error GoTo 0
If i > 40 Then MsgBox "there seems to have been a problem putting the file into the zip foder. Check the zip at: " & strPath & strFileNameZip
End Sub
Sub NewZip(sPath) 'You need this sub-routine as well
'Create empty Zip File
'by Ron De Bruin - https://www.rondebruin.nl/win/s7/win001.htm
'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
STILL Powered by Ron De Bruin - http://www.rondebruin.nl/win/s7/win001.htm
Related
Some of VBA Experts have helped me a lot and have fixed the code for me which moves one file one at a time but it first moves the oldest file in the folder. However here i have a complex situation which for now not resolving. i.e. I would like to add a timer of two hours i.e. the file should move after two hour.
e.g. If a file named "North_West data" whose modified time is 6:40 PM i would like the code to move it exactly after two hours. Similarly at the next run the next file which has to be moved has filed modified time e.g. 6:50 PM so the VBA code should actually move it exactly after two hours. this means each file should have automatic two hours delay timer in it, i hope i am able to clarify the query.
Function OldestFile(strFold As String) As String
Dim FSO As Object, Folder As Object, File As Object, oldF As String
Dim lastFile As Date: lastFile = Now
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(strFold)
For Each File In Folder.Files
If File.DateLastModified < lastFile Then
lastFile = File.DateLastModified: oldF = File.Name
End If
Next
OldestFile = oldF
End Function
Sub MoveOldestFile()
Dim FromPath As String, ToPath As String, fileName As String
FromPath = "E:\Source\"
ToPath = "E:\Destination\"
fileName = OldestFile(FromPath)
If Dir(ToPath & fileName) = "" Then
Name FromPath & fileName As ToPath & fileName
Else
MsgBox "File """ & fileName & """ already moved..."
End If
End Sub
You can check the previously resolved query here
Previous query
Please, try the next way. Basically, it uses a VBScript able to catch file creation event, which sends the created file name and the moment of creation to a workbook which should be open all the time.
Create a VBScript and name it "FolderMonitor.vbs". To do that, please copy the next code in an empty Notepad window:
Dim oExcel, strWB, nameWB, wb
strWB = "C:\Teste VBA Excel\Folder monitor.xlsm" 'use here the path of the waiting workbook!
nameWB = Left(strWB, InStr(StrReverse(strWB), "\") - 1)
nameWB = Right(strWB, Len(nameWB))
Set objExcel = GetObject(,"Excel.Application")
Set wb = objExcel.Workbooks(nameWB)
if wb is nothing then wbscript.quit 'the necessary workbook is not open...
dim strComputer, strDirToMonitor, strTime, objWMIService, colMonitoredEvents, objEventObject, MyFile
strComputer = "."
'# WMI needs two backslashes (\\) as path separator and each of it should be excaped.
'# So, you must use 4 backslashes (\\\\) as path separator!
strDirToMonitor = "C:\\\\test\\\\test" 'use here your path
'# Monitor Above every 10 secs...
strTime = "10"
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colMonitoredEvents = objWMIService.ExecNotificationQuery _
("SELECT * FROM __InstanceOperationEvent WITHIN " & strTime & " WHERE " _
& "Targetinstance ISA 'CIM_DirectoryContainsFile' and " _
& "TargetInstance.GroupComponent= " _
& "'Win32_Directory.Name=" & Chr(34) & strDirToMonitor & Chr(34) & "'")
Do While True
Set objEventObject = colMonitoredEvents.NextEvent()
Select Case objEventObject.Path_.Class
Case "__InstanceCreationEvent"
MyFile = StrReverse(objEventObject.TargetInstance.PartComponent)
' Get the string to the left of the first \ and reverse it
MyFile = (StrReverse(Left(MyFile, InStr(MyFile, "\") - 1)))
MyFile = Mid(MyFile, 1, Len(MyFile) - 1)
'send the information to the waiting workbook:
objExcel.Application.Run "'" & strWB & "'!GetMonitorInformation", Array(MyFile,Now)
' some other events can be used starting from here...
End Select
Loop
And save it as stated above. But take care to not save it as "FolderMonitor.vbs.txt". In order to avoid that, when saving you should change 'Save as typefrom defaultText documents (.txt)toAll files (.*)`!
In order to make the following code working as it is, you should create a folder named "VBScript" in the folder where the workbook running the code exists and place the above VBScript inside!
Copy the next code in a standard module of a xlsm workbook. In order to be called by the above script, as it is, you should name it "Folder monitor.xlsm":
Option Explicit
Private Const ourScript As String = "FolderMonitor.vbs"
Private Const fromPath As String = "E:\Source\"
Sub startMonitoring()
Dim strVBSPath As String
strVBSPath = ThisWorkbook.Path & "\VBScript\" & ourScript
TerminateMonintoringScript 'to terminate monitoring script, if running..
Shell "cmd.exe /c """ & strVBSPath & """", 0
End Sub
Sub TerminateMonintoringScript()
Dim objWMIService As Object, colItems As Object, objItem As Object, Msg As String
Set objWMIService = GetObject("winmgmts:\\" & "." & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", "WQL", 48)
For Each objItem In colItems
If objItem.Caption = "wscript.exe" Then
'// msg Contains the path of the exercutable script and the script name
On Error Resume Next
Msg = objItem.CommandLine 'for the case of null
On Error GoTo 0
'// If wbscript.exe runs the monitoring script:
If InStr(1, Msg, ourScript) > 0 Then
Debug.Print "Terminate Wscript process..."
objItem.Terminate 'terminate process
End If
End If
Next
Set objWMIService = Nothing: Set colItems = Nothing
End Sub
Sub GetMonitorInformation(arr As Variant)
'call DoSomething Sub after 2 hours (now IT WILL RUN AFTER 1 MINUTE, for testing reasons...)
'for running after 2 hours you should change "00:01:00" in "02:00:00":
arr(0) = Replace(arr(0), "'", "''") 'escape simple quote (') character'
Application.OnTime CDate(arr(1)) + TimeValue("00:01:00"), "'DoSomething """ & CStr(arr(0)) & """'"
Debug.Print "start " & Now 'just for testing (wait a minute...)
'finaly, this line should be commented.
End Sub
Sub DoSomething(strFileName As String)
Const toPath As String = "E:\Destination\"
If Dir(toPath & strFileName) = "" Then
Name fromPath & strFileName As toPath & strFileName
Debug.Print strFileName & " moved from " & fromPath & " to " & toPath 'just for testing...
Else
MsgBox "File """ & toPath & strFileName & """ already exists in this location..."
End If
End Sub
a. You firstly should run "startMonitoring" Sub. It can be called from the Workbook_Open event.
b. Copy files in the monitored folder and check if they are copied as it should. Note that the code as it is move it after a minute. It is commented to exactly show what and how it can be changed...
I have mutiple folders (appox. 400 and could increase up in some cases) and each of these folders contains some files. I wanted to zip all these folders with their contents and create 400 zip files. I wanted to automate this with VBA. I tried with the following code. The standard one which uses shell application.
Sub Zip_All_Files_in_Folder_Browse()
Dim FileNameZip, FolderName, oFolder
Dim strDate As String, DefPath As String
Dim oApp As Object
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"
Set oApp = CreateObject("Shell.Application")
'Browse to the folder
Set oFolder = oApp.BrowseForFolder(0, "Select folder to Zip", 512)
If Not oFolder Is Nothing Then
'Create empty Zip File
NewZip (FileNameZip)
FolderName = oFolder.Self.Path
If Right(FolderName, 1) <> "\" Then
FolderName = FolderName & "\"
End If
'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
On Error GoTo 0
MsgBox "You find the zipfile here: " & FileNameZip
End If
End Sub
Sub NewZip(sPath)
'Create empty Zip File
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
I can call the above code in loop to create mutiple zip folders. However, I was wondering if this is really an effcient process! Is there any alternative for this procedure? Sometimes my count of folders to be zipped may go beyound 1000. So I would really appreciate your suggestions and ideas on this.
Thank you in advance
Well, if you don't need everything separated into 400 different folders, you can combine them all into one zipped folder.
Sub Zip_All_Files_in_Folder_Browse()
Dim FileNameZip, FolderName, oFolder
Dim strDate As String, DefPath As String
Dim oApp As Object
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"
Set oApp = CreateObject("Shell.Application")
'Browse to the folder
Set oFolder = oApp.BrowseForFolder(0, "Select folder to Zip", 512)
If Not oFolder Is Nothing Then
'Create empty Zip File
NewZip (FileNameZip)
FolderName = oFolder.Self.Path
If Right(FolderName, 1) <> "\" Then
FolderName = FolderName & "\"
End If
'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
On Error GoTo 0
MsgBox "You find the zipfile here: " & FileNameZip
End If
End Sub
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
https://www.rondebruin.nl/win/s7/win001.htm
I'm stepping through the code to export a module using this post, but nothing happens. Is there a security setting to allow VBA permission to export a module?
I'm copying a few tabs from a workbook into a new workbook, but the tabs have macros which lead to broken links. To get around this I want to move the module and re-associate the macro. If I can't get this to work I will just copy the whole workbook and delete the info I don't want in the destination.
Here's the code from the above post:
Public Sub CopyModule(SourceWB As Workbook, strModuleName As String, TargetWB As Workbook)
' Description: copies a module from one workbook to another
' example: CopyModule Workbooks(ThisWorkbook), "Module2",
' Workbooks("Food Specials Rolling Depot Memo 46 - 01.xlsm")
' Notes: If Module to be copied already exists, it is removed first,
' and afterwards copied
Dim strFolder As String
Dim strTempFile As String
Dim FName As String
If Trim(strModuleName) = vbNullString Then
Exit Sub
End If
If TargetWB Is Nothing Then
MsgBox "Error: Target Workbook " & TargetWB.Name & " doesn't exist (or closed)", vbCritical
Exit Sub
End If
strFolder = SourceWB.Path
If Len(strFolder) = 0 Then strFolder = CurDir
' create temp file and copy "Module2" into it
strFolder = strFolder & "\"
strTempFile = strFolder & "~tmpexport.bas"
On Error Resume Next
FName = Environ("Temp") & "\" & strModuleName & ".bas"
If Dir(FName, vbNormal + vbHidden + vbSystem) <> vbNullString Then
Err.Clear
Kill FName
If Err.Number <> 0 Then
MsgBox "Error copying module " & strModuleName & " from Workbook " & SourceWB.Name & " to Workbook " & TargetWB.Name, vbInformation
Exit Sub
End If
End If
' remove "Module2" if already exits in destination workbook
With TargetWB.VBProject.VBComponents
.Remove .Item(strModuleName)
End With
' copy "Module2" from temp file to destination workbook
SourceWB.VBProject.VBComponents(strModuleName).Export strTempFile
TargetWB.VBProject.VBComponents.Import strTempFile
Kill strTempFile
On Error GoTo 0
End Sub
I am trying to open a folder full of powerpoint files all with arabic (unicode) names and and edit them, then I knew about VBA and found this code here
yet when I tried to use it it doesn't open the files and always come with and error in the 'open' function
I also tried this solution here too -the StrConv function - but it doesn't seem to work either.
here is my final code
Sub BatchSave()
' Opens each PPT in the target folder and saves as PPT97-2003 format
Dim sFolder As String
Dim sPresentationName As String
Dim oPresentation As Presentation
' Get the foldername:
'sFolder = InputBox("Folder containing PPT files to process", "Folder")
sFolder = "E:\taranem\tttt\tranem"
If sFolder = "" Then
Exit Sub
End If
' Make sure the folder name has a trailing backslash
If Right$(sFolder, 1) <> "\" Then
sFolder = sFolder & "\"
End If
' Are there PPT files there?
If Len(Dir$(sFolder & "*.PPT")) = 0 Then
MsgBox "Bad folder name or no PPT files in folder."
Exit Sub
End If
' Open and save the presentations
sPresentationName = Dir$(sFolder & "*.ppt")
While sPresentationName <> ""
f = sFolder & StrConv(sPresentationName, vbFromUnicode)
Set oPresentation = Presentations.Open(f, , , False)
Call oPresentation.SaveAs(sFolder & "N_" & sPresentationName, ppSaveAsShow)
oPresentation.Close
' New presentation is now saved as N_originalname.ppt
' Now let's rename them - comment out the next couple lines
' if you don't want to do this
' Original.PPT to Original.PPT.OLD
Name sFolder & sPresentationName As sFolder & sPresentationName & ".OLD"
' N_Original.PPT to Original.PPT
Name sFolder & "N_" & sPresentationName As sFolder & sPresentationName
sPresentationName = Dir$()
Wend
MsgBox "DONE"
End Sub
indentation is missed up I know xD
When I get to the line
oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items
I get a:
run time error 91, object variable not set
The zip file is created and in the working folder as well as the files to be zipped. I've checked my variables and they are set and correct.
Sub Zip_genie()
Dim FileNameZip, FolderName, oFolder
Dim strDate As String, DefPath As String
Dim oApp As Object
DefPath = "c:\users\" & Environ("Username") & "\documents\Appraiser_Genie\working\"
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
ChDir DefPath
FileNameZip = "report.zip"
Set oApp = CreateObject("Shell.Application")
'Create empty Zip File
NewZip (FileNameZip)
FolderName = DefPath
Debug.Print (FolderName)
Debug.Print (FileNameZip)
'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
On Error GoTo 0
'MsgBox "You find the zipfile here: " & FileNameZip
End Sub
Try specifying the full pathname of the zip file.
For example, instead of just:
FileNameZip = "report.zip"
Use:
FileNameZip = "c:\users\" & Environ("Username") & "\documents\Appraiser_Genie\target\report.zip"
...or wherever your report.zip file is