отправить все «видимые» черновики с помощью VBA в Outlook 2007

Question

Как автоматически отправлять несколько (в настоящее время видимых) элементов проекта с помощью VBA? Пожалуйста, помогите, спасибо.

Редактировать: Это трудный случай, ни один из предметов еще не находится в папке с черновиками. Это созданные электронные письма, которые находятся на вашем экране, ожидая отправки.

Edit2: nvm, это все равно не поможет. Мой скрипт создает около 500 электронных писем и отображает первые 100 причин ошибки в памяти. Я решил автоматически отправлять их без отображения (он разбивает макет таким образом, но пока это мой единственный вариант.)

Answer 1

Как раз так случилось, что я столкнулся с тем же вопросом раньше и с удобным кодом. Если вы еще не находитесь в Outlook, вам нужно добавить ссылку в VBA IDE, Tools ---> References ... и установить флажок рядом с «Библиотека объектов Microsoft Outlook 14.0».

Dim oFolder As Folder 
Dim oNS As NameSpace 
Dim olMail As MailItem 

If (MsgBox("Are you sure you want to send ALL EMAILS IN YOUR DRAFTS FOLDER?", vbYesNo + vbCritical, "WARNING: THIS WILL SEND ALL DRAFTS")) = vbYes Then 
    Set oNS = Outlook.Application.GetNamespace("MAPI") 

    Set oFolder = oNS.GetDefaultFolder(olFolderDrafts) 

    For i = 1 To oFolder.Items.Count 
     oFolder.Items(1).Send 
    Next 
End If 

Set oNS = Nothing 

Answer 2

Вот несколько кодов. Замените Your Name в myFolders("Mailbox - Your Name") с вашим фактическим именем, которое отображается в почтовом ящике.

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 

'Send all items in the "Drafts" folder that have a "To" address filled in. 

'Setup Outlook 
Set myOutlook = Outlook.Application 
Set myNameSpace = myOutlook.GetNamespace("MAPI") 
Set myFolders = myNameSpace.Folders 

'Set Draft Folder. 
Set myDraftsFolder = myFolders("Mailbox - Your Name").Folders("Drafts") 

'Loop through all Draft Items 
For lDraftItem = myDraftsFolder.Items.Count To 1 Step -1 

'Check for "To" address and only send if "To" is filled in. 
If Len(Trim(myDraftsFolder.Items.Item(lDraftItem).To)) > 0 Then 

'Send Item 
myDraftsFolder.Items.Item(lDraftItem).Send 

End If 

Next lDraftItem 

'Clean-up 
Set myDraftsFolder = Nothing 
Set myNameSpace = Nothing 
Set myOutlook = Nothing 

End Sub 

Исходный код адаптировано из this Question's ответа.