Create home address labels from personal NAB

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

There are Comments. Add yours.

TIP: Want to include a code block in your comment? Use <pre> or <code> tags around the desired text. Ex: <code>insert code</code>

REGISTER or login:

Forgot Password?
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
Sort by: OldestNewest

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:

Disclaimer: Our Tips Exchange is a forum for you to share technical advice and expertise with your peers and to learn from other enterprise IT professionals. TechTarget provides the infrastructure to facilitate this sharing of information. However, we cannot guarantee the accuracy or validity of the material submitted. You agree that your use of the Ask The Expert services and your reliance on any questions, answers, information or other materials received through this Web site is at your own risk.