PDA

View Full Version : Moving Sent Items To Another ARCHIVE Sent Folder.



harky
08-14-2019, 10:37 PM
I had this code which work pretty well from this user here.
https://www.mrexcel.com/forum/excel-questions/1103982-vba-send-emails-attachment-base-path-folder-4.html

But need someone to help on add-on.
Possible to move send email to ARCHIVE Folder once email sent on outlook?

ARCHIVE Folder: 2019_ARCHIVE
Subfolder: SendFolder




Sub SendEmail()
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long, d As Long
Dim wks As Worksheet, pf As String, wPath As String, wFile As Variant, wPattern As String
Dim num_err As Variant, sErr As Boolean


'START of confirmation message box'
response = MsgBox("Start sending email?", vbYesNo)
If response = vbNo Then
MsgBox ("Macro Canceled!")
Exit Sub
End If
'END of confirmation message box'

Set Mail_Object = CreateObject("Outlook.Application")
Set wks = Worksheets("SendEmail")
lr = wks.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lr
sErr = False
With Mail_Object.CreateItem(o)
.to = wks.Range("B" & i).Value
.cc = wks.Range("C" & i).Value
.Subject = wks.Range("D" & i).Value
.Body = wks.Range("E" & i).Value & vbNewLine & _
wks.Range("F" & i).Value & vbNewLine & _
wks.Range("G" & i).Value

pf = wks.Range("H" & i).Value
d = InStrRev(pf, "\")
wPath = Left(pf, d)
wPattern = Mid(pf, d + 1)
If wPath <> "" Then
If wPattern = "" Then wPattern = "*.*"
'If Right(wPath, 1) <> "\" Then wPath = wPath & "\"
If Dir(wPath, vbDirectory) <> "" Then
wFile = Dir(wPath & wPattern)
On Error Resume Next
If wFile <> "" Then
Do While wFile <> ""
.Attachments.Add wPath & wFile
num_error = Err.Number
If num_error <> 0 Then
wks.Range("I" & i).Value = "ERROR Exceed Size"
sErr = True
End If
wFile = Dir()
Loop
Else
wks.Range("I" & i).Value = "ERROR Wrong File URL"
sErr = True
End If
On Error GoTo 0
Else
wks.Range("I" & i).Value = "ERROR Wrong Folder URL"
sErr = True
End If
End If
If sErr = False Then
.Send
'.display 'disable display and enable send to send automatically
num_error = Err.Number
If num_error <> 0 Then
wks.Range("I" & i).Value = Err.Description
Else
wks.Range("I" & i).Value = "Email Send!"
End If
End If
Application.Wait (Now + TimeValue("0:00:07")) 'Pausing an application for 3s, before next email
End With
Next i
MsgBox "E-mail successfully sent", 64
Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub

snb
08-15-2019, 01:12 AM
See: https://www.snb-vba.eu/VBA_Outlook_external_en.html#L_5.2.2

harky
08-15-2019, 01:27 AM
See: https://www.snb-vba.eu/VBA_Outlook_external_en.html#L_5.2.2

how do i add this into script in excel?




c00 = "controle"

With CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(5).Items(c00).Move .GetDefaultFolder(3)
End With
End Sub

harky
08-15-2019, 01:54 AM
try this in outlook 2019
got error..


See: https://www.snb-vba.eu/VBA_Outlook_external_en.html#L_5.2.2

Kenneth Hobs
08-15-2019, 07:28 PM
What is your account type? The usual method probably works only on pop3. IMAP is a problem and Exchange has security restrictions. As such, it is probably best to run a separate macro sometime to move the emails from Sent folder to a preferred folder.

You cross-posted to: https://www.ozgrid.com/forum/forum/help-forums/excel-vba-macros/1221713-moving-sent-items-to-another-archive-sent-folder

The "error" to your site snb is:

Your connection is not private

Attackers might be trying to steal your information fromwww.snb-vba.eu (for example, passwords, messages, or credit cards). Learn more
(http://www.vbaexpress.com/forum/chrome-error://chromewebdata/#)
NET::ERR_CERT_COMMON_NAME_INVALID

harky
08-15-2019, 08:17 PM
Hi.
It ok. I got another code which work on Outlook BUT had some issue here is... the code wont auto run every 1 sec
or auto run.


Sub MoveSentItem()


On Error Resume Next
Dim objFolder As Outlook.MAPIFolder, olFolderSentMail As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem


Set objNS = Application.GetNamespace("MAPI")
Set olFolderSentMail = objNS.GetDefaultFolder(olFolderSentMail)
'For the "Item" portion, I used the name of the folder exactly as it appear in the ToolTip when I hover over it.
Set objFolder = objNS.Folders.Item("SENT_ARCHIVE").Folders.Item("Sent Items")


'Assume this is a mail folder


If objFolder Is Nothing Then
MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, "INVALID FOLDER"
End If


If Application.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a message is selected
Exit Sub
End If
For Each objItem In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.Move objFolder
End If
End If
Next
End Sub