We help IT Professionals succeed at work.

VB 6/ Mail Merge/Access Database

Lushous
Lushous asked
on
Hi all,

I have an access database with a list of client names. I have a VB program that i want to interface with a word doc to access a particular file and then mail merge with the names in the database.

I am using the code below to open the word doc from VB but how do i then get to merge the data from the database into the word doc??

Private Sub cmdCreateNewsletter_Click()

Dim objWord As Word.Application
Set objWord = New Word.Application
With objWord
.Visible = True
.Documents.Open App.Path & "\news.doc"
.Selection.InsertAfter ""
.Quit True
End With
Set objWord = Nothing
End Sub

I was thinking I need to insert some more code somewhere?

Any ideas?
Comment
Watch Question

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

Commented:
Hi, i also work with word mail merge these day and hope the following links with help you a litte:

http://www.planet-source-code.com/xq/ASP/txtCodeId.1038/lngWId.1/qx/vb/scripts/ShowCode.htm

http://www.mvps.org/access/bugs/bugs0011.htm

http://www.tfwpa.com/msaccess/wordmerge.htm

'Hope will help.
Commented:
I do a similar thing with this module - pass MergeToPrinter a populated recordset and the name of the template (hard coded to be in a Letters subdirectory of the application directory


'Retrieve a network login ID
Declare Function WNetGetUser Lib "mpr" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpusername As String, lpnLength As Long) As Long

'Ini File handling
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyname As Any, ByVal lpDefault As String, ByVal lpreturnedstring As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyname As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
'Temp file creation
Declare Function OSGetTempPath& Lib "kernel32" Alias "GetTempPathA" (ByVal BufferLength&, ByVal result$)
Declare Function OSGetTempFilename& Lib "kernel32" Alias "GetTempFileNameA" (ByVal FilePath$, ByVal Prefix$, ByVal wUnique&, ByVal TempFileName$)

Public oWordMerge As Object              'Activating Word by Object Automation


Function SearchReplace(ByVal SourceStr As String, LookFor As String, ReplaceWith As String) As String

Dim CharPos As Integer
ReFind:
CharPos = InStr(SourceStr, LookFor)
If CharPos > 0 Then
    SourceStr = left$(SourceStr, CharPos - 1) & ReplaceWith & right$(SourceStr, Len(SourceStr) - CharPos)
    GoTo ReFind
End If
SearchReplace = SourceStr
End Function
Function sGetTempFile()
Dim sFilePath As String
Dim sTempResult As String
Dim lCharCount As Long
Dim sPrefix As String * 3

   Const MAX_RETURN = 3000

   sTempResult = Space$(MAX_RETURN)
   lCharCount = OSGetTempPath&(MAX_RETURN, sTempResult)

   sFilePath = left$(sTempResult, lCharCount)
   sGetTempFile = sFilePath & GetUser() & ".txt"
   'sTempResult = Space$(MAX_RETURN)
   'sPrefix = Left$(UCase$(GetUser()), 3)
   'lCharCount = OSGetTempFilename&(sFilePath, sPrefix, 0, sTempResult)
   'sGetTempFile = Left$(sTempResult, lCharCount)

End Function

Function GetUser() As String
Dim ReturnCode As Integer
Dim UserName As String
Dim lp As String
    Dim size As Long
    GetUser = "Nonetwrk"
    UserName = String$(255, 0)
    size = Len(UserName)
    ReturnCode = WNetGetUser&(lp, UserName, size)
    If ReturnCode = 0 Then
        While Asc(Mid$(UserName, size, 1)) = 0
            size = size - 1
        Wend
        GetUser = left$(UserName, size)
    End If
End Function
'------------------------------------------------------------
' MergeToPrinter
'
'   Merge a recordset direct to the printer using object
'   automation of a word document  CMQ - July 1997
'------------------------------------------------------------
Sub MergeToPrinter(rsMail As Recordset, DocName As String)

Dim WindowNum As Integer
Dim LoopCounter As Integer, RecordDone As Integer, RetVal As Variant
Dim Inifile As String, TemplateName As String, MergeFile As String
Dim MaxRecs As Integer, RecPrompt As String
Dim MergeFileNum As Integer, PrintActive As Integer
Dim sMemo As String, iStart As Integer

On Error GoTo MergeToPrinter_Err

Inifile = AppPath() & "mailmerg.ini"             'No - pick up the local ini file

'TemplateName = GetSetting(Inifile, "MailMerge", DocName, "")    'Get the template name from the Ini
TemplateName = DocName & ".dot"


rsMail.MoveLast
rsMail.MoveFirst
MaxRecs = rsMail.RecordCount                    'How many records?

MergeFileNum = FreeFile     'Get the next free file number

MergeFile = sGetTempFile()  'Create the merge file in the TEMP directory
Open MergeFile For Output As MergeFileNum   'Open the file for output
Headerline = ""
For LoopCounter = 0 To rsMail.Fields.Count - 1          'Create the header line
    Headerline = Headerline & rsMail(LoopCounter).Name
    If LoopCounter < rsMail.Fields.Count - 1 Then Headerline = Headerline & Chr$(9) 'Fieldnames - tab separated
Next LoopCounter
Print #MergeFileNum, Headerline             'Write it to the file
For RecordDone = 1 To MaxRecs                          'Write each line of data
    Headerline = ""
    For LoopCounter = 0 To rsMail.Fields.Count - 1        'For each record found
        If rsMail(LoopCounter).Type = dbMemo Or rsMail(LoopCounter).Type = dbText Then
            sMemo = Trim$(NotNull(rsMail(LoopCounter)))
            Do While InStr(sMemo, Chr$(13)) <> 0
                iStart = InStr(sMemo, Chr$(13))  ' Find where C/R is
                Mid$(sMemo, iStart, 1) = " "    ' Replace with space.
            Loop
            Headerline = Headerline & Trim$(sMemo)     'write a line - tab separated
        Else
            Headerline = Headerline & rsMail(LoopCounter)     'write a line - tab separated
        End If
        If LoopCounter < rsMail.Fields.Count - 1 Then Headerline = Headerline & Chr$(9)
    Next LoopCounter
    Print #MergeFileNum, Headerline
    rsMail.MoveNext
Next RecordDone
Close #MergeFileNum                         'Close the file


TemplateName = App.Path() & "Letters\" & TemplateName         'Set the template name
Set oWordMerge = CreateObject("Word.Application")       'Open up Word
oWordMerge.Application.Visible = True
oWordMerge.Documents.Add TemplateName                     'New document based on the template
oWordMerge.ActiveDocument.MailMerge.OpenDataSource MergeFile, False    'Specify the data file
oWordMerge.ActiveDocument.MailMerge.Destination = wdSendToNewDocument
oWordMerge.ActiveDocument.MailMerge.Execute
oWordMerge.ActiveDocument.PrintOut 0, 0, "0", "", "", "", 0, "1", "", 0, 0, 1, ""   'Print The File
oWordMerge.Documents("Document1").Close SaveChanges:=wdDoNotSaveChanges
oWordMerge.Application.WindowState = wdWindowStateMaximize
oWordMerge.Application.Visible = True
oWordMerge.Quit wdDoNotSaveChanges
MergeToPrinter_Exit:
    Exit Sub

MergeToPrinter_Err:
    MsgBox "Merge To Printer"
    Resume MergeToPrinter_Exit
End Sub

Author

Commented:
thanxs my fellow collegues

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