sparky_n_ames
New Member
- Joined
- May 20, 2010
- Messages
- 15
I previously had this code working using early binding. But do to sharing the workbook across multiple versions of Excel is became non-functional for some users. I am trying to update it to late binding, but for the life of me I cannot get it to run. It keeps throwing ERROR: Sub or Function Not Defined. I don't know what I am missing here. But it is referencing the Set = CreateOjbect("Outlook.Application") as the problem line. It doesn't appear to like the CreateOjbect call. I've tried running with both the Outlook Object Library checked or unchecked, it makes no difference either way. I am trying to get away from using the reference to the object library altogether.
Option Explicit
Function InRange(Range1 As Range, Range2 As Range) As Boolean
' returns True if Range1 is within Range2'
Dim InterSectRange As Range
Set InterSectRange = Application.Intersect(Range1, Range2)
InRange = Not InterSectRange Is Nothing
Set InterSectRange = Nothing
End Function
Sub SendEmail()
Dim OutlookApp As Object 'Outlook.Application
Dim MItem As Object 'Outlook.MailItem
Const OLMAILITEM = 0
Dim rng As Range
Dim rngt As Range
Dim cell As Range
Dim Subj As String
Dim EmailAddr As String
Dim EmailAddr2 As String
Dim Recipient As String
Dim Msg As String
Dim subName As String
Dim ws As Worksheet
Dim LR As Long
Dim x As Long
Set ws = Worksheets("Dashboard")
Set rng = ws.Range("B14:P14")
Set rngt = ws.Range("B9" & ":" & "P" & Rows.Count).End(xlUp)
Set OutlookApp = CreateOjbect("Outlook.Application")
Set MItem = OutlookApp.CreateItem(OLMAILITEM)
LR = ws.Range("B" & Rows.Count).End(xlUp).Offset(-2, 0).Row
i = ActiveCell.Row
'If Application.Intersect(rngt, ActiveCell) Is Nothing Then
If InRange(ActiveCell, Range("B9" & ":P" & LR)) Then
If ws.Range("B" & i).Value <> 0 Then
'Create Outlook object
'Set OutlookApp = New Outlook.Application
'Loop through the rows
For Each cell In Columns("G").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "*@*" Then
EmailAddr1 = EmailAddr1 & ";" & cell.Value
End If
Next
For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "*@*" Then
EmailAddr2 = EmailAddr2 & ";" & cell.Value
End If
'Set OutlookApp = Nothing
'Set MItem = Nothing
Next
With ws
subName = .Range("B" & i).Value & " " & .Range("C" & i).Value
Msg = "Submittal Attached For" & " " & subName
Subj = .Range("B4").Value & " - " & "SUBMITTAL" & " - " & subName
End With
'Create Mail Item and view before sending
'Set MItem = OutlookApp.CreateItem(olMailItem)
With MItem
.To = EmailAddr1
.CC = EmailAddr2
.Subject = Subj
.Body = Msg & vbCrLf
.Display
End With
ws.Range("F" & i).Value = "Email"
End If
End If
End Sub
Option Explicit
Function InRange(Range1 As Range, Range2 As Range) As Boolean
' returns True if Range1 is within Range2'
Dim InterSectRange As Range
Set InterSectRange = Application.Intersect(Range1, Range2)
InRange = Not InterSectRange Is Nothing
Set InterSectRange = Nothing
End Function
Sub SendEmail()
Dim OutlookApp As Object 'Outlook.Application
Dim MItem As Object 'Outlook.MailItem
Const OLMAILITEM = 0
Dim rng As Range
Dim rngt As Range
Dim cell As Range
Dim Subj As String
Dim EmailAddr As String
Dim EmailAddr2 As String
Dim Recipient As String
Dim Msg As String
Dim subName As String
Dim ws As Worksheet
Dim LR As Long
Dim x As Long
Set ws = Worksheets("Dashboard")
Set rng = ws.Range("B14:P14")
Set rngt = ws.Range("B9" & ":" & "P" & Rows.Count).End(xlUp)
Set OutlookApp = CreateOjbect("Outlook.Application")
Set MItem = OutlookApp.CreateItem(OLMAILITEM)
LR = ws.Range("B" & Rows.Count).End(xlUp).Offset(-2, 0).Row
i = ActiveCell.Row
'If Application.Intersect(rngt, ActiveCell) Is Nothing Then
If InRange(ActiveCell, Range("B9" & ":P" & LR)) Then
If ws.Range("B" & i).Value <> 0 Then
'Create Outlook object
'Set OutlookApp = New Outlook.Application
'Loop through the rows
For Each cell In Columns("G").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "*@*" Then
EmailAddr1 = EmailAddr1 & ";" & cell.Value
End If
Next
For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "*@*" Then
EmailAddr2 = EmailAddr2 & ";" & cell.Value
End If
'Set OutlookApp = Nothing
'Set MItem = Nothing
Next
With ws
subName = .Range("B" & i).Value & " " & .Range("C" & i).Value
Msg = "Submittal Attached For" & " " & subName
Subj = .Range("B4").Value & " - " & "SUBMITTAL" & " - " & subName
End With
'Create Mail Item and view before sending
'Set MItem = OutlookApp.CreateItem(olMailItem)
With MItem
.To = EmailAddr1
.CC = EmailAddr2
.Subject = Subj
.Body = Msg & vbCrLf
.Display
End With
ws.Range("F" & i).Value = "Email"
End If
End If
End Sub