Папка VBA Word с электронной почтой в формате pdf

Question

Я хочу отправить PDF-файлы из файла MS Word. Этот файл связан с исходным файлом Excel для выполнения функции слияния. При поддержке http://word.officeacademy.it/450/word-come-fare-stampa-unione-direttamente-in-singoli-file-pdf-vba/ и http://www.rondebruin.nl/win/s7/win001.htm Я начал создавать макрос:

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 = "[e-mail]"
            .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

Я создаю pdf файлы, создаю папки, но я не могу заархивировать файлы в созданных папках.

Мне нужно найти все файлы с ключевым словом в Dim Value (поле "NomeCentro" в исходном файле Excel), а также архивировать и копировать в ранее созданную папку "NomeCentro".

Наконец, мне нужно отправить письмо для каждого zip-файла (я не проверял почтовый код, потому что отладка останавливает меня раньше).

Изменить: ошибка генерирует всплывающее окно с (попробуйте перевести сообщение) "Не удается переместить сжатую (сжатую) папку в себя" в строке

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

Answer 1

Вы получаете какие-либо сообщения об ошибках? Если да, можете ли вы предоставить их здесь и указать, в какой строке вы их получаете?

Редактировать: на основании сообщения об ошибке, приведенного ниже в комментарии, проблема заключается в том, что zip-файл находится по пути, указанному в DestFolder, а затем вы пытаетесь скопировать все элементы в DestFolder в zip-файл, но все элементы включают сам zip-файл,

Создайте zip-файл по пути, который не будет затронут вызовом копирования.