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 first published in November 2000

Dig deeper on Lotus Notes Domino Administration Tools

0 comments

Oldest 

Forgot Password?

No problem! Submit your e-mail address below. We'll send you an email containing your password.

Your password has been sent to:

-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