Create Labels With Ms-Word (Ole)

This one is for easyly create Labels with MS-Word
' 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
This was last published in November 2000

Dig Deeper on Lotus Notes Domino Administration Tools

Start the conversation

Send me notifications when other members comment.

By submitting you agree to receive email from TechTarget and its partners. If you reside outside of the United States, you consent to having your personal data transferred to and processed in the United States. Privacy

Please create a username to comment.

-ADS BY GOOGLE

SearchWindowsServer

Search400

  • iSeries tutorials

    Search400.com's tutorials provide in-depth information on the iSeries. Our iSeries tutorials address areas you need to know about...

  • V6R1 upgrade planning checklist

    When upgrading to V6R1, make sure your software will be supported, your programs will function and the correct PTFs have been ...

  • Connecting multiple iSeries systems through DDM

    Working with databases over multiple iSeries systems can be simple when remotely connecting logical partitions with distributed ...

SearchEnterpriseLinux

SearchDataCenter

SearchExchange

SearchContentManagement

Close