Wrox Programmer Forums

Need to download code?

View our list of code downloads.

Go Back   Wrox Programmer Forums > Microsoft Office > Excel VBA > Excel VBA
Password Reminder
Register
| FAQ | Members List | Calendar | Search | Today's Posts | Mark Forums Read
Excel VBA Discuss using VBA for Excel programming.
Welcome to the p2p.wrox.com Forums.

You are currently viewing the Excel VBA section of the Wrox Programmer to Programmer discussions. This is a community of tens of thousands of software programmers and website developers including Wrox book authors and readers. As a guest, you can read any forum posting. By joining today you can post your own programming questions, respond to other developers’ questions, and eliminate the ads that are displayed to guests. Registration is fast, simple and absolutely free .
DRM-free e-books 300x50
Reply
 
Thread Tools Search this Thread Display Modes
  #1 (permalink)  
Old March 10th, 2006, 05:11 AM
Registered User
 
Join Date: Mar 2006
Location: Melrose, Minnesota
Posts: 2
Thanks: 0
Thanked 0 Times in 0 Posts
Send a message via MSN to Willie Johnson Jr
Default VBA Excel, outlook createobject

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 = "recipient2@mail.com"
            '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()

Digit Solver
Reply With Quote
Reply


Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is Off
HTML code is Off
Trackbacks are Off
Pingbacks are On
Refbacks are Off


Similar Threads
Thread Thread Starter Forum Replies Last Post
vba work outlook with excel sheet qunatphil Excel VBA 1 April 16th, 2008 12:30 PM
VBA in excel and outlook dlindamood2000 Excel VBA 19 December 7th, 2006 10:16 AM
ASP & Excel - Permission denied: 'CreateObject' shamigc Classic ASP Components 1 May 9th, 2006 06:58 PM
error when createobject excel.application vovo Classic ASP Professional 0 February 3rd, 2005 12:29 AM
Server.CreateObject("Outlook.Application") Dave Sell Classic ASP Professional 1 September 4th, 2004 01:44 PM



All times are GMT -4. The time now is 05:10 PM.


Powered by vBulletin®
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.
© 2013 John Wiley & Sons, Inc.