Create home address labels from personal NAB

Quick way to highlight contacts in your NAB "Contact" view and print out home address mailing labels in MS Word.

Quick way to highlight contacts in your NAB "Contact" view and print our home address mailing labels in MS Word (Great for the holidays).

Create an agent in your Personal NAB ("Manually From Actions Menu" and "Run On Selected Documents");

 Declarations Public Const Sep = "~~" Public Const MultSep = "^^" *************************************** Initialize Sub Initialize %REM CREATED: 12/01/2000, By J. Scott Russo MODIFIED: <date>, By <name>; <brief description> Creates MS labels from selected documents in your Personal NAB, "Contact" view. %END REM ' 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 Dim colcount As Integer Set settings=db.GetProfileDocument("Settings","") ' declare Notes front-end objects Dim ws As New NotesUIWorkspace Set dc=db.UnProcessedDocuments ' declare constants wdCell = 12 'Microsoft Word VBA constant. Designates unit for table cell. wdLine=7 'wdCustomLabelA4 = 2 Divmod=1 cr = Chr(13) & Chr(10) ' Carriage return. TickBased%=True ' get required template from user LabelTemplate = Inputbox("Please enter the MS Word mailing label name to use. ", db.Title,"Avery 5163") columns = Inputbox("Please enter the number of columns in this MS Word mailing label template. ", db.Title,"2") colcount=Cint(columns) dividers = Inputbox("Are there any dividers between the columns? (Please only answer Yes or No)", db.Title,"Yes") If dividers="Yes" Then skip=True Else skip=False ' 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 Word 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!=1 If TickBased% Then Set doc=dc.GetFirstDocument Else Set doc=view.GetFirstDocument End If While Not doc Is Nothing ' build label text LabelAddress="" LabelAddress = GetfieldValues(doc) If Not SingleColumn% Then Call wrd.Selection.TypeText(LabelAddress) ' Insert full address into Word. 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 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 divmod=labelcount! Mod colcount 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 fReplace( Byval StringValue As String, Sep As String, ReplaceSep As String ) As String %REM CREATED: 09/17/97 by Scott Erlanger This function replace a character (Sep) with another one (ReplaceSep). Works exactly like @ReplaceSubstring. It breaks a string into left and right sides of the separator and recursively calls the function to work on the remaining string (the right side). %END REM StringLen% = Len( StringValue ) SepLen% = Len( Sep ) SepLoc% = Instr( 1, StringValue, Sep ) If ( SepLoc% > 0 ) Then LeftValue$ = Left( StringValue, ( SepLoc% - 1 ) ) LeftValueLen% = Len( LeftValue$ ) RightValue$ = Right( StringValue, ( StringLen% - LeftValueLen% - SepLen% ) ) NextString$ = fReplace( RightValue$, Sep, ReplaceSep ) fReplace = LeftValue$ & ReplaceSep & NextString$ Else fReplace = StringValue End If End Function *************************************** Function getfieldvalues(doc As notesdocument) As String cr = Chr(13) & Chr(10) ' Carriage return. AllAdd$=fReplace(fReplace(doc.Address(0) ,Chr(13) & Chr(10)&Chr(13) & Chr(10) ,Chr(13) & Chr(10) ),Chr(13) & Chr(10) &Chr(13) & Chr(10) ,Chr(13) & Chr(10) ) 'AddressBlock= AllAdd$ & cr & (CityStateZip) 'AddressBlock= doc.address(0) & cr & (CityStateZip) ' Addressblock=fReplace(Addressblock,Chr(13) & Chr(10) &Chr(13) & Chr(10),Chr(13) & Chr(10) ) AddressBlock = doc.HomeAddress(0) & " " & doc.Zip(0) If doc.form(0)="Person" Then Namelist=doc.FullName(0) varFirstName = doc.FirstName(0) varLastName = doc.LastName(0) varSpouse = doc.Spouse(0) If varSpouse <> "" Then NameList = varFirstName & " & " & varSpouse & " " & varLastName Else NameList = varFirstName & " " & varLastName End If ' GetFieldValues=fReplace(Namelist & cr & Addressblock,Chr(13) & Chr(10)&Chr(13) & Chr(10) ,Chr(13) & Chr(10) ) GetFieldValues=Namelist & cr & Addressblock End If End Function
This was first published in June 2001

Dig deeper on Domino Resources - Part 3

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

SearchWinIT

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

SearchVirtualDataCentre.co.UK

Close