Eliminare collegamenti excel dalla Cartella

Hai un problema con Excel?

Nuova discussione

Eliminare collegamenti excel dalla Cartella
di Lele (utente non iscritto) data: 12/07/2017 16:06:50
Ciaoo a tutti!!! ho realizzato questo codice per inoltrare dai presenti in excel mezzo mail dei, allegandoli in pdf.
Non ho diritti di amministratore nel pc, quindi creo una cartella temporanea per memorizzare i files pdf che poi inoltro mezzo mail.

Tutto il codice funziona perfettamente tranne la riga RmDir è come se un collegamento con la cartella risultasse sempre aperto e non mi permette di cancellarla. Ho utilizzato anche altri comandi ma non ho avuto esito.

Sapete consigliarmi qualche comando per troncare i collegamenti excel / cartella e ripulire quest'ultima dai files temporanei?
O come rimuovere direttamente i files .tmp ?

Grazie 1000!!

Sub CreaPdf()

On Error GoTo Gest_err

Rows("24:28").Select
    Selection.EntireRow.Hidden = True
    
 Application.Wait TimeSerial(Hour(Now), Minute(Now), Second(Now + TimeValue("00:00:01")))

Set FSO = CreateObject("Scripting.FileSystemObject")  ' New FileSystemObject
    strTempPath = FSO.GetSpecialFolder(TemporaryFolder) & "" & FSO.GetTempName & ""
    FSO.CreateFolder strTempPath

SetAttr (strTempPath), vbHidden
ChDir strTempPath

Dim arrPos(2000)

    T = Range(A16)
    x = 3
    y = 1
    Do While (Sheets("DB_Anagrafica_Mese").Cells(x, 49) <> "")
        If Sheets("DB_Anagrafica_Mese").Cells(x, 49) <> "." Then
            Range("A16") = Sheets("DB_Anagrafica_Mese").Cells(x, 49)
                        
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            "Indicatori" & " " & Sheets("DB_Anagrafica_Mese").Cells(x, 50) & " " & Sheets("DB_Anagrafica_Mese").Cells(x, 49) & ".pdf", Quality:= _
            xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
        
            x = x + 1
            T = T + 1
        Else
            Exit Do
        End If
                      
    Loop
    
    Z = y
    y = 1
    Do While Z > 1
        For n = 1 To Z
            x = arrPos(n)
                Range("A16") = Sheets("DB_Anagrafica_Mese").Cells(x, 49)
                
               ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            "Indicatori" & " " & Sheets("DB_Anagrafica_Mese").Cells(x, 50) & " " & Sheets("DB_Anagrafica_Mese").Cells(x, 49) & ".pdf", Quality:= _
            xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
                
        Next
        Z = y
        y = 1
    Loop
    
    Range("A16") = ""
        
    q = 3
    w = 1
    
Do While (Sheets("DB_Anagrafica_Mese").Cells(q, 49) <> "")
        If Sheets("DB_Anagrafica_Mese").Cells(q, 49) <> "." Then
            Range("A16") = Sheets("DB_Anagrafica_Mese").Cells(q, 49)
     
        
    Dim NewMail As Object
Set NewMail = CreateObject("Outlook.Application").CreateItem(oMailItem)
   
    With NewMail
        .To = Worksheets("DB_Anagrafica_Mese").Cells(q, 51)
        .CC = Sheets("Cruscotto").Cells(28, 2)
        .Subject = "Indicatori"
        .Body = Sheets("Cruscotto").Cells(26, 2)
        .Attachments.Add strTempPath & "Indicatori" & " " & Sheets("DB_Anagrafica_Mese").Cells(q, 50) & " " & Sheets("DB_Anagrafica_Mese").Cells(q, 49) & ".pdf"
        .Display
        .Save
        .Send
    End With
            
  q = q + 1
  
  Else
            Exit Do
        End If
     
          
Loop
    
    j = w
    w = 1
    Do While j > 1
        For r = 1 To j
            q = arrPos(r)
                Range("A16") = Sheets("DB_Anagrafica_Mese").Cells(q, 49)
  
    With NewMail
        .To = Worksheets("DB_Anagrafica_Mese").Cells(q, 51)
        .CC = Sheets("Cruscotto").Cells(28, 2)
        .Subject = "Indicatori"
        .Body = Sheets("Cruscotto").Cells(26, 2)
        .Attachments.Add strTempPath & "Indicatori" & " " & Sheets("DB_Anagrafica_Mese").Cells(q, 50) & " " & Sheets("DB_Anagrafica_Mese").Cells(q, 49) & ".pdf"
        .Display
        .Save
        .Send
    End With

Next
        j = w
        w = 1
    Loop
    
    Range("A16") = ""

Rows("24:28").Select
    Selection.EntireRow.Hidden = False
  
  Range("A15").Select
  
    'Pulizie
    Set appOL = Nothing
    Set creaEmail = Nothing
    
    
 Kill (strTempPath & "*.*")
 
 RmDir (strTempPath)
    
 Exit Sub
    
    
Gest_err:
    arrPos(y) = x
    y = y + 1
    Resume Next
   
    
End Sub

di Vecchio Frac data: 12/07/2017 20:00:48
Può darsi che aver assegnato l'attributo "nascosto" alla cartella gli dia fastidio.
Prova a rimuovere questo attributo prima di cancellare la cartella.

Inoltre prima di eliminare la cartella corrente (in ciui ti sei spostato con ChDir iniziale) prova a spostarti in un percorso diverso (magari con ChDir ThisWorkbook.Path) e poi riprova a eliminare la cartella temporanea.

Infine, prova anche ad annientare l'oggetto FSO prima di eliminare la cartella, perchè strTempPath punta a questo oggetto per creare la cartella temporanea.
di Lelec data: 13/07/2017 07:31:12
Vecchio Frac grazie 1000! risolto! Alcune volte la soluzione semplice è sempre la migliore. E' bastato cambiare il percorso.

Vuoi Approfondire?