Korespondencja seryjna z punktu widzenia VBA

W dzisiejszym odcinku przedstawiam makro generujące dokument Word-a na podstawie szablonu. Makro takie można wykorzystać np. z poziomu Excel-a lub Access-a do automatyzacji korespondencji seryjnej . Parametryzacji ewentualnie wymagały by parametry będące w stringach tekstowych.

Sub generuj_dokument()
    
    ' deklaracje zmiennych, może być potrzebna referencja w projekcie
    Dim w As Word.Application
    Dim d As Word.Document
    Dim nd As Word.Document
    Dim m As Word.MailMerge
    Dim wAllert As Word.WdAlertLevel
    
    Dim sConn As String
    Dim sComm As String
    Dim sFile As String
    Dim sFileOut As String
    Dim sDefaultDir As String
    Dim sTemplate As String
    Dim sPass As String

    sComm = "SELECT * FROM `Arkusz1$`" 'zapytanie sql z którego korzystamy
    sPass = "xxxxxxxx" ' hasło do pliku template
    sDefaultDir = "C:\Users\user\Documents\" ' katalog domyślny dla operacji
    sTemplate = sDefaultDir & "dokument.docx" ' plik szablonu
    sFileData = sDefaultDir & "dane.xlsx" ' plik z danymi
    sFileOut = sDefaultDir & "dane_out.docx" ' plik wyjściowy
    
    ' connection String, w tym przypadku dla Excel-a 12
    sConn = ""
    sConn = "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & sFileData & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engine Type=37;Jet OLEDB:Database Locki"

    On Error Resume Next
    
    ' istniejący obiekt
    Set w = GetObject(, "Word.Application")
     
    If Err.Number <> 0 Then
        ' nowy obiekt
        Set w = CreateObject("Word.Application")
    End If

    ' wyłączenie alertu o pobieraniu danych
    wAllert = w.DisplayAlerts
    w.DisplayAlerts = wdAlertsNone
    Set d = w.Documents.Open( _
            FileName:=sTemplate, _
            PasswordDocument:=sPass)
    w.DisplayAlerts = wAllert
    Set m = d.MailMerge

    With m
        .OpenDataSource _
                Name:=sFileData, _
                SQLStatement:=sComm, _
                SubType:=wdMergeSubTypeAccess, _
                Connection:=sConn
        .Destination = wdSendToNewDocument
        If .State = wdMainAndDataSource Then
            .Execute
        Else
            MsgBox "problem w wypełnieniu dokumentu"
            Exit Sub
        End If
    End With

    ' obiekt nowo utworzonego dokumentu po wypełnieniu
    Set nd = ActiveDocument
    
    With nd
        .SaveAs _
                FileName:=sFileOut, _
                FileFormat:=wdFormatXMLDocument
        .Close
    End With
    
    d.Close False
    w.Quit
    
    Set nd = Nothing
    Set d = Nothing
    Set w = Nothing

End Sub

I taka mała uwaga na koniec. Plik Excel-a z którego korzystamy powinien być zamknięty na czas kiedy korzystamy z makra.

Masowy zapis z korespondencji seryjnej

Korespondencja seryjna to świetny wynalazek. Niesamowicie ułatwia życie, gdy np. chcemy wygenerować i wydrukować kilkaset listów. W momencie jednak gdy chcemy tylko wygenerować i zapisać jako pliki te dokumenty stajemy przed ścianą.

Prostym rozwiązaniem tej niedogodności jest to oto makro

Sub Generuj_i_Zapisz()

    Dim w As MailMerge
    Dim a As Long
    Dim sFileName As String

On Error GoTo ERR_Handler

    Application.ScreenUpdating = False
    Application.Visible = False
    
    Set w = ActiveDocument.MailMerge

    w.DataSource.ActiveRecord = wdFirstDataSourceRecord

    For a = 0 To w.DataSource.RecordCount

        With w
            .Destination = wdSendToNewDocument
            .SuppressBlankLines = True
            With .DataSource
                .FirstRecord = a
                .LastRecord = a
            End With
            .Execute Pause:=False
            
        End With
      
        ' składamy nazwę pliku z jakiś elementów np. z kolumn źródła danych
        sFileName = "C:\Users\Przemek\Documents\w\" & w.DataSource.DataFields("c").Value & ".docx"
        
        ActiveDocument.Parent.ScreenUpdating = False
        ActiveDocument.SaveAs _
            FileName:=sFileName, _
            FileFormat:=wdFormatXMLDocument, _
            LockComments:=False, _
            Password:="", _
            AddToRecentFiles:=True, _
            WritePassword:="", _
            ReadOnlyRecommended:=False, _
            EmbedTrueTypeFonts:=False, _
            SaveNativePictureFormat:=False, _
            SaveFormsData:=False, _
            SaveAsAOCELetter:=False
        ActiveWindow.Close
    
        w.DataSource.ActiveRecord = wdNextRecord
    
    Next
    
END_Handler:

    Application.Visible = True
    Application.ScreenUpdating = True
    
    Exit Sub

ERR_Handler:
    
    MsgBox Err.Description
    
    Resume END_Handler:
    
End Sub

Komentarza w zasadzie wymagać może tylko linia

sFileName = w.DataSource.DataFields("c").Value & ".docx"

gdzie DataFields("c") to nazwa kolumny ze źródła danych - w przypadku danych użytkownika trzeba to zmienić lub użyć własnego kodu VBA. Ewentualnie zamiast nazwy możemy podać numer obiektu w kolekcji.