VBA - No compression permission

Question

Good afternoon Peoples.

I’m working on a code that unzips a file ".xlsm", exchange the Vbproject and compact again. However a permission problem has arisen at the time of compacting, I hope you can help me.

Dim Fname As Variant, FileNameFolder As Variant, DefPath As String, strDate As String

Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(ThisWorkbook.Path)
Set fc = f.Files

For Each f1 In fc
na = na & f1.Name
If Not na Like "*Update.xlsm" And Not na Like "*.bin" Then GoTo conl
na = ""
Next
Exit Sub

conl:

pat = ThisWorkbook.Path & "\"
fs.copyfile pat & na, pat & na & ".zip"

Fname = pat & na & ".zip"

DefPath = ThisWorkbook.Path
If Right(DefPath, 1) <> "\" Then DefPath = DefPath & "\"

FileNameFolder = DefPath & "pasta\"
MkDir FileNameFolder

Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).Items
fs.copyfile pat & "vbaProject.bin", pat & "pasta\xl\vbaProject.bin", True

Kill Fname

'alternativa(ocorre o mesmo problema)
'Open pat & na & ".zip" For Output As #1
'Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
'Close #1

'oApp.Namespace(Fname).CopyHere oApp.Namespace(FileNameFolder).Items

Set Folder = fs.GetFolder(FileNameFolder)

zipName = Folder.Name + ".zip"
fs.CreateTextFile(pat & zipName, True).Write "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
Set zipFile = fs.GetFile(pat & zipName)
Set Source = oApp.Namespace(Folder.Path).Items

oApp.Namespace(zipFile.Path).CopyHere (Source)

On Error Resume Next

fs.deletefolder Environ("Temp") & "\Temporary Directory*", True
End Sub```

Grato desde já.

Answer 1

Fortunately I managed to solve this problem... in fact I used another code, but simple in a way. For the proper functioning of it is necessary to add the references: "Microsoft Scripting Runtime" and "Microsoft Visual Basic for Application Extensibility 5.3".

Follows the code:

Private Const IMPORT_DELAY As String = "00:00:03"
Private Const proj_name As String = "vpject365"
Public componentsToImport As Dictionary, vbaProjectToImport As VBProject, i As Integer, pat As String

Public Sub Workbook_Ca1culate()
Stop
Dim FSO As Object, fn, f, fc, fl, i As Integer, msgTitle As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set f = FSO.GetFolder(ThisWorkbook.Path)

msgTitle = "Selecione o arquivo Acob"
If i = 1 Then msgTitle = "Selecione o arquivo Combo"

With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.InitialFileName = f
.Title = msgTitle
.Show
Workbooks.Open .SelectedItems(1)
pat = .SelectedItems(1)
Build.testImport
End With

ThisWorkbook.Saved = True
ThisWorkbook.ChangeFileAccess xlReadOnly

Kill f & "\" & "update.xlam"
Workbooks(fn).Close SaveChanges:=True
ThisWorkbook.Close
End Sub

Public Sub testImport()
'Nathan

Dim vbaProject As Object: Set vbaProject = Application.VBE.VBProjects(proj_name)

On Error Resume Next
On Error GoTo 0

Dim FSO As New Scripting.FileSystemObject, export_path As String, c As VBComponent, bas As String, vComponentName As Variant

bas = "cb"
If i = 1 Then bas = "cmb": i = 1

export_path = FSO.GetParentFolderName(vbaProject.fileName) & "\"
Set c = vbaProject.VBComponents("Compilado")
Set componentsToImport = New Dictionary
Set vbaProjectToImport = vbaProject

vbaProject.VBComponents.Remove c

componentsToImport.Add bas, ThisWorkbook.Path & "\" & bas

Application.OnTime Now() + TimeValue(IMPORT_DELAY), "'Build.importComponents'"

If i = 1 Then Workbook_Ca1culate

End Sub

Public Sub importComponents()

Dim componentName As String, vComponentName As Variant

For Each vComponentName In componentsToImport.Keys
componentName = vComponentName
vbaProjectToImport.VBComponents.Import componentsToImport(componentName)
Next

Set componentsToImport = Nothing: Set vbaProjectToImport = Nothing
Stop
Application.Wait (Now() + TimeValue("0:00:05"))

'Dim FSO As Object, fn, f, fc, fl
'Set FSO = CreateObject("Scripting.FileSystemObject")
'Set f = FSO.GetFolder(ThisWorkbook.Path)
'Set fc = f.Files

'For Each fl In fc
'fn = fl.Name
'If fn Like "*.xlsm" And Not fn Like "~$*" And Not fn Like "update.xlsm" Then GoTo jmpa
'Next
'MsgBox "Macro não encontrada": Exit Sub
'jmpa:

Kill pat 'f & "\" & "update"

End Sub

Now instead of moving the entire Vbproject it moves only the module as desired. ;)