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
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