We help IT Professionals succeed at work.

Working with Microsoft Word

Dear all,

I am now need to generate a large
amount of customer letter on microsoft word, according
to the customer name, address, ..etc.

Each Letter is having a standard format.

What i need to do is to retreive the
customer name, customer address, and
then dump to the word document and save
as a particular customer named file.

How do i do the above using visual basic ?

Would be appreciate if you can provide the coding..

kan
Comment
Watch Question

Ryan ChongSoftware Tead Lead / Business Analyst / System Analyst / Data Engineer
CERTIFIED EXPERT

Commented:
Hi,

Try to use the Mail Merge function in M$ Word.

Anyway, you can use VB to integrate with it..
Ryan ChongSoftware Tead Lead / Business Analyst / System Analyst / Data Engineer
CERTIFIED EXPERT

Commented:
How to Use Automation to Run Word 97 Mail Merge from Access:
http://support.microsoft.com/support/kb/articles/q159/3/28.asp
Commented:
Word uses a find & replace to carry out the merge, so in the Word template you will need to enter the field names to replace.

Hopefully this will help.


Below is some sample code that should get you started
The statements below allow you to specify the filepath & documentname of the document to create, the name&location of the template file to merge with, and a recordset to pass.

objWord.FilePath = Me.txtPath 'Doc to create path
objWord.FileName = Me.txtDocName 'Doc to create name
objWord.mergeDocument = "c:\WordDocs\Templates\printquote.dot" 'merge doc
Set objWord.MergeRecordset = rsResult 'Recordset
objWord.DocumentMerge
           
           
Set objWord = Nothing


'Copy whole of code below into a class module

Option Explicit


Private WithEvents mobjWordApp As Word.Application
Private mlngWidth As Long
Private mlngHeight As Long
Private mlngTop As Long
Private mlngLeft As Long
Private mCurrPath As String
Private mstrMergeDocument As String
Private mstrMergeDelimiter As String
Private mstrCaption As String
Private mstrFilePath As String
Private mstrFileName As String
Private mstrTemplate As String
Private mblnAllowUserOpen As Boolean
Private mblnAllowUserNew As Boolean
Private mblnAllowUserEdit As Boolean
Private mblnAllowUserSave As Boolean
Private mblnAllowUserSaveAs As Boolean
Private mblnAllowLoseFocus As Boolean
Private mintstatus As Integer
Private mrstMergeRecordset As ADODB.Recordset

Public Event CurrentDocumentPath(ByVal FilePath As String)
Public Event intCLSwordError(ByVal ErrNo As Integer, ByVal ErrDescription As String)

Private Sub Class_Initialize()

On Error GoTo errhandler

Dim pintTemp As Integer
Dim strError As String
'set defaults
mlngWidth = 250
mlngHeight = 250
mlngTop = 50
mlngLeft = 100
mstrMergeDocument = ""
mstrMergeDelimiter = "%%"
mstrTemplate = ""
mblnAllowUserEdit = True
mblnAllowUserOpen = True
mblnAllowUserNew = True
mblnAllowUserSave = True
mblnAllowUserSaveAs = True
mstrFilePath = ""
mstrCaption = ""
mstrFileName = ""
Set mrstMergeRecordset = Nothing
'set reference to word

Set mobjWordApp = New Word.Application

'mobjWordApp.Visible = True

exithere:
Exit Sub

errhandler:
strError = Err.Description & vbCrLf & "The application was unable to to launch Word"
RaiseEvent intCLSwordError(Err.Number, strError)
GoTo exithere:

End Sub

Public Sub DocumentOpen(vFilePath As String)

On Error GoTo errhandler:

Dim setEdit As Boolean

Call setParameters

'setEdit = mblnAllowUserOpen
'mblnAllowUserOpen = True

If mblnAllowUserEdit = False Then
mobjWordApp.Documents.Open vFilePath, , True
Else
mobjWordApp.Documents.Open vFilePath
End If
mCurrPath = mobjWordApp.ActiveDocument.FullName
mobjWordApp.Application.RecentFiles.add (parseFileName(vFilePath))

Call ConfigureMenus

mobjWordApp.Visible = True

exithere:
Exit Sub

errhandler:
'
RaiseEvent intCLSwordError(Err.Number, Err.Description)
GoTo exithere:


End Sub

Public Sub DocumentNew()

On Error GoTo errhandler:
Dim strTemp
Dim setEdit As Boolean

Call setParameters

mobjWordApp.Documents.add

' if a document path or name supplied, save doc accordingly

If mstrFilePath = "" Then
mstrFilePath = mobjWordApp.Options.DefaultFilePath(wdDocumentsPath)
End If
       
If mstrFileName = "" Then
mstrFileName = mobjWordApp.ActiveDocument.Name
End If

strTemp = mstrFilePath & "\" & mstrFileName

'*********ADDED BY BAC 30/06/01 ***************
'Check if folder exists
If CheckFolderExist(mstrFilePath) Then

    '**********************************************
    mobjWordApp.ActiveDocument.SaveAs strTemp
           
    mobjWordApp.Application.RecentFiles.add (mobjWordApp.ActiveDocument.FullName)
    mCurrPath = mobjWordApp.ActiveDocument.FullName
   
    Call ConfigureMenus
   
    mobjWordApp.Visible = True

Else
    'CLOSE WORD
    mobjWordApp.Application.Quit
End If

exithere:
Exit Sub

errhandler:
'
RaiseEvent intCLSwordError(Err.Number, Err.Description)
GoTo exithere:



End Sub

Sub DocumentMerge()

' allow first change of document without firing doc change event
' after that, any change will call doc change and be reposnded to accordingly

Dim strTemp As String

If (IsEmpty(mrstMergeRecordset)) And mstrMergeDocument = "" Then
' a recordsets here but no doc to put it in
RaiseEvent intCLSwordError(1002, "No recordset or merge document supplied.")
Exit Sub
End If



If (Not IsEmpty(mrstMergeRecordset)) And mstrMergeDocument = "" Then
' a recordsets here but no doc to put it in
RaiseEvent intCLSwordError(1000, "No merge document specified.")
Exit Sub
End If

If (IsEmpty(mrstMergeRecordset)) And mstrMergeDocument <> "" Then
' a recordsets here but no doc to put it in
RaiseEvent intCLSwordError(1001, "No recordset specified.")
Exit Sub
End If


Dim setEdit As Boolean
Call setParameters
setEdit = mblnAllowUserOpen
mblnAllowUserOpen = True

mobjWordApp.Documents.Open mstrMergeDocument


' if a document path or name supplied, save doc accordingly
If mstrFilePath = "" Then
    mstrFilePath = mobjWordApp.Options.DefaultFilePath(wdDocumentsPath)
End If
       
If mstrFileName = "" Then
mstrFileName = mobjWordApp.ActiveDocument.Name
End If

strTemp = mstrFilePath & "\" & mstrFileName

'*********ADDED BY BAC 30/06/01 ***************
'Check if folder exists
If CheckFolderExist(mstrFilePath) Then
        mobjWordApp.ActiveDocument.SaveAs strTemp
               
        mobjWordApp.Application.RecentFiles.add (mobjWordApp.ActiveDocument.FullName)
        mCurrPath = mobjWordApp.ActiveDocument.FullName
       
        If setEdit = False Then
        mblnAllowUserOpen = False
        End If
       
  Call ConfigureMenus
              Call DoMerge
       
        mobjWordApp.Visible = True
Else
    'CLOSE WORD
    mobjWordApp.Application.Quit
End If

exithere:
Exit Sub

errhandler:

RaiseEvent intCLSwordError(Err.Number, Err.Description)
GoTo exithere:


End Sub



Sub ConfigureMenus()

On Error GoTo errhandler:

'deal with any commands which mustnt be present. Uses ID no.s supplied by Microsoft,
' need changing with later versions of word.
mobjWordApp.CustomizationContext = mobjWordApp.ActiveDocument
On Error Resume Next
If mblnAllowUserNew = False Then
    mobjWordApp.CommandBars("Menu Bar").FindControl(ID:=18, Recursive:=True).Enabled = False
    mobjWordApp.CommandBars("standard").Controls("New").Enabled = False
End If

If mblnAllowUserOpen = False Then
    mobjWordApp.CommandBars("Menu Bar").FindControl(ID:=23, Recursive:=True).Enabled = False
    mobjWordApp.CommandBars("standard").Controls("Open...").Enabled = False
End If

If mblnAllowUserSave = False Then
    mobjWordApp.CommandBars("Menu Bar").FindControl(ID:=3, Recursive:=True).Enabled = False
    mobjWordApp.CommandBars("standard").Controls("Save").Enabled = False
End If
If mblnAllowUserSaveAs = False Then
    mobjWordApp.CommandBars("Menu Bar").FindControl(ID:=748, Recursive:=True).Enabled = False
    mobjWordApp.CommandBars("standard").Controls("Save As...").Enabled = False
End If
On Error GoTo 0

exithere:
Exit Sub

errhandler:
'
RaiseEvent intCLSwordError(Err.Number, Err.Description)
GoTo exithere:



End Sub


Private Sub Class_Terminate()
Set mobjWordApp = Nothing

End Sub

Private Sub mobjWordApp_DocumentChange()

On Error GoTo errhandler:

' need to check whats happeniing and respond accordingly
' choices are : new opened over the top of ours
'               ours closed and new opened
'               ours saved with a different name
'
Dim strTemp

' check if empty - theyve closed doc but not word
If mobjWordApp.Documents.Count = 0 Then

' pick up what the document was from recent file list
mCurrPath = mobjWordApp.Application.RecentFiles.Item(1).path & "\" & mobjWordApp.Application.RecentFiles.Item(1).Name
mobjWordApp.Application.Quit
Set mobjWordApp = Nothing
RaiseEvent CurrentDocumentPath(mCurrPath)
Exit Sub
End If

If mobjWordApp.Documents.Count = 1 And mobjWordApp.ActiveDocument.FullName <> mCurrPath Then
' the original document has been replaced
' update mcurrpath to reflect
mCurrPath = mobjWordApp.ActiveDocument.FullName
End If

If mobjWordApp.Documents.Count > 1 And mobjWordApp.ActiveDocument <> mCurrPath Then
mobjWordApp.ActiveDocument.Close
mCurrPath = mobjWordApp.ActiveDocument.FullName
mobjWordApp.Application.RecentFiles.add mCurrPath
End If

exithere:
Exit Sub

errhandler:
'
RaiseEvent intCLSwordError(Err.Number, Err.Description)
GoTo exithere:

End Sub

Private Sub mobjWordApp_Quit()

On Error GoTo errhandler:

Dim strTemp As String

mobjWordApp.CommandBars("Menu Bar").Reset
mobjWordApp.CommandBars("Standard").Reset

strTemp = mobjWordApp.ActiveDocument.FullName
mobjWordApp.Quit
Set mobjWordApp = Nothing

RaiseEvent CurrentDocumentPath(strTemp)

exithere:
Exit Sub

errhandler:
'
RaiseEvent intCLSwordError(Err.Number, Err.Description)
GoTo exithere:


End Sub


Public Property Get Width() As Long
Width = mlngWidth
End Property

Public Property Let Width(ByVal vNewValue As Long)
mlngWidth = vNewValue
End Property

Public Property Get Height() As Long
Height = mlngHeight
End Property

Public Property Let Height(ByVal vNewValue As Long)
mlngHeight = vNewValue
End Property
Public Property Get MergeDelimiter() As String
'MergeDelimiter = mlngMergeDelimiter
End Property

Public Property Let MergeDelimiter(ByVal vNewValue As String)
mstrMergeDelimiter = vNewValue
End Property
Public Property Get mergeDocument() As String
mergeDocument = mstrMergeDocument
End Property

Public Property Let mergeDocument(ByVal vNewValue As String)
mstrMergeDocument = vNewValue
End Property


Public Property Set MergeRecordset(ByVal vNewValue As ADODB.Recordset)
Set mrstMergeRecordset = vNewValue
End Property

Public Property Get Left() As Long
Left = mlngLeft
End Property
Public Property Let Left(ByVal vNewValue As Long)
mlngLeft = vNewValue
End Property


Public Property Get Top() As Long
Top = mlngTop
End Property

Public Property Let Top(ByVal vNewValue As Long)
mlngTop = vNewValue
End Property


Public Property Get AllowUserOpen() As Boolean
Stop
AllowUserOpen = mblnAllowUserOpen
End Property

Public Property Let AllowUserNew(ByVal vNewValue As Boolean)
mblnAllowUserNew = vNewValue
End Property
Public Property Get AllowUserNew() As Boolean
AllowUserNew = mblnAllowUserNew
End Property

Public Property Let AllowUserOpen(ByVal vNewValue As Boolean)
mblnAllowUserOpen = vNewValue
End Property

Public Property Get AllowUserEdit() As Boolean
AllowUserEdit = mblnAllowUserEdit
End Property

Public Property Let AllowUserEdit(ByVal vNewValue As Boolean)
mblnAllowUserEdit = vNewValue
End Property

Public Property Get AllowUserSave() As Boolean
AllowUserSave = mblnAllowUserSave
End Property

Public Property Let AllowUserSave(ByVal vNewValue As Boolean)
mblnAllowUserSave = vNewValue
End Property
Public Property Get AllowUserSaveAs() As Boolean
AllowUserSaveAs = mblnAllowUserSaveAs
End Property

Public Property Let AllowUserSaveAs(ByVal vNewValue As Boolean)
mblnAllowUserSaveAs = vNewValue
End Property



Public Property Get FilePath() As String
FilePath = mstrFilePath
End Property

Public Property Let FilePath(ByVal vNewValue As String)
mstrFilePath = vNewValue
End Property

Public Property Get FileName() As String
FileName = mstrFilePath
End Property

Public Property Let FileName(ByVal vNewValue As String)
mstrFileName = vNewValue
End Property


Public Property Get Caption() As String
Caption = mstrCaption
End Property

Public Property Let Caption(ByVal vNewValue As String)
mstrCaption = vNewValue
End Property

Private Sub setParameters()

On Error GoTo errhandler:

Dim intTemp As Integer
Dim intCommand As Integer
mobjWordApp.Width = mlngWidth
mobjWordApp.Height = mlngHeight
mobjWordApp.Top = mlngTop
mobjWordApp.Left = mlngLeft
mobjWordApp.Caption = mstrCaption

exithere:
Exit Sub

errhandler:
'
RaiseEvent intCLSwordError(Err.Number, Err.Description)


GoTo exithere:

End Sub

Private Function parseFileName(vFilePath)

On Error GoTo errhandler:

Dim lngStartPos As Long

lngStartPos = InStrRev(vFilePath, "\")

parseFileName = Right(vFilePath, Len(vFilePath) - lngStartPos)

exithere:
Exit Function

errhandler:
'
RaiseEvent intCLSwordError(Err.Number, Err.Description)
GoTo exithere:

End Function

Private Sub DoMerge()
' examine recordset, get field name check if its in the doc and substitute
Dim sintcount As Long
Dim sstrTemp As String
Dim blnfound As Boolean
Dim lngNo As Long
Dim lngCount As Long

On Error GoTo errhandler:
lngNo = mrstMergeRecordset.RecordCount
mrstMergeRecordset.MoveFirst
lngCount = 0
While Not mrstMergeRecordset.EOF
lngCount = lngCount + 1
    For sintcount = 0 To mrstMergeRecordset.Fields.Count - 1
   
    blnfound = True
    sstrTemp = mrstMergeRecordset.Fields(sintcount).Value
   
    mobjWordApp.Selection.HomeKey Unit:=wdStory
    While blnfound = True
       
        mobjWordApp.Selection.Find.ClearFormatting
        With mobjWordApp.Selection.Find
            .Text = mstrMergeDelimiter & mrstMergeRecordset.Fields(sintcount).Name & mstrMergeDelimiter
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        mobjWordApp.Selection.Find.Execute
   
       
        If mobjWordApp.Selection.Find.Found Then
         mobjWordApp.Selection.InsertAfter (sstrTemp)
         'mobjWordApp.ActiveDocument.Selection.Range = sstrTemp
        mobjWordApp.Selection.Find.Execute mstrMergeDelimiter & mrstMergeRecordset.Fields(sintcount).Name & mstrMergeDelimiter, , , , , , , , , "", wdReplaceOne
        Else
       
        blnfound = False
        End If
       
    Wend
   
    Next
   
If mrstMergeRecordset.RecordCount > 1 And (lngCount < lngNo) Then
'put in a page break
mobjWordApp.Selection.EndKey Unit:=wdLine, Extend:=wdExtend
mobjWordApp.Selection.EndKey Unit:=wdStory
mobjWordApp.Selection.InsertBreak Type:=wdPageBreak
mobjWordApp.Selection.InsertFile FileName:=mstrMergeDocument, Range:="", ConfirmConversions:=False, Link:=False, Attachment:=False
End If

mrstMergeRecordset.MoveNext


Wend



'mobjWordApp.ActiveDocument.Save


exithere:

Exit Sub

errhandler:
If Err.Number = 94 Then 'invalid use of null
sstrTemp = "****MISSING DATA****"

Resume Next

Else
RaiseEvent intCLSwordError(Err.Number, Err.Description)

GoTo exithere:
End If

End Sub

Public Function CheckFolderExist(path As Variant) As Boolean
    'function to check if the folder exists. If it does not then
    'create it
    Dim obj_fso As New FileSystemObject

On Error GoTo Error:

    If obj_fso.FolderExists(path) Then
        CheckFolderExist = True
    Else
        'create folder
        obj_fso.CreateFolder (path)
        CheckFolderExist = True
    End If
    Set obj_fso = Nothing
Exit Function
Error:
    CheckFolderExist = False
    MsgBox Err.Description
End Function

Public Sub SearchAndReplace( _
  strFind As String, _
  strReplace As String, _
  fMatchCase As Boolean, _
  fMatchWholeWord As Boolean, _
  fMatchWildcards As Boolean)
  ' Comments  : Runs search and replace on the current document with
  '             the specified options
  ' Parameters: strFind - text to find
  '             strReplace - text to replace with
  '             fMatchCase - True for case-sensitive search
  '             fMatchWholeWord - True for whole-word search
  '             fMatchWildcards - True for wildcard search
  ' Returns   : Nothing
  ' Source    : Total Visual SourceBook 2000
  '
  On Error GoTo PROC_ERR
 
 
  If Len(strReplace) > 255 Then
   
    'With ActiveDocument.Content.Find
    '    .Execute FindText:=strFind, Forward:=True, Format:=True
    '    With .Parent
    '        .StartOf Unit:=wdParagraph, Extend:=wdMove
    '        .InsertAfter strReplace
    '        .Move Unit:=wdParagraph, Count:=1
    '    End With

    'End With
   
     'Use the Find method of the Content object
   ' With ActiveDocument.Content.Find
     
       'Set various properties
   '   .MatchCase = fMatchCase
   '   .MatchWholeWord = fMatchWholeWord
   '   .MatchWildcards = fMatchWildcards
   '   .Text = strFind
   '   .Replacement.Text = ""
   '   ' Call the execute method to do the actual work
    '  .Execute Replace:=wdReplaceAll, Forward:=True
     
   ' End With
 
  Else
 
    ' Use the Find method of the Content object
    With ActiveDocument.Content.Find
     
      ' Set various properties
      .MatchCase = fMatchCase
      .MatchWholeWord = fMatchWholeWord
      .MatchWildcards = fMatchWildcards
      .Text = strFind
      .Replacement.Text = strReplace
     
     
      ' Call the execute method to do the actual work
      .Execute Replace:=wdReplaceAll, Forward:=True
    End With
   End If
   
PROC_EXIT:
  Exit Sub
 
PROC_ERR:
  MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "SearchAndReplace"
  Resume PROC_EXIT
 
End Sub

Public Function CheckFileExists(path As Variant) As Boolean
    'function to check if the selected file exists. If it does not then
    'warn the user
    Dim obj_fso As New FileSystemObject

On Error GoTo Error:

    If obj_fso.FileExists(path) Then
        CheckFileExists = True
    Else
        'Warn User
        CheckFileExists = False
        mobjWordApp.Application.Quit
    End If
    Set obj_fso = Nothing
Exit Function
Error:
    CheckFileExists = False
    MsgBox Err.Description
End Function


Mike McCrackenSenior Consultant
CERTIFIED EXPERT
Most Valuable Expert 2011
Top Expert 2013

Commented:
listening

Explore More ContentExplore courses, solutions, and other research materials related to this topic.