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.
jey
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 UIView=ws.CurrentView
Set view = UIview.View
SheetTitle$=UIView.ViewName
' 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 5167")
' 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
previous page
|