Domski
12-04-2009, 09:14 AM
Hi,
Having recently moved from Notes to Outlook I've been getting my hands dirty trying out some code.
What I was asked for was to develop something that would allow us to send out an email containing formatted text, images and personalised attachments to each of our 11,000+ employees.
After some research I came across some code on Sue Mosher's site (www.outlookcode.com (http://www.outlookcode.com)) that suggested the way to do this was to create the formatted email body text in a Word document and then use the code to convert that to an email and send it.
The code I have come up with is as follows:
Sub SendDocAsMsg()
' Adapted from code found on Sue Mosher's site www.outlookcode.com (http://www.outlookcode.com)
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim outApp As Outlook.Application
Dim itm As Object
Dim ID As String
Dim blnWeOpenedWord As Boolean
Dim bodyFname As String
Dim wb1 As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim lastRow As Long, myRow As Long
Dim strPersNum As String
Dim strEmail As String
Dim strMergeName As String
On Error Resume Next
' Prompt user for data file and open
TempFileName = Application.GetOpenFilename("Select data source (*.xls), *.xls")
If TempFileName = "" Then
MsgBox "No file selected!", vbCritical
Exit Sub
End If
Application.ScreenUpdating = False
Set wb1 = Workbooks.Open(TempFileName)
TempFilePath = wb1.Path
lastRow = wb1.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Set wrdApp = GetObject(, "Word.Application")
If wrdApp Is Nothing Then
Set wrdApp = CreateObject("Word.Application")
blnWeOpenedWord = True
End If
bodyFname = ThisWorkbook.Path & "\Body Text.doc"
For myRow = 2 To lastRow
Application.StatusBar = "Processing record " & myRow - 1 & " of " & lastRow - 1
' Set personnel number, name and email details
strPersNum = wb1.Sheets("Sheet1").Cells(myRow, 1).Value
strEmail = wb1.Sheets("Sheet1").Cells(myRow, 2).Value
strMergeName = wb1.Sheets("Sheet1").Cells(myRow, 12).Value
Set wrdDoc = wrdApp.Documents.Open _
(Filename:=bodyFname, ReadOnly:=True)
Set itm = wrdDoc.MailEnvelope.Item
With itm
.To = strEmail
.Subject = "Metro card renewal"
.ReplyRecipients.Add "joe.bloggs@leeds.gov.uk"
.Attachments.Add TempFilePath & "\letters\" & strMergeName & ".doc"
.Attachments.Add TempFilePath & "\Additional Info.doc"
.Send
ID = .EntryID
End With
Set itm = Nothing
Set itm = outApp.Session.GetItemFromID(ID)
itm.Send
wrdDoc.Close False
If blnWeOpenedWord Then
wrdApp.Quit
End If
Next myRow
Set wrdDoc = Nothing
Set itm = Nothing
Set wrdApp = Nothing
wb1.Close
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
The main problem is that it is very slow and takes around a minute to send 10 emails. Obviously with the volume I am planning to send the code is going to have to run for quite a long time.
Has anyone else got suggestions as to a better way to achieve this sort of thing or how the code could be made more efficient.
Any help appreciated.
Dom
Having recently moved from Notes to Outlook I've been getting my hands dirty trying out some code.
What I was asked for was to develop something that would allow us to send out an email containing formatted text, images and personalised attachments to each of our 11,000+ employees.
After some research I came across some code on Sue Mosher's site (www.outlookcode.com (http://www.outlookcode.com)) that suggested the way to do this was to create the formatted email body text in a Word document and then use the code to convert that to an email and send it.
The code I have come up with is as follows:
Sub SendDocAsMsg()
' Adapted from code found on Sue Mosher's site www.outlookcode.com (http://www.outlookcode.com)
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim outApp As Outlook.Application
Dim itm As Object
Dim ID As String
Dim blnWeOpenedWord As Boolean
Dim bodyFname As String
Dim wb1 As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim lastRow As Long, myRow As Long
Dim strPersNum As String
Dim strEmail As String
Dim strMergeName As String
On Error Resume Next
' Prompt user for data file and open
TempFileName = Application.GetOpenFilename("Select data source (*.xls), *.xls")
If TempFileName = "" Then
MsgBox "No file selected!", vbCritical
Exit Sub
End If
Application.ScreenUpdating = False
Set wb1 = Workbooks.Open(TempFileName)
TempFilePath = wb1.Path
lastRow = wb1.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Set wrdApp = GetObject(, "Word.Application")
If wrdApp Is Nothing Then
Set wrdApp = CreateObject("Word.Application")
blnWeOpenedWord = True
End If
bodyFname = ThisWorkbook.Path & "\Body Text.doc"
For myRow = 2 To lastRow
Application.StatusBar = "Processing record " & myRow - 1 & " of " & lastRow - 1
' Set personnel number, name and email details
strPersNum = wb1.Sheets("Sheet1").Cells(myRow, 1).Value
strEmail = wb1.Sheets("Sheet1").Cells(myRow, 2).Value
strMergeName = wb1.Sheets("Sheet1").Cells(myRow, 12).Value
Set wrdDoc = wrdApp.Documents.Open _
(Filename:=bodyFname, ReadOnly:=True)
Set itm = wrdDoc.MailEnvelope.Item
With itm
.To = strEmail
.Subject = "Metro card renewal"
.ReplyRecipients.Add "joe.bloggs@leeds.gov.uk"
.Attachments.Add TempFilePath & "\letters\" & strMergeName & ".doc"
.Attachments.Add TempFilePath & "\Additional Info.doc"
.Send
ID = .EntryID
End With
Set itm = Nothing
Set itm = outApp.Session.GetItemFromID(ID)
itm.Send
wrdDoc.Close False
If blnWeOpenedWord Then
wrdApp.Quit
End If
Next myRow
Set wrdDoc = Nothing
Set itm = Nothing
Set wrdApp = Nothing
wb1.Close
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
The main problem is that it is very slow and takes around a minute to send 10 emails. Obviously with the volume I am planning to send the code is going to have to run for quite a long time.
Has anyone else got suggestions as to a better way to achieve this sort of thing or how the code could be made more efficient.
Any help appreciated.
Dom