Print Label

Here's a button I use in lots of my databases -- you need MS Word 97 or 2000 to use it, and to know the label media code (Word handles 100s of these). It works with selected or all documents in a view.
Sub CreateMailingLabels(Line1Fields As Variant,Line2Fields As Variant,Line3Fields As Variant,Line4Fields As Variant,Line5Fields As Variant)

' requires MS Word 97 or Word 2000
' works on any Notes view or folder
' supply list of Notes field names to be concatenated onto each line of the
' label in the parameters Line1Fields etc
'
' e.g.
'
' Call CreateMailingLabels
'("FirstName,LastName","HouseNo,Street","Town","County","PostCode")

On Error Goto ErrorProc

' declare Notes back-end objects
Dim session As New notessession
Dim db As notesdatabase
Dim doc As NotesDocument
Dim dc As NotesDocumentCollection
Set db = session.currentdatabase
Dim settings As NotesDocument
Set settings=db.GetProfileDocument("Settings","")

' declare Notes front-end objects
Dim ws As New NotesUIWorkspace

Set dc=db.UnProcessedDocuments

' Find out active Notes view
Dim view As notesview
Dim UIView As NotesUIView
Set view = UIView.View

' declare constants

wdCell = 12 'Microsoft Word VBA constant. Designates unit for table cell.
wdLine=5
wdCustomLabelA4 = 2
cr = Chr(13) & Chr(10) ' Carriage return.

SelectedDocuments=Messagebox("Do you want to use all the addresses in this view?",35,db.Title)
If SelectedDocuments=2 Then
Messagebox "Merge Cancelled",16,db.Title
Exit Sub
End If

If SelectedDocuments=7 Then
TickBased%=True
End If
' get required template from user

LabelTemplate = Inputbox("Please enter the MS Word mailing label name to use. ", db.Title,"Avery L7413")

' trim off "Avery" prefix if used
LabelTemplateName=LabelTemplate
If Left$(LabelTemplate,5)="Avery" Then
LabelTemplate=Trim$(Right$(LabelTemplate,Len(LabelTemplate)-5))
End If
If Instr(LabelTemplate,"-")>1 Then
LabelTemplate=Trim$(Left$(LabelTemplate,Instr(LabelTemplate,"-")-1))
End If
If LabelTemplate="" Then
Messagebox "Merge Cancelled",16,db.Title
Exit Sub
End If

' Create an instance of Excel
Dim wrd As Variant
Set wrd = CreateObject("word.application")

' create a new Word document only if required
If wrd.documents.count=0 Then
Call wrd.documents.add
End If

' create new mailing lanels
Print "Generating ";LabelTemplateName;" mailing labels in MS Word"
On Error Goto TrapTemplateName
Call wrd.MailingLabel.CreateNewDocument(LabelTemplate)
On Error Goto ErrorProc

' create each mailing label from line of Notes view

LabelCount!=0
If TickBased% Then
Set doc=dc.GetFirstDocument
Else
Set doc=view.GetFirstDocument
End If
While Not doc Is Nothing

' build label text

LabelAddress = GetListFieldValues(doc,Line1Fields) & cr
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 full address into Word.
On Error Goto TrapSingleColumn
Call wrd.Selection.MoveRight(wdCell) ' Move one cell to the right.
On Error Goto ErrorProc
If SingleColumn% Then
Call wrd.MailingLabel.CreateNewDocument(LabelTemplate,LabelAddress)
End If
Else
Call wrd.MailingLabel.CreateNewDocument(LabelTemplate,LabelAddress)
End If
LabelCount!=LabelCount!+1
If TickBased% Then
Set doc = dc.GetNextDocument(doc)
Else
Set doc = view.GetNextDocument(doc)
End If
Wend
If TickBased% Then
Print LabelCount!;" labels created from selected addresses"
Else
Print LabelCount!;" labels created from this Notes view (";SheetTitle$;")"
End If
REM Make the instance visible to the user
wrd.visible = True

Exit Sub
TrapTemplateName:
Messagebox "Incorrect Template Name",16,db.Title
Exit Sub

TrapSingleColumn:
Print "Detected non-table labels and changing behaviour accordingly"
SingleColumn%=True
Resume Next
ErrorProc:
Print "(";Erl;") ";Error$
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
If Instr(ThisField,"(")>0 And Instr(ThisField,")")>0 Then
ThisFieldTemp$=Right$(ThisField,Len(ThisField)-Instr(ThisField,"("))
ThisFieldIndex%=Val(Left$(ThisFieldTemp$,Len(ThisFieldTemp$)-1))
ThisField=Left$(ThisField,Instr(ThisField,"(")-1)
Else
ThisFieldIndex%=-1
End If
TempArray=doc.GetItemValue(ThisField)
If ThisFieldIndex%>=0 Then
If Ubound(TempArray)>=ThisFieldIndex% Then
TempOutput=TempOutput+" "+TempArray(ThisFieldIndex%)
End If
Else
TempOutput=TempOutput+" "+TempArray(0)
End If
Wend
End If
GetListFieldValues=TempOutput
End Function

This was first published in November 2000

Dig deeper on Domino Resources - Part 5

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