[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
?
Solved

Access 2002 database that will no longer properly pull data over when doing a mail merge to Word 2003.

Posted on 2014-08-28
4
Medium Priority
?
106 Views
Last Modified: 2016-06-15
The user is running Access 2002 on an XP machine. When trying to do a mail merge, we can edit the recipient list and select some of the records....even if we select individual records, the mail merge tries to pull all 8,000+ records.
The database was open when a power outage occurred and since the outage it hasn't worked. We have compacted  and repaired the database, cleared out temp files, and rebooted everything to no avail.
0
Comment
Question by:jhaysbns
4 Comments
 
LVL 46

Expert Comment

by:aikimark
ID: 40292244
have you deleted the .LDB file?
0
 
LVL 31

Accepted Solution

by:
Helen Feddema earned 2000 total points
ID: 40293139
Try this code (it works in Office 2003).  It uses a different method, creating a text file for the merge instead of a live link, so it isn't nearly as memory-intensive:

Private Sub cmdCreateDocuments_Click()
'Created by Helen Feddema 30-May-2014
'Last modified by Helen Feddema 18-Jul-2014

On Error GoTo ErrorHandler

   Dim appWord As Word.Application
   Dim cbo As Access.ComboBox
   Dim doc As Word.Document
   Dim docMerge As Word.Document
   Dim fil As Scripting.File
   Dim fso As New Scripting.FileSystemObject
   Dim i As String
   Dim intCount As Integer
   Dim intDocCount As Integer
   Dim intReturn As Integer
   Dim intSaveNameFail As String
   Dim lngContactID As Long
   Dim lngRecordCount As Long
   Dim lngSelectCount As Long
   Dim rstMerge As DAO.Recordset
   Dim rstSource As DAO.Recordset
   Dim strAddress As String
   Dim strBookmark As String
   Dim strCompanyName As String
   Dim strContactName As String
   Dim strContactNameAndJob As String
   Dim strCountry As String
   Dim strDBPath As String
   Dim strDefaultDocsPath As String
   Dim strDefaultTemplatesPath As String
   Dim strDocsPath As String
   Dim strDocType As String
   Dim strJobTitle As String
   Dim strLongDate As String
   Dim strPhone As String
   Dim strProgressBarText As String
   Dim strQuery As String
   Dim strRecordSource As String
   Dim strSalutation As String
   Dim strSaveName As String
   Dim strSaveNamePath As String
   Dim strShortDate As String
   Dim strTemplateName As String
   Dim strTemplateNameAndPath As String
   Dim strTemplatesPath As String
   Dim strTest As String
   Dim strTestFile As String
   Dim strTextFile As String
   
On Error Resume Next

   'Delete old merge data text file, if it exists
   strDBPath = Application.CurrentProject.Path & "\"
   strTextFile = strDBPath & "Merge Data.txt"
  'Debug.Print "Text file for merge: " & strTextFile
   
   Set fil = fso.GetFile(strTextFile)
   
On Error GoTo ErrorHandler
   
   If Not (fil Is Nothing) Then
      fil.Delete
   End If
   
   DoCmd.SetWarnings False
      
   'Check that a template has been selected
   Set cbo = Me![cboSelectDocument]
   strTemplateName = Nz(cbo.Value)
   If strTemplateName = "" Then
      strTitle = "No template selected"
      strPrompt = "Please select a template"
      MsgBox prompt:=strPrompt, _
         buttons:=vbInformation + vbOKOnly, _
         Title:=strTitle
      cbo.SetFocus
      cbo.Dropdown
      GoTo ErrorHandlerExit
   Else
      Debug.Print "Template: " & strTemplateName
      strDocType = cbo.Column(1)
   End If
   
   strFilter = GetProperty("Filter", "")
   lngRecordCount = Nz(DCount("*", "qryMergeContacts"))
      
   'Check that a document has been selected
   Set cbo = Me![cboSelectDocument]
   strTemplateName = Nz(cbo.Column(0))
  'Debug.Print "Template: " & strTemplateName
   strFilter = GetProperty("Filter", "")
   lngRecordCount = Nz(DCount("*", "qryMergeContacts"))
   
   If strTemplateName = "" Then
      strTitle = "No document selected"
      strPrompt = "Please select a document"
      MsgBox prompt:=strPrompt, _
         buttons:=vbInformation + vbOKOnly, _
         Title:=strTitle
      cbo.SetFocus
      cbo.Dropdown
      GoTo ErrorHandlerExit
   ElseIf strFilter = " " Then
      strTitle = "Question"
      strPrompt = "Create a merge document for all " & lngRecordCount _
         & " contacts?"
      intReturn = MsgBox(prompt:=strPrompt, _
         buttons:=vbQuestion + vbYesNo, _
         Title:=strTitle)
      If intReturn = vbNo Then
         GoTo ErrorHandlerExit
      ElseIf intReturn = vbYes Then
         DoCmd.CopyObject newname:="qfltMergeContacts", _
            sourceobjecttype:=acQuery, _
            sourceobjectname:="qryMergeContacts"
      End If
   End If
   
   'Set Word application variable; if Word is not running,
   'the error handler defaults to CreateObject
   Set appWord = GetObject(, "Word.Application")
   
   strLongDate = Format(Date, "mmmm d, yyyy")
   strShortDate = Format(Date, "m-d-yyyy")
   
   'Get selected Docs and Templates paths from database properties
   '(saved from controls on main menu)
   strDocsPath = GetDocsPath
   strTemplatesPath = GetTemplatesPath
   strTemplateNameAndPath = strTemplatesPath & strTemplateName
  'Debug.Print "Template name and path: " & strTemplateNameAndPath
   
   'Check for existence of template in templates folder,
   'and exit if not found
On Error Resume Next

   Set fil = fso.GetFile(strTemplateNameAndPath)
   If fil Is Nothing Then
      strTitle = "Template not found"
      strPrompt = "Can't find " & strTemplateName & " in " _
         & strTemplatesPath & "; canceling"
      MsgBox prompt:=strPrompt, _
         buttons:=vbInformation + vbOKOnly, _
         Title:=strTitle
      GoTo ErrorHandlerExit
   End If
   
On Error GoTo ErrorHandler
   
   strTitle = "Information missing"
   strQuery = "qfltMergeContacts"
   
   Set rstSource = CurrentDb.OpenRecordset(strQuery)
   lngSelectCount = rstSource.RecordCount
   
   If lngSelectCount = 0 Then
      strTitle = "No records found"
      strPrompt = "Please select another filter"
      MsgBox prompt:=strPrompt, _
         buttons:=vbInformation + vbOKOnly, _
         Title:=strTitle
      GoTo ErrorHandlerExit
   Else
      strProgressBarText = "Creating merge document... "
      Call SysCmd(acSysCmdInitMeter, strProgressBarText, _
         lngSelectCount)
   End If
         
   'Clear tblMergeList and set up recordset based on it
   strTable = "tblMergeList"
   strSQL = "DELETE tblMergeList.* FROM tblMergeList;"
   DoCmd.SetWarnings False
   DoCmd.RunSQL strSQL
  'Debug.Print "Opening recordset based on " & strTable
   Set rstMerge = CurrentDb.OpenRecordset(strTable, dbOpenTable)
   lngRecordCount = 0
    
   Do While Not rstSource.EOF
      lngContactID = rstSource![ContactID]
     'Debug.Print "On Contact ID: " & lngContactID
      
      'Set variables with data from different fields
      strContactName = Nz(rstSource![FirstName]) & _
         " " & Nz(rstSource![LastName])
      strJobTitle = Nz(rstSource![JobTitle])
      strCompanyName = Nz(rstSource![CompanyName])
      strPhone = Nz(rstSource![WorkPhone])
      strSalutation = Nz(rstSource![Salutation])
      strAddress = Nz(rstSource![StreetAddress]) & vbCrLf & _
         Nz(rstSource![City]) & ", " & _
         Nz(rstSource![StateOrProvince]) & _
         "  " & Nz(rstSource![PostalCode])
         
      'Write data from variables to a new record in table
      With rstMerge
         .AddNew
         ![Name] = strContactName
         ![JobTitle] = strJobTitle
         ![CompanyName] = strCompanyName
         ![Address] = strAddress
         ![Salutation] = strSalutation
         ![TodayDate] = strLongDate
         .Update
      End With
         
      lngRecordCount = lngRecordCount + 1
      Debug.Print "Updating progress bar for record " _
         & lngRecordCount & " of "; lngSelectCount & " records"
      Call SysCmd(acSysCmdUpdateMeter, lngRecordCount)

NextContact:
      rstSource.MoveNext
   Loop
   
   rstSource.Close
   rstMerge.Close
   
   'Export merge list to a text file (to avoid having to open the
   'database when the document is opened later on)
   DoCmd.TransferText transfertype:=acExportDelim, _
      TableName:=strTable, _
      FileName:=strTextFile, _
      HasFieldNames:=True
   
   'Open a new merge document based on the selected template
   Set doc = appWord.Documents.Add(strTemplateNameAndPath)
  'Debug.Print "New merge doc name: " & doc.Name
         
   'Check for existence of previously saved letter in documents folder,
   'and append an incremented number to save name if found
   strSaveName = strDocType & " on " & strShortDate & ".doc"
   i = 2
   intSaveNameFail = True
   Do While intSaveNameFail
      strSaveNamePath = strDocsPath & strSaveName
     'Debug.Print "Proposed save name and path: " _
         & vbCrLf & strSaveNamePath
      strTestFile = Nz(Dir(strSaveNamePath))
     'Debug.Print "Test file: " & strTestFile
      If strTestFile = strSaveName Then
        'Debug.Print "Save name already used: " & strSaveName
         
         'Create new save name with incremented number
         intSaveNameFail = True
         strSaveName = strDocType & " " & CStr(i) _
            & " on " & strShortDate & ".doc"
         strSaveNamePath = strDocsPath & strSaveName
        'Debug.Print "New save name and path: " _
            & vbCrLf & strSaveNamePath
         i = i + 1
      Else
        'Debug.Print "Save name not used: " & strSaveName
         intSaveNameFail = False
      End If
   Loop
   
  'Debug.Print "Final save name: " & strSaveNamePath
   
   'Set the merge data source to the text file just created,
   'and do the merge
   With doc
      .MailMerge.OpenDataSource Name:=strTextFile, _
         Format:=wdOpenFormatText
      
      If Nz(InStr(strTemplateName, "Label")) > 0 Then
         .MailMerge.MainDocumentType = wdMailingLabels
      Else
         .MailMerge.MainDocumentType = wdFormLetters
      End If
      
      .MailMerge.Destination = wdSendToNewDocument
      .MailMerge.Execute
      
      'Set another Document variable to the newly merged document,
      'to ensure that the correct document is saved
      Set docMerge = appWord.ActiveDocument
      .Close savechanges:=wdDoNotSaveChanges
   End With
   
   docMerge.SaveAs strSaveNamePath
   
   If lngSelectCount = 1 Then
      strPrompt = strDocType & " created for 1 contact"
   Else
      strPrompt = strDocType & " created for " _
         & lngSelectCount & " contacts"
   End If
   
   MsgBox prompt:=strPrompt, _
      buttons:=vbInformation + vbOKOnly, _
      Title:=strTitle

   Call SysCmd(acSysCmdRemoveMeter)
   Call BringDocToFront(appWord, docMerge)
      
ErrorHandlerExit:
   Set appWord = Nothing
   Exit Sub

ErrorHandler:
   If Err = 429 Then
      'Word is not running; open Word with CreateObject
      Set appWord = CreateObject("Word.Application")
      Resume Next
   Else
      MsgBox "Error No: " & Err.Number & "; Description: " _
         & Err.Description
      Resume ErrorHandlerExit
   End If

End Sub

Open in new window


This is from the Access 2003 sample database for my Working with Word ebook.
0
 

Author Comment

by:jhaysbns
ID: 40301730
I have deleted the .LDB file and that didn't seem to help.

I'll give the code a shot later today when the  client calls back and let's me on the computer.
0
 
LVL 28

Expert Comment

by:MacroShadow
ID: 41655166
No comment has been added to this question in more than 21 days, so it is now classified as abandoned.

I have recommended this question be closed as follows:

Accept: Helen_Feddema (https:#a40293139)

If you feel this question should be closed differently, post an objection and the moderators will review all objections and close it as they feel fit. If no one objects, this question will be closed automatically the way described above.

MacroShadow
Experts-Exchange Cleanup Volunteer
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

We live in a world of interfaces like the one in the title picture. VBA also allows to use interfaces which offers a lot of possibilities. This article describes how to use interfaces in VBA and how to work around their bugs.
Explore the ways to Unlock VBA Project Password Excel 2010 & 2013 documents. Go through the article and perform the steps carefully to remove VBA Excel .xls file.
With Secure Portal Encryption, the recipient is sent a link to their email address directing them to the email laundry delivery page. From there, the recipient will be required to enter a user name and password to enter the page. Once the recipient …
Visualize your data even better in Access queries. Given a date and a value, this lesson shows how to compare that value with the previous value, calculate the difference, and display a circle if the value is the same, an up triangle if it increased…

834 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question