Opening Outlook through VBA crashes for unknown reason - vba

I am using this code to open a list of email-adresses directly in outlook. The email list consists of roughly 100 email-adresses.
If I let the code run for only parts of the list it works just fine for all different parts, but as soon as I let it run for the whole list I get a runtime error '5. Does anyone have a suggestion what causes this problem? I would be very thankful.
If ActiveWorkbook.Worksheets("Output").Range("I10").Value = "Wahr" Then
Dim strAddress As String
Dim lastCell As Long
Dim i As Integer
Worksheets("Output").Activate
lastCell = Range("B" & Rows.Count).End(xlUp).Row
For i = 13 To lastCell
If strAddress = "" Then
strAddress = Cells(i, 2).Value
Else
strAddress = strAddress & ";" & Cells(i, 2).Value
End If
Next i
ActiveWorkbook.FollowHyperlink Address:="mailto:" & strAddress 'this line gives me the error
End If
EDIT: The weird thing is, that it doesnt really matter which "groups" I choose. It seems to be a question of how many adresses I pick.

Not sure what you mean by I am using this code to open a list of email-adresses directly in outlook.
The code appears to create a single blank email with each cell in B13 downwards providing the email addresses?
Maybe this code below will help.
It uses late binding (so no references needed) to get a reference to Outlook, it then creates an email and adds the email addresses to it as recipients before finally displaying it. You can change the .Display to .Send to send the email rather than just display it.
Public Sub Test()
Dim oOL As Object
Dim oMail As Object
Dim rLastCell As Range
Dim rAddRange As Range
Dim rCell As Range
Set oOL = CreateOL
With ThisWorkbook.Worksheets("Output")
Set rLastCell = .Cells(.Rows.Count, 2).End(xlUp)
Set rAddRange = .Range("B13", rLastCell)
End With
Set oMail = oOL.CreateItem(0)
With oMail
For Each rCell In rAddRange
.Recipients.Add rCell.Value
Next rCell
.Display
End With
End Sub
Public Function CreateOL() As Object
Dim oTmpOL As Object
On Error GoTo ERROR_HANDLER
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Creating an instance of Outlook is different from Excel. '
'There can only be a single instance of Outlook running, '
'so CreateObject will GetObject if it already exists. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set oTmpOL = CreateObject("Outlook.Application")
Set CreateOL = oTmpOL
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure CreateOL."
Err.Clear
End Select
End Function

Related

Sending Email based on name in a cell

I have looked through multiple posts to send an email if a value in a range of cells changes and adapted the code I found in those posts to suit my needs, but for some reason the email is not being sent when the value in any cell of the range defined changes, and I am a little lost at why. Any guidance is greatly appreciated. Please see code below (please note that for confidentiality purposes the emails and names are fake).
Private Sub Workbook_Change(ByVal Target As Range)
' Uses early binding
' Requires a reference to the Outlook Object Library
Dim RgSel As Range, RgCell As Range
Dim OutlookApp As Object, MItem As Object
Dim Subj As String, EmailAddr As String, Recipient As String
Dim CustName As String, Msg As String
Dim pEmail As String
On Error GoTo NX
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set RgCell = Range("C2:C100")
Set RgSel = Intersect(Target, RgCell)
If Not RgSel Is Nothing Then
Set OutlookApp = CreateObject("Outlook.Application")
Set MItem = OutlookApp.CreateItem(0)
For Each cell In RgCell
If cell.Value = "Bob" Then 'Fake Name for posting question
pEmail = "BobT#SomethingBlahBlahBlah.com" 'Fake email address used for posting question
CustName = cell.Offset(0, -1).Value
Subj = "***NEW ITEM ASSIGNED***" & " - " & UCase(CustName)
Recipient = "Bob T. Builder" 'Fake name for posting question
EmailAddr = pEmail
' Compose Message
Msg = "Dear, " & Recipient & vbCrLf & vbCrLf
Msg = Msg & "I have assigned " & CustName & "'s" & " item to you." & vbCrLf
Msg = Msg & "Please review the information in their customer folder in the L: Drive." & vbCrLf & vbCrLf
Msg = Msg & "Sincerely," & vbCrLf & vbCrLf & vbCrLf
Msg = Msg & "Bob's Boss" & vbCrLf 'Fake name for posting question
Msg = Msg & "Vice President"
' Create Mail Item and send
With MItem
.to = EmailAddr
.Subject = Subj
.body = Msg
.Save 'This will change to .send after testing is complete
End With
Set RgSel = Nothing
Set OutlookApp = Nothing
Set MItem = Nothing
End If
Next cell
Application.DisplayAlerts = True
Application.ScreenUpdating = True
NX:
Resume Next
End Sub
I think you've intended to use the Worksheet_Change event but have Private Sub Workbook_Change... instead.
Additional issues:
For Each cell In RgCell should probably be For Each cell in RgSel, or For Each cell in Target - otherwise the code runs through each cell in C2:C100, and not just the cell(s) changed, or Target.
There is no need to Set RgSel = Nothing
With Set MItem = OutlookApp.CreateItem(0), you create an email message before you've checked If cell.Value = "Bob". Move this line within the If statement.
Set OutlookApp = Nothing should be outside the For Each loop, i.e. it should be done after you've finished looping.
On Error GoTo NX, and then NX: Resume Next, is equivalent to On Error Resume Next, which doesn't handle any errors, but rather ignores them.
You may be missing a closing End If, or it is not included in this snippet.

How can make Sheet to activate in VBA from a variable? (A cell particularly)

I am actually quite new to VBA but I am doing some coding to streamline my office work. I understand this would be some amateur level questions to most of you but I tried to google for quite a while and I do not find satisfactory answer.
I have an excel write up that based on the inputted parameters, It should ultimately refer to the correct sheet -> copy the selected cells -> Generate an e-Mail with the body pasting the copied cells along with an attachment
I can do most of the parts, just that I cannot reference the "Correct Sheet" as a variable in my codes. Please shed some lights on for me. Thank you.
Here are most of the codes, the rest are irrelevant and too clumsy to paste all I guess.
Sub GenerateEmail()
Dim olApp As Object
Dim olMailItm As Object
Dim iCounter As Integer
Dim Dest As Variant
Dim SDest As String
Dim StrAtt1 As String
Dim rng As Range
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("test").Range("A1:Q500").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set olApp = CreateObject("Outlook.Application")
Set olMailItm = olApp.CreateItem(0)
On Error Resume Next
With olMailItm
SDest = ""
StrAtt1 = ThisWorkbook.Path & "\PDF\" & Sheets("Email_Generator").Range("B16")
.To = Worksheets("Email_Generator").Range("B14")
.CC = "Myself"
.BCC = ""
.Subject = Worksheets("Email_Generator").Range("B18")
.HTMLBody = RangetoHTML(rng)
.attachments.Add StrAtt1
.Display
End With
Set olMailItm = Nothing
Set olApp = Nothing
End Sub
Specifically, I would like this code "Sheets("test") as a Cell in Sheet "Test" that is a variable based on the paramters I have inputted in my excel so that this code will reference to the correct worksheet
Set rng = Sheets("test").Range("A1:Q500").SpecialCells(xlCellTypeVisible)
But when I identify the sheet as a named sheet e.g. Sheets("Email1"), it perfectly works, just that it cannot become a variable.
I hope this post is not too long to read because I tried to be as specific as possible. Thank you to all who reads this and tries to help. I really appreciate it.
This function to return the worksheet name selected by the user from an InputBox. If the user cancels or enters an invalid number then the function returns a zero length string.
Sub TestFunction()
Dim SheetName As String
Dim rng As Range
SheetName = getSheetNameFromInputBox
If Len(SheetName) = 0 Then
MsgBox Prompt:="Try Again", Title:="Invalid Sheet"
Exit Sub
End If
Set rng = Sheets(SheetName).Range("A1:Q500").SpecialCells(xlCellTypeVisible)
MsgBox rng.Address(External:=True)
End Sub
Function getSheetNameFromInputBox() As String
Dim ws As Worksheet
Dim Prompt As String
Dim result
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Sheet3" Then
Prompt = Prompt & ws.Index & ") " & ws.Name & vbCrLf
End If
Next
result = InputBox(Prompt:=Prompt, Title:="Enter the Worksheet number", Default:=1)
On Error Resume Next
If IsNumeric(result) Then getSheetNameFromInputBox = Worksheets(CInt(result)).Name
On Error GoTo 0
End Function

Send instant message on Office Communicator using Excel VBA

I want to send instant message using Office Communicator and Excel VBA. I use an excel sheet containing a list of Email IDs.
**A B C**
Serial No Name Email
1 abc abc.abc#abc.com
2 xyz xyz.xyz#xyz.com
3 pqr pqr.pqr#pqr.com
I wrote the below code to send message. But it is not working. I have enabled Communicator reference in VBA.
Sub sendIM()
Dim msgr As CommunicatorAPI.IMessengerConversationWndAdvanced
Dim ToUser As String
Dim message As String
Application.ScreenUpdating = True
For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeConstants)
On Error Resume Next
If cell.Value Like "?*#?*.?*" Then
ToUser = Chr(34) & cell.Value & Chr(34)
'MsgBox ToUser
message = "Hi " & Cells(cell.Row, "B").Value _
& vbNewLine & vbNewLine & _
"HOW ARE YOU"
Set msgr = Messenger.InstantMessage(ToUser)
msgr.SendText (message)
End If
Next cell
Application.ScreenUpdating = True
End Sub
For a single email id, it is working. I use the below mentioned code to send single message.
Sub sendIM()
Dim msgr As CommunicatorAPI.IMessengerConversationWndAdvanced
Dim ToUser As String
Dim message As String
Application.ScreenUpdating = True
ToUser = "abc.abc#abc.com"
message = "hai"
On Error Resume Next
Set msgr = Messenger.InstantMessage(ToUser)
msgr.SendText (message)
Application.ScreenUpdating = True
End Sub
But I need to loop through the sheet so that the message is sending to everyone. What changes I have to make this work ?
Note: The Email Ids here I mentioned is not real.
I have never worked with Office Communicator but since you are saying that the second code works then try this. (UNTESTED)
Sub SendIM()
Dim msgr As CommunicatorAPI.IMessengerConversationWndAdvanced
Dim ToUser As String, message As String
Dim aCell As Range
Dim ws As Worksheet
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Application.ScreenUpdating = False
With ws
'~~> Why On Error Resume next? If you know what error you are going to get
'~~> Then simply handle it. For the time being, I am skipping the record
'~~> Also keeping it out of the loop
On Error GoTo SkipIT
For Each aCell In .Columns("C").Cells.SpecialCells(xlCellTypeConstants)
If aCell.Value Like "?*#?*.?*" Then
ToUser = aCell.Value '<~~ Don't need quotes
message = "Hi " & .Cells(aCell.Row, "B").Value _
& vbNewLine & vbNewLine & _
"HOW ARE YOU"
Set msgr = Messenger.InstantMessage(ToUser)
msgr.SendText (message)
DoEvents '<~~ Let excel send the message. Give it time
End If
SkipIT:
Next aCell
End With
Application.ScreenUpdating = True
End Sub
EDIT
An improved version. Takes care of error handling
Sub sendIM()
Dim msgr As CommunicatorAPI.IMessengerConversationWndAdvanced
Dim ToUser As String, message As String
Dim aCell As Range
Dim ws As Worksheet
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Application.ScreenUpdating = False
With ws
For Each aCell In .Columns("C").Cells.SpecialCells(xlCellTypeConstants)
If aCell.Value Like "?*#?*.?*" Then
ToUser = aCell.Value '<~~ Don't need quotes
message = "Hi " & .Cells(aCell.Row, "B").Value _
& vbNewLine & vbNewLine & _
"HOW ARE YOU"
'~~> Only place I can think an error could happen
On Error Resume Next
Set msgr = Messenger.InstantMessage(ToUser)
'~~> Check if the object is created
If Not msgr Is Nothing Then msgr.SendText (message)
Set msgr = Nothing
On Error GoTo 0
DoEvents '<~~ Let excel send the message. Give it time
End If
Next aCell
End With
Application.ScreenUpdating = True
End Sub

invalid procedure call or argument when calling function in excel vba

There's a command button as a trigger to send email to customers when you click on it. It will call the function first like this:
Private Sub Lotus2_Click()
ThisWorkbook.Send_Unformatted_Rangedata (2)
End Sub
Then there are two parts for the function in another sheet waiting to be called, I couldn't debug this since whenever I want to, the system only show me the line which calls the function. The problem is I know there's something wrong about calling function, but I'm not sure which part of the function goes wrong. I'm sorry as the function part is a bit tedious, as you can see below. I will truly appreciate a lot for any advice given, thanks.
*********UPDATE*******************
Hi, I just found something wrong with this line with the error message ofRun time error -2147417851 (80010105) Automation error The server threw an exception:
Set noDocument = noDatabase.CreateDocument
But I don't see anything wrong with it. Any help will be appreciated much.
Sub Send_Unformatted_Rangedata(i As Integer)
Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim vaRecipient As Variant
Dim rnBody As Range
Dim Data As DataObject
Dim rngGen As Range
Dim rngApp As Range
Dim rngspc As Range
Dim stSubject As String
stSubject = "E-Mail For Approval for " + (Sheets("Summary").Cells(i, "A").Value) + " for the Project " + Replace(ActiveWorkbook.Name, ".xls", "")
'Const stMsg As String = "Data as part of the e-mail's body."
'Const stPrompt As String = "Please select the range:"
'This is one technique to send an e-mail to many recipients but for larger
'number of recipients it's more convenient to read the recipient-list from
'a range in the workbook.
vaRecipient = VBA.Array(Sheets("Summary").Cells(i, "U").Value, Sheets("Summary").Cells(i, "V").Value)
On Error Resume Next
'Set rnBody = Application.InputBox(Prompt:=stPrompt, _
Default:=Selection.Address, Type:=8)
'The user canceled the operation.
'If rnBody Is Nothing Then Exit Sub
Set rngGen = Nothing
Set rngApp = Nothing
Set rngspc = Nothing
Set rngGen = Sheets("General Overview").Range("A1:C30").SpecialCells(xlCellTypeVisible)
Set rngApp = Sheets("Application").Range("A1:E13").SpecialCells(xlCellTypeVisible)
Set rngspc = Sheets(Sheets("Summary").Cells(i, "P").Value).Range(Sheets("Summary").Cells(i, "Q").Value).SpecialCells(xlCellTypeVisible)
Set rngspc = Union(rngspc, Sheets(Sheets("Summary").Cells(i, "P").Value).Range(Sheets("Summary").Cells(i, "R").Value).SpecialCells(xlCellTypeVisible))
On Error GoTo 0
If rngGen Is Nothing And rngApp Is Nothing And rngspc Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
'Instantiate Lotus Notes COM's objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
'Make sure Lotus Notes is open and available.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Create the document for the e-mail.
Set noDocument = noDatabase.CreateDocument
'Copy the selected range into memory.
rngGen.Copy
rngApp.Copy
rngspc.Copy
'Retrieve the data from then copied range.
Set Data = New DataObject
Data.GetFromClipboard
'Add data to the mainproperties of the e-mail's document.
With noDocument
.Form = "Memo"
.SendTo = vaRecipient
.Subject = stSubject
'Retrieve the data from the clipboard.
.Body = Data.GetText & " " & stMsg
.SaveMessageOnSend = True
End With
'Send the e-mail.
With noDocument
.PostedDate = Now()
.send 0, vaRecipient
End With
'Release objects from memory.
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
'Activate Excel for the user.
AppActivate "Microsoft Excel"
'Empty the clipboard.
Application.CutCopyMode = False
MsgBox "The e-mail has successfully been created and distributed.", vbInformation
End Sub
Then there are two parts for the function in another sheet
If the procedures are located in a sheet module, then you should call them with:
Sheet_Object_Name.Send_Unformatted_Rangedata (2)
Second option is to move procedures to ThisWorkbook module, and your code:
ThisWorkbook.Send_Unformatted_Rangedata (2)
should work fine.
Another solution is to add a separate module to your project (using Insert->Module), move procedures there, and then you can call those procedures from other modules using simply:
Send_Unformatted_Rangedata (2)

Issue with reading data from specific cells in Excel VBA

I'm attempting to send an email containing an Excel workbook from within the document using the built in VB macros. There is data in one of the sheets, which are relevant to sending the email (Subject, recipient etc). I am trying to access these using the Sheets object like so
Sub Button1_Click()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim cell As Object
Dim count As Integer
count = 0
For Each cell In Selection
count = count + 1
Next cell
If count <> 1 Then
MsgBox ("You must select exactly one cell, which shall be the e-mail address of the recipient")
Wscript.Quit
Else
recipient = ActiveCell.Value
End If
On Error Resume Next
With OutMail
.To = recipient
.CC = ""
.BCC = ""
.SentOnBehalfOfName = This.Sheets("MailContent").Range("A2").Value
.Subject = This.Sheets("MailContent").Range("A4").Value
.Body = This.Sheets("MailContent").Range("A6").Value & vbNewLine & This.Sheets("MailContent").Range("A7") & vbNewLine & vbNewLine & "Næste gang senest den " + This.Sheets("MailContent").Range("A10") & vbNewLine & vbNewLine & This.Sheets("MailContent").Range("A8")
.Attachments.Add ActiveWorkbook.Name
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I've also been able to replicate the same error with this small snippet
Sub Button1_Click()
Dim subjectCell As Range
subjectCell = This.Sheets("MailContent").Range("A2")
MsgBox (subjectCell.Value)
End Sub
I've tried using WorkSheets, Sheets, ActiveWorkbook to access the cells, but I'm sure it's just a problem of how I assign the data, since I'm not used to languages with syntax like VB. Any help is much appreciated, and if you need more info leave me a comment.
You need to use the 'Set' keyword to assign to a range.
Set subjectCell = ThisWorkbook.Sheets("MailContent").Range("A2")
This still catches me out on an irritatingly regular basis.