Is there a way to extract 7z content using VBA without administrator privileges?
Using the function UnzipAFile described here I get an error at line:
ShellApp.Namespace(unzipToPath).CopyHere ShellApp.Namespace(zippedFileFullName).items
I think it is related to the create object command:
Set ShellApp = CreateObject("Shell.Application")
I do not and cannot have administrator privileges.
(Maybe its due to other reason?!?)
Thank you for your help.
See Ron de Bruin Example code-
Unzip file(s) with the default Windows zip program
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
Related
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 am trying to automate unzipping a zip file and extracting the files to a new folder location. I have scoured a bunch of sources and found code that will unzip the folder but it won't actually remove the files inside and put them in the new location, it just copies the zip folder and pastes it to the new location with the password removed. I want it to extract the files inside, and place them in the new folder. Thanks in advance for any help. Here is my code:
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
Dim sPathTo7ZipExe As String
Dim sZipPassword As String
sPathTo7ZipExe = "C:\Riley\7Zip\7za.exe" ' <-- change this to where you installed the 7zip command line program
sZipPassword = "password" ' <-- change this to your zip password
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
DefPath = "C:\Riley\Visual Basic\" ' <-- make sure your path here ends in a \. you were missing that before
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
Shell sPathTo7ZipExe & " x -y -p" & sZipPassword & " -o""" & _
FileNameFolder & """ """ & Fname, vbHide
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
Does any have VBA code for outlook that will automatically unzip a file? I have found several post that save a file to a locationm, but nothing that unzips a file.
Maybe this is what you are looking for. An example from the website (visit the link to find out more):
With this example you can browse to the zip file. After you select the zip file the macro will create a new folder in your DefaultFilePath and unzip the Zip file in that folder. You can run the code without any changes.
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
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
I am writing some code that prompts the user to add a folder name, then copies all the files on the CD drive (D:) to C:\Example\ & FolderName if it doesn't already exist.
The code works until I try to copy files to a folder that already exists then I get a Run-time error 70: Permission Denied. Any help would be greatly appreciated.
Public Sub CopyFiles()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim FNames As String
Dim FolderName As String
FolderName = InputBox(Prompt:="Your folder name", Title:="Folder Name", default:="Folder Name here")
If Dir("C:\Example\" & FolderName & "\", vbDirectory) = "" Then
MkDir "C:\Example\" & FolderName
Else
End If
FromPath = "D:\"
ToPath = "C:\Example\" & FolderName & "\"
FileExt = "*.flac*"
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
FNames = Dir(FromPath & FileExt)
If Len(FNames) = 0 Then
MsgBox "No files in " & FromPath
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
End Sub
The problem is not that the folder exists. The problem is that you are trying to copy files and overwrite them
Overwriting is usually not a problem but fails if the files in the destination folder have Read Only Attributes. You can read more about it in this MSDN Article
What happened was when you first copied the files from the CD Drive, the file which where copied retained the Read Only Property. You can check that by Right Clicking on the File and checking their properties.
To overcome this problem, you need to reset the file attributes or delete the files in that folder.
To delete, you can simply use
On Error Resume Next
Kill "C:\MyFolder\*.*"
On Error GoTo 0
To change the attributes, you have to loop through the file and check if their property is read only. You can do that by
If fso.GetFile(Dest_File).Attributes And 1 Then
and to reset it, you have to use
fso.GetFile(Dest_File).Attributes = fso.GetFile(Dest_File).Attributes - 1
Once you do that you will be able to copy the files across.
As Siddharth mentioned, the error occurs because the code is trying to overwrite existing files. So, if you don't want to overwrite the files, you can simply add a If Error Resume Next. The solution code I am using is below:
Public Sub CopyFiles()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim FNames As String
Dim FolderName As String
FolderName = InputBox(Prompt:="Your folder name", Title:="Folder Name", default:="Folder Name here")
If Dir("C:\Example\" & FolderName & "\", vbDirectory) = "" Then
MkDir "C:\Example\" & FolderName
Else
End If
FromPath = "D:\"
ToPath = "C:\Example\" & FolderName & "\"
FileExt = "*.flac*"
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
FNames = Dir(FromPath & FileExt)
If Len(FNames) = 0 Then
MsgBox "No files in " & FromPath
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
On Error Resume Next
FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
On Error GoTo 0
End Sub