Errore runtime 70 autorizzazione negata aspettare che si sblocchi un file

Buongiorno a tutti

mi creo un file zip da dei file che trovo in una cartella, dopo aver creato lo zip con i file voglio cancellare la cartella con i singoli files

il processo di creazione dello zip certe volte non riesce a sbloccare i file e ricevo autorizzazione negata errore runtime 70
potrei aumentare il waituntil ma vorrei qualcosa di dinamico, come fare per esempio a capire se un file è ancora bloccato?
grazie

    folderToZipPath = "C:\temp\" & var_ragione_soc_cliente & "\"
    zippedFileFullName = "C:\temp\" & var_ragione_soc_cliente & ".zip"

    
    Open zippedFileFullName For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
    
    Set ShellApp = CreateObject("Shell.Application")
   
    ShellApp.Namespace(zippedFileFullName).CopyHere folderToZipPath 'copies folder and its contents
    
    WaitUntil = Now + TimeValue("00:00:3")
    Do
      DoEvents
    Loop Until Now >= WaitUntil
    
    DoEvents
    
    Kill folderToZipPath & "\*.*"
    RmDir folderToZipPath

Se non usi Shell.Application ma la Shell Nativa, basta aprire un Processo ed interrogare con GetExitCodeProcess se il processo è finito in LOOP...
Ti allego un Modulo che uso per Zippare nei miei progetti, non zippa tutta la cartella, ma userai un Ciclo anche con DIR per ciclare i File e passarli allo ZIP usando AddFilesToZip... in questo caso il Processo è SINCRONO.


Option Compare Database
Option Explicit

#If VBA7 Then
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Declare PtrSafe Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
    Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
    Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
#End If


Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103


Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
    Dim hProg As Long
    Dim hProcess As Long, ExitCode As Long
    'fill in the missing parameter and execute the program
    If IsMissing(WindowState) Then WindowState = 1
    hProg = Shell(PathName, WindowState)
    'hProg is a "process ID under Win32. To get the process handle:
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
    Do
        'populate Exitcode variable
        GetExitCodeProcess hProcess, ExitCode
        DoEvents
    Loop While ExitCode = STILL_ACTIVE
End Sub

Function ZipMe(File2Zip As String)
    Dim PathZipProgram      As String
    Dim NameZipFile         As String
    Dim strDate             As String
    Dim DefPath             As String
    Dim ShellStr            As String
    Dim intDot              As Integer
    
    'Path of the Zip program
    PathZipProgram = "C:\program files\7-Zip\"
    If Right(PathZipProgram, 1) <> "\" Then
        PathZipProgram = PathZipProgram & "\"
    End If

    'Check if this is the path where 7z is installed.
    If Dir(PathZipProgram & "7z.exe") = "" Then
        MsgBox "Please find your copy of 7z.exe and try again"
        Exit Function
    End If

    DefPath = CurrentProject.Path
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If
    
    intDot = InStrRev(File2Zip, ".")
    NameZipFile = Mid$(File2Zip, 1, intDot) & "zip"

    ShellStr = PathZipProgram & "7z.exe a" _
             & " " & Chr(34) & NameZipFile & Chr(34) _
             & " " & File2Zip

    ShellAndWait ShellStr, vbHide

    MsgBox "Troverai il File quì: " & vbNewLine & NameZipFile
End Function

' ---------------------------------------------------------------------------------
Sub AddFilesToZip(ZipFile As String, FileToAdd As String)

    Dim objShell As Object
    Dim varZipFile As Variant

    If Len(Dir(FileToAdd)) > 0 Then
    
        Set objShell = CreateObject("Shell.Application")
        varZipFile = ZipFile
        objShell.Namespace(varZipFile).CopyHere (FileToAdd)
        Do Until objShell.Namespace(varZipFile).Items.Count >= 1
            Call Sleep(100)
        Loop
    End If

End Sub

Sub InitializeZipFile(ZipFile As String)

    Dim intFile As Integer

    If Len(Dir(ZipFile)) > 0 Then
        Kill ZipFile
    End If

    intFile = FreeFile
    Open ZipFile For Output As #intFile
      Print #intFile, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #intFile
End Sub

Se devi zippare più File:


    Dim strZIP As String
    strZIP="C:\NomeFile.ZIP"
    Call InitializeZipFile(strZIP)
    Call AddFilesToZip(strZIP, NomeFile1)
    Call AddFilesToZip(strZIP, NomeFile2)

Errore runtime 70 autorizzazione negata aspettare che si sblocchi un file

Errore runtime 70 autorizzazione negata aspettare che si sblocchi un file

1 Risposte

Re: Errore runtime 70 autorizzazione negata aspettare che si sblocchi un file