PDA

View Full Version : How to bypass security warning sending emails from outlook using Excel VBA Code sampl



Blade Hunter
11-24-2014, 03:06 PM
OK so this will not be relevant to everyone, only those who are using a closed server where the email is not used by anyone else except their code.

OK, So that was super convoluted but I have now got this working, no addins or anything.

Test code from Excel to create a draft (no security warning on draft creation):



Private Sub EmailCopy()
Dim oApp, oMail As Object
Dim WB As Workbook
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
With oMail
.To = "MyEmail@email.com"
.Subject = "Test"
.Body = "Test"
.Display
.Save
End With
Set oMail = Nothing
Set oApp = Nothing
End Sub


Code in outlook ThisOutlookSession:



Private WithEvents Items As Outlook.Items


Private Sub Application_Startup()
Dim objNS As Outlook.NameSpace
Set objNS = GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderDrafts).Items
Set objNS = Nothing
End Sub


Private Sub Items_ItemAdd(ByVal Item As Object)
EmailOutlookDraftsMessages
End Sub


Public Sub EmailOutlookDraftsMessages()
Dim lDraftItem As Long
Dim myOutlook As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolders As Outlook.Folders
Dim myDraftsFolder As Outlook.MAPIFolder
Set myOutlook = Outlook.Application
Set myNameSpace = myOutlook.GetNamespace("MAPI")
Set myFolders = myNameSpace.Folders
Set myDraftsFolder = myFolders("email@email.com").Folders("Drafts")
For lDraftItem = myDraftsFolder.Items.Count To 1 Step -1
If Len(Trim(myDraftsFolder.Items.Item(lDraftItem).To)) > 0 Then
myDraftsFolder.Items.Item(lDraftItem).Send
End If
Next lDraftItem
Set myDraftsFolder = Nothing
Set myNameSpace = Nothing
Set myOutlook = Nothing
End Sub


Once you put this in outlook you have to close and reopen it to set it monitoring for event changes on the Drafts folder.

Now be warned, if you create an email and save it (draft) IT WILL AUTO SEND, this is fine for me because this is on my VM that only I have access to and the only emails created are done from my Excel code.

Appreciate any comments if there are any.

Cheers

Dan

westconn1
11-25-2014, 01:38 AM
to make it more general pupose, you could set some property, or category of the daft message, then match that criteria before sending

are the messages automatically moved from the drafts folder when sent?

snb
11-25-2014, 01:58 AM
Nice Idea !
Which version of Office do you use ?

What is the effect if you use:


Private Sub M_snb()
with CreateObject("Outlook.Application")
with .CreateItem(0)
.To = "MyEmail@email.com"
.Subject = "Test"
.Body = "Test"
.Save
End With

for each it in .GetNamespace("MAPI").GetDefaultFolder(olFolderDrafts).Items
it.send
next
end with
End Sub

Blade Hunter
11-25-2014, 02:15 PM
Invalid procedure or argument on the for each line.

Even if we resolve that I guarantee it will prompt the security box on .send :)

Blade Hunter
11-25-2014, 02:16 PM
to make it more general pupose, you could set some property, or category of the daft message, then match that criteria before sending

are the messages automatically moved from the drafts folder when sent?

That is an awesome idea, I will update and post back :)

Blade Hunter
11-25-2014, 02:27 PM
Which version of Office do you use ?

2010 64bit. I imagine it would be the same for most versions though :)

Kenneth Hobs
11-25-2014, 03:17 PM
Have you looked into using CDO?

Blade Hunter
11-25-2014, 03:22 PM
Have you looked into using CDO?

Yeah, I don't have access to the smtp server unfortunately.

snb
11-26-2014, 07:46 AM
Still erroring ?


Private Sub M_snb()
with CreateObject("Outlook.Application")
with .CreateItem(0)
.To = "MyEmail@email.com"
.Subject = "Test"
.Body = "Test"
.Save
End With

for each it in .GetNamespace("MAPI").GetDefaultFolder(16).Items
it.send
next
end with
End Sub

Blade Hunter
11-26-2014, 02:03 PM
Gives me the security prompt on .send

snb
11-26-2014, 02:17 PM
If outlook is already open and you use:


Private Sub M_snb()
with GetObject(,"Outlook.Application")
with .CreateItem(0)
.To = "MyEmail@email.com"
.Subject = "Test"
.Body = "Test"
.Save
End With

for each it in .GetNamespace("MAPI").GetDefaultFolder(16).Items
it.send
next
end with
End Sub

Blade Hunter
11-26-2014, 03:31 PM
Same issue, security prompt on .send

Outlook intercepts code trying to send an email if you don't have an up to date virus scanner from the MS list of approved virus scanners. It's a security thing from MS. I can't see any way without installing something that I will be able to do this other than the way I have done it. There is maybe sendkeys but I hate using sendkeys with a passion.

My method works for now and once I put in the fix suggested above I think it will be pretty sweet :).

snb
11-26-2014, 03:55 PM
A simple way to prevent this is to use Outlook 2000 to send emails.

There's also the clickYes program that prevents unnecessary alerts.

Blade Hunter
11-26-2014, 04:11 PM
I can't install 3rd party apps on the machine and I can't change the email program unfortunately. I am no longer in IT so I have very little control :(