VBA Word Email fichier zip fichier pdf

Question

Je veux envoyer des fichiers pdf à partir d'un fichier MS Word docm. Ce fichier est lié à un fichier source Excel pour exécuter la fonction Fusion et publipostage. Avec le soutien de http://word.officeacademy.it/450/word-come-fare-stampa-unione-direttamente-in-singoli-file-pdf-vba/ et http://www.rondebruin.nl/win/s7/win001.htm j'ai commencé à créer une macro:

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 

---

Sub Unione_in_pdf() 

Dim fd As FileDialog 
Dim file As Variant 

'Crea un oggetto FileDialog per scegliere la cartella in cui salvare i file 
Set fd = Application.FileDialog(msoFileDialogFolderPicker) 
With fd 

    'Usa il metodo Show per mostrare la finestra di dialogo e restituire l'azione dell'utente 
    If .Show = -1 Then 
      For Each vrtSelectedItem In .SelectedItems 

      'vrtSelectedItem è una stringa che contiene l'indirizzo di ogni elemento selezionato. 
      'E' possibile usare qualsiasi funzione di I/O sui file utilizzando questo indirizzo. 
      SelectedPath = vrtSelectedItem 

      Next vrtSelectedItem 

    Else 
      MsgBox ("Nessuna cartella è stata selezionata.") 
      Exit Sub 
    End If 

End With 

'Imposta la variabile oggetto a Nothing 
Set fd = Nothing 

Application.ScreenUpdating = False 

MainDoc = ActiveDocument.Name 
ChangeFileOpenDirectory SelectedPath 
For i = 1 To ActiveDocument.MailMerge.DataSource.RecordCount 
    With ActiveDocument.MailMerge 
     .Destination = wdSendToNewDocument 
     .SuppressBlankLines = True 
     With .DataSource 
      .FirstRecord = i 
      .LastRecord = i 
      .ActiveRecord = i 

      'Utilizza alcuni campi del file sorgente per impostare il nome del file pdf 
      'IMPORTANTE: tali campi vanno personalizzati in base a quelli effettivamente 
      'presenti nella sorgente dati 
      docName = "Lettera_" & .DataFields("NomeCentro").Value & "_" & .DataFields("Allievo").Value & ".pdf" 
      Value = .DataFields("NomeCentro").Value 
     End With 
     .Execute Pause:=False 

     Application.ScreenUpdating = False 

    End With 

    ActiveDocument.ExportAsFixedFormat OutputFileName:=docName, _ 
     ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _ 
     wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _ 
     Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _ 
     CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _ 
     BitmapMissingFonts:=True, UseISO19005_1:=False 
    ActiveWindow.Close SaveChanges:=False 

    Folder = ActiveDocument.Path 
    DestFolder = Folder & Application.PathSeparator & Value 
    If Len(Dir(DestFolder, vbDirectory)) = 0 Then 

     MkDir DestFolder 

     Dim FileNameZip 
     Dim oApp As Object 

      If Right(DestFolder, 1) <> "\" Then 
       DestFolder = DestFolder & "\" 
      End If 

     FileNameZip = DestFolder & "MyZip" & ".zip" 

     'Create empty Zip File 
     NewZip (FileNameZip) 

     Set oApp = CreateObject("Shell.Application") 
     'Copy the files to the compressed folder 
     oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(DestFolder).items 

     'Keep script waiting until Compressing is done 
     On Error Resume Next 
     Do Until oApp.Namespace(FileNameZip).items.Count = _ 
      oApp.Namespace(DestFolder).items.Count 
      Application.OnTime When:=Now + TimeValue("00:00:15"), _ 
    Name:="MyDelayMacro" 
     Loop 
     On Error GoTo 0 

     'Create the mail 
     Set OutApp = CreateObject("Outlook.Application") 
     Set OutMail = OutApp.CreateItem(0) 
     strbody = "Hi there" & vbNewLine & vbNewLine & _ 
        "This is line 1" & vbNewLine & _ 
        "This is line 2" & vbNewLine & _ 
        "This is line 3" & vbNewLine & _ 
        "This is line 4" 

     On Error Resume Next 
     With OutMail 
      .To = "ron@debruin.nl" 
      .CC = "" 
      .BCC = "" 
      .Subject = "This is the Subject line" 
      .Body = strbody 
      .Attachments.Add FileNameZip 
      .Send 'or use .Display 
     End With 
     On Error GoTo 0   

     End If 

Next i 

     Application.ScreenUpdating = True 

End Sub 

Je créer des fichiers PDF, créer des dossiers, mais je ne peux pas les fichiers zip dans des dossiers créés.

J'ai besoin de trouver tous les fichiers avec le mot-clé dans le champ Dim Value ("NomeCentro" dans le fichier source Excel) et le zip et copier dans le dossier "NomeCentro" précédemment créé.

Enfin, je dois envoyer un mail pour chaque fichier zip (je n'ai pas testé le code mail car le débogage m'arrête avant).

Edit: l'erreur génère une fenêtre contextuelle avec (essayer de traduire un message) « ne peut pas déplacer un comprimé (zippé) dossier en lui-même » à la ligne

oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(DestFolder).items 

Answer 1

Avez-vous des messages d'erreur? Si oui, pouvez-vous les fournir ici et indiquer dans quelle ligne vous les recevez? Edit: Basé sur le message d'erreur ci-dessous dans le commentaire, le problème est que le fichier zip est situé dans le chemin indiqué par DestFolder, puis vous essayez de copier tous les éléments dans DestFolder dans le fichier zip, mais tous les éléments comprennent le fichier zip lui-même.

Créez le fichier zip dans un chemin qui ne sera pas affecté par l'appel de copie.