G
Guest
Hello,
I am building an VBA macro that will allow me to send Bulk Email, using MS
Outlook, and using an word.doc as the message body. When i create a new
object of words i have no problem, but if i try to create an object of MS
Outlook i get the error 429 if you are familiar with that, "You can pull a
search on google using, "VBA error 429".
Basically it works like this, i need to be able to send out around 1,500 per
day what it does is extract the information from excel spreadsheet cell. I
click on a button in excel then it will dump every value in every cell into
an array. Then it will manipulate a word.doc document by inserting into
bookmarks values from the array. then after one row is processed it will then
send it to outlook to be processes for outgoing mail.
As i stated before the word application has no problem working, but if i try
to initiate outlook then i get the error. I never thought VBA would be so
complicated. If anyone has any suggestions or better way i could go about
this i would surely appreciate it.
~~~~~~~~~~~Below is the code~~~~~~~~~~~~~
Option Explicit
Sub BtnSendEmail_Click()
Dim name, phone, email, time, _
dated As String
Dim confirm, sent As Boolean
Dim status As Boolean
' array = {name, phone, email, date, time, confirm, sent}
Dim rowColArray() As String
Dim row As Double, col As Double
' Debug.Print DBEngine.Version
' Step 1
status = GetApptRec(rowColArray, row, col)
' ' TODO: at end of coding delete this section was used for
' ' TODO: testing purposes
' ' test values to see if it was inputted
' Dim nr, nc As Integer
' For nr = 1 To row
' For nc = 1 To col
' ' MsgBox rowColArray(nr, nc)
' Next nc
' Next nr
'
' MsgBox "There are " & row & " rows " & _
' "and " & col & " Columns", vbOKOnly, _
' "Number of Row and Columns"
' TODO: Call CreateEmailMsg (Create Email Message Module)
Call CreateEmailMsg(rowColArray)
' TODO: Call SendMsg (Send Email Message)
End Sub
Public Function GetApptRec(ByRef rowColArray() As String, _
ByRef row As Double, ByRef col As Double) As Boolean
Dim r, c As Integer
' Dim rowColArray() As String
' Dim row, col As Double
Dim strValue As String
' Determine the total number of rows and columns
col = fLastColWithData()
row = fLastRowWithData()
ReDim rowColArray(row, col)
For r = 1 To row
For c = 1 To col
' fill varaible with the values from the cells
' starting at row 2
strValue = Cells(r, c)
rowColArray(r, c) = strValue
Next c
Next r
GetApptRec = True
End Function ' GetApptRec
Public Function CreateEmailMsg _
(ByRef rowColArray() As String) As String
Dim r As Double, c As Integer, row As Double, col As Integer
Dim name As String, dated As String, timed As String, _
email As String
Dim oGlobalWordApp As Object
Dim oOutlook As Object
' Dim oOutlook As Outlook.Application
Set oGlobalWordApp = CreateObject("Word.Application")
oOutlook = CreateObject("Outlook.Application")
' oOutlook = New Outlook.Application
oGlobalWordApp.Visible = True
row = UBound(rowColArray, 1)
col = UBound(rowColArray, 2)
On Error GoTo errorHandler
' TODO: Call GetWrdDoc (Get Word Document)
Documents.Open ("C:\docs\copy of crm.doc")
' TODO: FrmDtTm (Format Date And Time)
' TODO: Call ManipMsg (Manipulate Message)
' array = {name, phone, email, date, time, confirm, sent}
' bookmark. exists (does it exist?):
For r = 1 To row
' make sure it is ok to send it before sending it
Dim sent, confirmed
sent = rowColArray(r, 7)
confirmed = rowColArray(r, 6)
If confirmed = 1 And sent = 0 Then
For c = 1 To col
name = rowColArray(r, 1)
dated = rowColArray(r, 4)
timed = rowColArray(r, 5)
email = rowColArray(r, 3)
If Word.ActiveDocument.Bookmarks.Exists("Name") = True Then
Word.ActiveDocument.Bookmarks("Name").Select
Word.Selection.TypeText Text:=name
End If
If Word.ActiveDocument.Bookmarks.Exists("Date1") = True Then
Word.ActiveDocument.Bookmarks("Date1").Select
Word.Selection.TypeText Text:=dated
End If
If Word.ActiveDocument.Bookmarks.Exists("Date2") = True Then
Word.ActiveDocument.Bookmarks("Date2").Select
Word.Selection.TypeText Text:=dated
End If
If Word.ActiveDocument.Bookmarks.Exists("Time1") = True Then
Word.ActiveDocument.Bookmarks("Time1").Select
Word.Selection.TypeText Text:=time
End If
If Word.ActiveDocument.Bookmarks.Exists("Time2") = True Then
Word.ActiveDocument.Bookmarks("Time2").Select
Word.Selection.TypeText Text:=time
End If
' TODO: Call SendMsg (Send Email Message)
Call SendMsg(, email)
Next c
End If
Next r
errorHandler:
MsgBox Err.Number & " " & Err.Description
oGlobalWordApp.Quit
oGlobalWordApp = Nothing
End Function ' CreateEmailMsg
Public Sub SendMsg(Optional ByVal msgBody As Object, _
Optional ByVal email As String)
' Dim bStarted As Boolean
' Dim oOutlookApp As Object
Dim oItem As Outlook.MailItem
' On Error Resume Next
On Error GoTo errorHandler
'Get Outlook if it's running
' Set oOutlookApp = GetObject(, "Outlook.Application")
' If Err <> 0 Then
'Outlook wasn't running, start it from code
' Set oOutlookApp = CreateObject("Outlook.Application")
' bStarted = True
' End If
'Create a new mailitem
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem
'Set the recipient for the new email
.To = email
'Set the recipient for a copy
'.CC = "(e-mail address removed)"
'Set the subject
.subject = "Concerning Appointment with Dustin Swiger"
'The content of the document is used as the body for the email
.Body = ActiveDocument.Content
.Send
End With
' If bStarted Then
' 'If we started Outlook from code, then close it
' oOutlookApp.Quit
' End If
errorHandler:
MsgBox Err.Number & " " & Err.Description
'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
End Sub ' SendMsg
Public Sub GetWrdDoc()
End Sub
Public Function FrmDtTm(ByVal time As String, _
ByVal dated As String)
End Function
Public Function ManipMsg(ByVal name As String, _
ByVal msgBody As Object)
' TODO: FindReplaceName (Find & Replace Default String for Name Field)
' TODO: FindReplaceDtTm (Find & Replace Default String for data & time)
End Function
Private Function FindReplaceName(ByVal name As String, _
ByVal msgBody As Object)
End Function
Private Function FindReplaceDtTm(ByVal dated As String, _
ByVal time As String, ByVal msbBody As Object)
End Function
Public Function fLastRowWithData()
Dim excelLastCell
Dim LastRowWithData
Dim row
Set excelLastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
' Determine the last row with data in it(must also copy above para for
' this to work)
LastRowWithData = excelLastCell.row
row = excelLastCell.row
Do While Application.CountA(ActiveSheet.Rows(row)) = 0 And row <> 1
row = row - 1
Loop
LastRowWithData = row ' row number
fLastRowWithData = LastRowWithData
End Function
Public Function fLastColWithData()
Dim excelLastCell
Dim lastColWithData
Dim col
Set excelLastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
' determine the last column with data in it(must also copy the top
' para for this to work)
lastColWithData = excelLastCell.Columns
col = excelLastCell.Column
Do While Application.CountA(ActiveSheet.Columns(col)) = 0 And col <> 1
col = col - 1
Loop
lastColWithData = col ' column number
fLastColWithData = lastColWithData
End Function
'TODO: I need to redo this to make this work with the sendMsg module
Public Sub chkSent(ByRef rowColArray() As String, row, col)
Dim r
Dim c As Integer
' initiate c to total amount of columns in the array
c = UBound(rowColArray, 2)
' array = {name, phone, email, date, time, confirm, sent}
For r = 1 To UBound(rowColArray, 1)
Value = rowcountarray(r, c)
If Value = 1 Then
Dim cs
For cs = 1 To c
rowcountarray(r, cs) = ""
Next cs
End If
Next r
End Sub
'TODO: I need to redo this to make this work with the sendMsg module
Public Sub chkConfirmed(ByRef rowColArray() As String, row, col)
Dim r
Dim c As Integer
' initiate c to total amount of columns in the array
c = UBound(rowColArray, 2)
c = c - 1
' array = {name, phone, email, date, time, confirm, sent}
For r = 1 To UBound(rowColArray, 1)
Value = rowcountarray(r, c)
If Value = 1 Then
Dim cs
For cs = 1 To c
rowcountarray(r, cs) = ""
Next cs
End If
Next r
End Sub
Public Sub SendOutlookMail(ByVal subject As String, ByVal Recipient As _
String, ByVal Message As String)
On Error GoTo errorHandler
Dim oLapp As Object
Dim oItem As Object
oLapp = CreateObject("Outlook.application")
oItem = oLapp.CreateItem(0)
'
With oItem
.subject = subject
.To = Recipient
.Body = Message
' .Send()
End With
'
oLapp = Nothing
oItem = Nothing
'
' reset the resend boolean
resend = False
Exit Sub
errorHandler:
oLapp = Nothing
oItem = Nothing
' reset the resend boolean
resend = False
Exit Sub
End Sub ' SendOutlookMail()
Basically
I am building an VBA macro that will allow me to send Bulk Email, using MS
Outlook, and using an word.doc as the message body. When i create a new
object of words i have no problem, but if i try to create an object of MS
Outlook i get the error 429 if you are familiar with that, "You can pull a
search on google using, "VBA error 429".
Basically it works like this, i need to be able to send out around 1,500 per
day what it does is extract the information from excel spreadsheet cell. I
click on a button in excel then it will dump every value in every cell into
an array. Then it will manipulate a word.doc document by inserting into
bookmarks values from the array. then after one row is processed it will then
send it to outlook to be processes for outgoing mail.
As i stated before the word application has no problem working, but if i try
to initiate outlook then i get the error. I never thought VBA would be so
complicated. If anyone has any suggestions or better way i could go about
this i would surely appreciate it.
~~~~~~~~~~~Below is the code~~~~~~~~~~~~~
Option Explicit
Sub BtnSendEmail_Click()
Dim name, phone, email, time, _
dated As String
Dim confirm, sent As Boolean
Dim status As Boolean
' array = {name, phone, email, date, time, confirm, sent}
Dim rowColArray() As String
Dim row As Double, col As Double
' Debug.Print DBEngine.Version
' Step 1
status = GetApptRec(rowColArray, row, col)
' ' TODO: at end of coding delete this section was used for
' ' TODO: testing purposes
' ' test values to see if it was inputted
' Dim nr, nc As Integer
' For nr = 1 To row
' For nc = 1 To col
' ' MsgBox rowColArray(nr, nc)
' Next nc
' Next nr
'
' MsgBox "There are " & row & " rows " & _
' "and " & col & " Columns", vbOKOnly, _
' "Number of Row and Columns"
' TODO: Call CreateEmailMsg (Create Email Message Module)
Call CreateEmailMsg(rowColArray)
' TODO: Call SendMsg (Send Email Message)
End Sub
Public Function GetApptRec(ByRef rowColArray() As String, _
ByRef row As Double, ByRef col As Double) As Boolean
Dim r, c As Integer
' Dim rowColArray() As String
' Dim row, col As Double
Dim strValue As String
' Determine the total number of rows and columns
col = fLastColWithData()
row = fLastRowWithData()
ReDim rowColArray(row, col)
For r = 1 To row
For c = 1 To col
' fill varaible with the values from the cells
' starting at row 2
strValue = Cells(r, c)
rowColArray(r, c) = strValue
Next c
Next r
GetApptRec = True
End Function ' GetApptRec
Public Function CreateEmailMsg _
(ByRef rowColArray() As String) As String
Dim r As Double, c As Integer, row As Double, col As Integer
Dim name As String, dated As String, timed As String, _
email As String
Dim oGlobalWordApp As Object
Dim oOutlook As Object
' Dim oOutlook As Outlook.Application
Set oGlobalWordApp = CreateObject("Word.Application")
oOutlook = CreateObject("Outlook.Application")
' oOutlook = New Outlook.Application
oGlobalWordApp.Visible = True
row = UBound(rowColArray, 1)
col = UBound(rowColArray, 2)
On Error GoTo errorHandler
' TODO: Call GetWrdDoc (Get Word Document)
Documents.Open ("C:\docs\copy of crm.doc")
' TODO: FrmDtTm (Format Date And Time)
' TODO: Call ManipMsg (Manipulate Message)
' array = {name, phone, email, date, time, confirm, sent}
' bookmark. exists (does it exist?):
For r = 1 To row
' make sure it is ok to send it before sending it
Dim sent, confirmed
sent = rowColArray(r, 7)
confirmed = rowColArray(r, 6)
If confirmed = 1 And sent = 0 Then
For c = 1 To col
name = rowColArray(r, 1)
dated = rowColArray(r, 4)
timed = rowColArray(r, 5)
email = rowColArray(r, 3)
If Word.ActiveDocument.Bookmarks.Exists("Name") = True Then
Word.ActiveDocument.Bookmarks("Name").Select
Word.Selection.TypeText Text:=name
End If
If Word.ActiveDocument.Bookmarks.Exists("Date1") = True Then
Word.ActiveDocument.Bookmarks("Date1").Select
Word.Selection.TypeText Text:=dated
End If
If Word.ActiveDocument.Bookmarks.Exists("Date2") = True Then
Word.ActiveDocument.Bookmarks("Date2").Select
Word.Selection.TypeText Text:=dated
End If
If Word.ActiveDocument.Bookmarks.Exists("Time1") = True Then
Word.ActiveDocument.Bookmarks("Time1").Select
Word.Selection.TypeText Text:=time
End If
If Word.ActiveDocument.Bookmarks.Exists("Time2") = True Then
Word.ActiveDocument.Bookmarks("Time2").Select
Word.Selection.TypeText Text:=time
End If
' TODO: Call SendMsg (Send Email Message)
Call SendMsg(, email)
Next c
End If
Next r
errorHandler:
MsgBox Err.Number & " " & Err.Description
oGlobalWordApp.Quit
oGlobalWordApp = Nothing
End Function ' CreateEmailMsg
Public Sub SendMsg(Optional ByVal msgBody As Object, _
Optional ByVal email As String)
' Dim bStarted As Boolean
' Dim oOutlookApp As Object
Dim oItem As Outlook.MailItem
' On Error Resume Next
On Error GoTo errorHandler
'Get Outlook if it's running
' Set oOutlookApp = GetObject(, "Outlook.Application")
' If Err <> 0 Then
'Outlook wasn't running, start it from code
' Set oOutlookApp = CreateObject("Outlook.Application")
' bStarted = True
' End If
'Create a new mailitem
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem
'Set the recipient for the new email
.To = email
'Set the recipient for a copy
'.CC = "(e-mail address removed)"
'Set the subject
.subject = "Concerning Appointment with Dustin Swiger"
'The content of the document is used as the body for the email
.Body = ActiveDocument.Content
.Send
End With
' If bStarted Then
' 'If we started Outlook from code, then close it
' oOutlookApp.Quit
' End If
errorHandler:
MsgBox Err.Number & " " & Err.Description
'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
End Sub ' SendMsg
Public Sub GetWrdDoc()
End Sub
Public Function FrmDtTm(ByVal time As String, _
ByVal dated As String)
End Function
Public Function ManipMsg(ByVal name As String, _
ByVal msgBody As Object)
' TODO: FindReplaceName (Find & Replace Default String for Name Field)
' TODO: FindReplaceDtTm (Find & Replace Default String for data & time)
End Function
Private Function FindReplaceName(ByVal name As String, _
ByVal msgBody As Object)
End Function
Private Function FindReplaceDtTm(ByVal dated As String, _
ByVal time As String, ByVal msbBody As Object)
End Function
Public Function fLastRowWithData()
Dim excelLastCell
Dim LastRowWithData
Dim row
Set excelLastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
' Determine the last row with data in it(must also copy above para for
' this to work)
LastRowWithData = excelLastCell.row
row = excelLastCell.row
Do While Application.CountA(ActiveSheet.Rows(row)) = 0 And row <> 1
row = row - 1
Loop
LastRowWithData = row ' row number
fLastRowWithData = LastRowWithData
End Function
Public Function fLastColWithData()
Dim excelLastCell
Dim lastColWithData
Dim col
Set excelLastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
' determine the last column with data in it(must also copy the top
' para for this to work)
lastColWithData = excelLastCell.Columns
col = excelLastCell.Column
Do While Application.CountA(ActiveSheet.Columns(col)) = 0 And col <> 1
col = col - 1
Loop
lastColWithData = col ' column number
fLastColWithData = lastColWithData
End Function
'TODO: I need to redo this to make this work with the sendMsg module
Public Sub chkSent(ByRef rowColArray() As String, row, col)
Dim r
Dim c As Integer
' initiate c to total amount of columns in the array
c = UBound(rowColArray, 2)
' array = {name, phone, email, date, time, confirm, sent}
For r = 1 To UBound(rowColArray, 1)
Value = rowcountarray(r, c)
If Value = 1 Then
Dim cs
For cs = 1 To c
rowcountarray(r, cs) = ""
Next cs
End If
Next r
End Sub
'TODO: I need to redo this to make this work with the sendMsg module
Public Sub chkConfirmed(ByRef rowColArray() As String, row, col)
Dim r
Dim c As Integer
' initiate c to total amount of columns in the array
c = UBound(rowColArray, 2)
c = c - 1
' array = {name, phone, email, date, time, confirm, sent}
For r = 1 To UBound(rowColArray, 1)
Value = rowcountarray(r, c)
If Value = 1 Then
Dim cs
For cs = 1 To c
rowcountarray(r, cs) = ""
Next cs
End If
Next r
End Sub
Public Sub SendOutlookMail(ByVal subject As String, ByVal Recipient As _
String, ByVal Message As String)
On Error GoTo errorHandler
Dim oLapp As Object
Dim oItem As Object
oLapp = CreateObject("Outlook.application")
oItem = oLapp.CreateItem(0)
'
With oItem
.subject = subject
.To = Recipient
.Body = Message
' .Send()
End With
'
oLapp = Nothing
oItem = Nothing
'
' reset the resend boolean
resend = False
Exit Sub
errorHandler:
oLapp = Nothing
oItem = Nothing
' reset the resend boolean
resend = False
Exit Sub
End Sub ' SendOutlookMail()
Basically