Hm, wollt mir mal wieder was bei euch klauen und kriegs nicht gebacken.
Bei mir startet Word mit der Adressetiketten Vorlage und öffnet zusätzlich
ein leeres Worddokument. Wenn ich die Aktion PrintLabels nochmals aufrufe
hab ich 4 Dokumente offen usw. Hier meine geklaute Scriptbibliothek:
Sub CreateMailingLabels(Line1Fields As Variant ,_
Line2Fields As Variant ,_
Line3Fields As Variant ,_
Line4Fields As Variant ,_
Line5Fields As Variant ,_
Skip As Variant ,_
ColCount As Integer ,_
LabelTemplate As String)
Dim ws As New NotesUIWorkspace
Dim s As New NotesSession
Dim db As notesdatabase
Dim doc As NotesDocument
Dim dc As NotesDocumentCollection
Dim wrd As Variant
Dim LabelCount As Long
Dim DivMod As Integer
cr = Chr ( 13 ) & Chr ( 10 )
wdCell = 12
LabelCount=1
DivMod = 1
Set db = s.CurrentDatabase
Set dc=db.UnProcessedDocuments
Set wrd = CreateObject ( "Word.Application" )
On Error Resume Next
Set objWord = GetObject("", "Word.Application")
If Err = 208 Then ' Fehler 208 tritt auf wenn Word noch nicht läuft
Err = 0
Set objWord = CreateObject("Word.Application")
objWord.Visible = True 'Word sichtbar machen
End If
Call wrd.Documents.Add
Call wrd.MailingLabel.CreateNewDocument ( LabelTemplate )
wrd.visible = True
Set doc=dc.GetFirstDocument
While Not doc Is Nothing
LabelAddress = GetListFieldValues ( doc , Line1Fields ) & cr '// Build label text
LabelAddress = LabelAddress & GetListFieldValues ( doc , Line2Fields ) & cr
LabelAddress = LabelAddress & GetListFieldValues ( doc , Line3Fields ) & cr
LabelAddress = LabelAddress & GetListFieldValues ( doc , Line4Fields ) & cr
LabelAddress = LabelAddress & GetListFieldValues ( doc , Line5Fields )
If Not SingleColumn% Then
Call wrd.Selection.TypeText ( LabelAddress ) '// Insert Label Text
On Error Goto TrapSingleColumn
If Skip = False Then
Call wrd.Selection.MoveRight ( wdCell ) ' Move one cell to the right.
Else
If DivMod = 0 Then
Call wrd.Selection.MoveRight ( wdCell ) ' Move one cell to the right.
Else
Call wrd.Selection.MoveRight ( wdCell ) ' Move one cell to the right.
Call wrd.Selection.MoveRight ( wdCell ) ' Move one cell to the right.
End If
End If
If SingleColumn% Then
Call wrd.MailingLabel.CreateNewDocument ( LabelTemplate , LabelAddress )
End If
Else
Call wrd.MailingLabel.CreateNewDocument ( LabelTemplate , LabelAddress )
End If
LabelCount = LabelCount + 1
If ColCount = 2 Then
DivMod = 1
Else
DivMod = Labelcount Mod ColCount
End If
Set doc = dc.GetNextDocument ( doc )
Wend
Exit Sub
TrapSingleColumn:
SingleColumn% = True
Resume Next
End Sub
Wär nett wenn mir einer auf die Sprünge helfen könnte.
Danke Alex
