This one is for easyly create Labels with MS-Word
Code
' Sample Usage:
Sub Click(Source As Button)
Call CreateMailingLabels("Title","FirstName, LastName" ,
"OfficeStreetAddress","Zip","City" , True , 5 , "L7690")
End Sub
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)
Const OLE_OBJECT = "Word.Application"
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 ( OLE_OBJECT )
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
Function GetListFieldValues ( doc As NotesDocument , FieldList As Variant ) As
String
Dim TempList As String
Dim TempOutput As String
Dim TempArray As Variant
Dim ThisField As String
TempList = FieldList
TempOutput = ""
If TempList <> "" Then
' parse list of fields
While Len ( TempList ) > 0
If Instr ( TempList , "," ) > 0 Then
ThisField = Trim ( Left$ ( TempList , Instr ( TempList ,
"," ) - 1 ) )
TempList = Right$ ( TempList , Len ( TempList ) - Instr (
TempList , "," ) )
Else
ThisField = Trim ( TempList )
TempList = ""
End If
' retrieve notes field <WHATLE