Question

我想从MS Word docm文件中发送pdf文件。此文件与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的支持下，我开始创建一个宏：

string some = "<raiz>"+ xmlSigned.ToString() + "</raiz>";

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

我创建了pdf文件，创建了文件夹，但我无法在创建的文件夹中压缩文件。

我需要在Dim Value（＆＃34; NomeCentro＆＃34; Excel源文件中的字段）中找到所有带有关键字的文件，并在＆＃34; NomeCentro＆＃34;中找到zip和copy。先前创建的文件夹

最后，我需要为每个zip文件发送一封邮件（我没有测试过邮件代码，导致调试之前停止了我）。

编辑：错误生成弹出窗口（尝试翻译消息）＆＃34;无法将压缩（压缩）文件夹移动到自身＆＃34;在

行

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

Answer 1

您收到任何错误消息吗？如果是的话，你能在这里提供它们并指出你收到它们的哪一行吗？

编辑：根据评论中提供的错误消息，问题是zip文件位于DestFolder指示的路径中，然后您尝试将DestFolder中的所有项目复制到zip文件，但所有项目都包括zip文件本身。

在不受复制调用影响的路径中创建zip文件。

VBA Word电子邮件压缩的pdf文件夹

1 个答案: