Thread: [Solved] Email Merge With Delay
View Single Post
 
Old 02-20-2018, 07:37 AM
nevin27 nevin27 is offline Windows 7 64bit Office 2010 64bit
Novice
 
Join Date: Feb 2018
Posts: 4
nevin27 is on a distinguished road
Default

Hey Paul,

My apologies was out of office for a few days, hence could not reply earlier.
You are right, I may not need the EmailMergeTableMaker macro. All I am trying to do is send out a standard word document to around 300 users. I have an Excel file with 3 field setup; First, Last and EMail. The only merge field that I am using in my MailMerge Word doc is "First". Rest of the word doc is standard.

I also want to insert a delay timer between each email message that is sent out, say like 90 seconds. Given my limited knowledge, I tried amalgamating the above code with the Catalogue Mail Merge code, per below. I did this because i need the timer. Per the catalogue tutorial, all my data is in the "Email Merge Main Document.doc" and data source is in Catalogue Merge Data.xls, all saved in the same folder along with other documents that were in the catalogue mail merge zip.

The below macro fails in the EmailMergeTableMaker function on the ".Paragraphs(1).Range.Delete" line; saying "Object variable or with block variable not set".

Thanks a ton for helping out Paul.

Regards,

Nevin.

Code:
Sub RunMerge()
Application.ScreenUpdating = False
Dim Doc1 As Document, Doc2 As Document, Doc3 As Document, StrDoc As String
Set Doc1 = ThisDocument
StrDoc = ThisDocument.Path & "\EmailDataSource.doc"
If Dir(StrDoc) <> "" Then Kill StrDoc
With Doc1.MailMerge
  If .State = wdMainAndDataSource Then
    .Destination = wdSendToNewDocument
    .Execute
    Set Doc2 = ActiveDocument
  End If
End With
Call EmailMergeTableMaker(Doc2)
With Doc2
    j = .Tables(1).Rows.Count - 1
  .SaveAs FileName:=StrDoc, AddToRecentFiles:=False, FileFormat:=wdFormatDocument
  StrDoc = .FullName
  .Close
End With
Set Doc2 = Nothing
Set Doc3 = Documents.Open(FileName:=Doc1.Path & "\Email Merge Main Document.doc", _
  AddToRecentFiles:=False)
With Doc3.MailMerge
  .MainDocumentType = wdEMail
  .OpenDataSource Name:=StrDoc, ConfirmConversions:=False, ReadOnly:=False, _
    LinkToSource:=True, AddToRecentFiles:=False, Connection:="", SQLStatement:="", _
    SQLStatement1:="", SubType:=wdMergeSubTypeOther
  If .State = wdMainAndDataSource Then
    '.Destination = wdSendToNewDocument
    .Destination = wdSendToEmail
    .MailAddressFieldName = "Recipient"
    .MailSubject = "Monthly Sales Stats"
    .MailFormat = wdMailFormatHTML
    For i = 1 To j
      With .DataSource
        .FirstRecord = i
        .LastRecord = i
        .ActiveRecord = i
      End With
      .Execute Pause:=False
      Call Pause(90)
    Next i
  End If
End With
Doc3.Close SaveChanges:=False
Set Doc3 = Nothing
Application.ScreenUpdating = True
End Sub

Public Function Pause(Delay As Long)
Dim Start As Long
Start = Timer
If Start + Delay > 86399 Then
  Start = 0: Delay = (Start + Delay) Mod 86400
  Do While Timer > 1
    DoEvents ' Yield to other processes.
  Loop
End If
Do While Timer < Start + Delay
  DoEvents ' Yield to other processes.
Loop
End Function

Sub EmailMergeTableMaker(DocName As Document)
Dim oTbl As Table, i As Integer, j As Integer, oRow As Row, oRng As Range, strTxt As String
With DocName
  .Paragraphs(1).Range.Delete
  Call TableJoiner
  For Each oTbl In .Tables
  j = 2
    With oTbl
      i = .Columns.Count - j
      For Each oRow In .Rows
        Set oRng = oRow.Cells(j).Range
        With oRng
.MoveEnd Unit:=wdCell, Count:=i
          .Cells.Merge
          strTxt = Replace(.Text, vbCr, vbTab)
          On Error Resume Next
          If Len(strTxt) > 1 Then .Text = Left(strTxt, Len(strTxt) - 2)
        End With
      Next
    End With
  Next
  For Each oTbl In .Tables
    For i = 1 To j
      oTbl.Columns(i).Cells.Merge
    Next
  Next
  With .Tables(1)
    .Rows.Add BeforeRow:=.Rows(1)
    .Cell(1, 1).Range.Text = "Recipient"
    .Cell(1, 2).Range.Text = "Data"
  End With
  .Paragraphs(1).Range.Delete
  Call TableJoiner
End With
Set oRng = Nothing
End Sub
Private Sub TableJoiner()
Dim oTbl As Table
For Each oTbl In ActiveDocument.Tables
  With oTbl.Range.Next
    If .Information(wdWithInTable) = False Then .Delete
  End With
Next
End Sub

Last edited by macropod; 02-20-2018 at 01:55 PM. Reason: Added code tags
Reply With Quote