Macro für Datenauswahl bei Serienbrief

Hallo zusammen

Wir verwenden Serienbriefe um Etiketten zu drucken. Das Layout der Etikette ist immer gleich, die Daten werden durch die Datenquelle definiert. Mittlerweile gibt es so viele, zum Teil ähnliche, Datensätze, dass die Auswahl des gewünschten Datensatz mühsam ist und oft der Falsche gedruckt wird.

Nun habe ich die Idee umgesetzt, dass man über eine Verknüpfung automatisch den gewünschten Datensatz öffnen kann.

Dazu habe ich Makros geschrieben, die die Aufrufparameter von WinWord auswerten und damit den gewünschten Datensatz sucht.

Dies funktioniert bis auf folgendes Problem wie gewünscht.

Wird so die gewünschte Etikette mit dem gewünschten Datensatz geöffnet, werden anschliessend die Daten nicht mehr aktualisiert, wenn im Reiter Sendungen ein anderer Datensatz angewählt wird.

Erst durch manuelles aktualisieren (CTRL+A, F9) oder durch ausdrucken werden die Daten aktualisiert.


Kennt jemand eine Lösung wie ich dies beheben kann?


Im folgenden ist der Code.

Aufgerufen wird er mit:


"%ProgramFiles(x86)%\Microsoft Office\Office14\WINWORD.EXE" Etikette.docm /mItemSelect /?Item1=3


Item1 ist das Seriendruckfeld und 3 ist der Wert der gesucht wird.


Declare Function libLStrCpyN Lib "kernel32" Alias "lstrcpynA" (ByVal DestString As String, ByVal SourcePointer As Long, ByVal MaxLen As Long) As Long
Declare Function libStrLen Lib "kernel32" Alias "lstrlenA" (ByVal SourcePointer As Long) As Long
Declare Function libGetCommandLine Lib "kernel32" Alias "GetCommandLineA" () As Long

Public Sub ItemSelect()
Dim strCommandLine As String
strCommandLine = GetCommandLine
Dim lPos As Long
lPos = InStr(strCommandLine, "/?")
If (0 < lPos) Then
Dim strArg As String
strArg = Mid(strCommandLine, lPos + 2)

lPos = InStr(strArg, " ")
If (0 < lPos) Then
strArg = Left(strArg, lPos - 1)
End If
lPos = InStr(strArg, "=")
If (0 < lPos) Then
Dim astrArg() As String
astrArg = Split(strArg, "=", 2)
Call dataSelect(astrArg(LBound(astrArg)), _
astrArg(UBound(astrArg)))
End If
End If
End Sub

Private Function GetCommandLine() As String
'Get a pointer to process commandline as Long
Dim ptrCommandLine As LongPtr
ptrCommandLine = libGetCommandLine
If (0 < ptrCommandLine) Then 'GetCommandLine ok
Dim strBuffer As String
Dim lBufferLength As Long
'Get a length of the command line using Long pointer
'Returns the length without the zero terminating char
lBufferLength = libStrLen(ptrCommandLine)

If (0 < lBufferLength) Then
'Allocate a space for the command line
strBuffer = Space(lBufferLength + 1)

'Copy the command line to a buffer using Long + String pointers.
ptrCommandLine = libLStrCpyN(strBuffer, ptrCommandLine, lBufferLength + 1)

'The copy SHOULD be OK. Zero means some error, not enough of space
If (0 < ptrCommandLine) Then 'lstrcpyn
'Remove the zero terminator from the copied string
Dim lPosZero As Long
lPosZero = InStr(strBuffer, Chr$(0))
If (0 < lPosZero) Then
strBuffer = Left(strBuffer, lPosZero - 1)
End If
GetCommandLine = strBuffer
End If
End If
End If
End Function


Private Function dataSelect(strField As String, _
strValue As String)

Dim doc As Document
Set doc = ActiveDocument

Select Case doc.MailMerge.MainDocumentType
Case wdCatalog ' 3
Case wdDirectory ' 3
Case wdEMail ' 4
Case wdEnvelopes ' 2
Case wdFax ' 5
Case wdFormLetters ' 0
Case wdMailingLabels ' 1
Case wdNotAMergeDocument ' -1
Exit Function
Case Else
Exit Function
End Select

doc.MailMerge.DataSource.ActiveRecord = wdFirstRecord
doc.MailMerge.DataSource.FindRecord _
Field:=strField, _
FindText:=strValue
doc.Saved = True
End Function