Announcement

Collapse
No announcement yet.

Moving Sent Items To Another ARCHIVE Sent Folder.

Collapse
This topic is closed.
X
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Moving Sent Items To Another ARCHIVE Sent Folder.



    Base on current (below) code.
    Possible to add on more function?

    Possible to move send email to ARCHIVE Folder once email sent on outlook?

    From Inbox 'sent folder' to ARCHIVE

    PST Name: SENT_ARCHIVE
    Subfolder: SendFolder

    Or nt, is there a code where i can put in outlook




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

  • #2


    Hi harky,

    No need to delete the thread you just need to add the link to VBA eXpress

    http://www.vbaexpress.com/forum/show...VE-Sent-Folder
    If the solution helped please donate to RSPCA

    Sites worth visiting: Rabbitohs | Excel-it royUK | Excel Matters Rory | Kris' Spreadsheet Solutions | Domenic xl-central | The Smallman

    Comment

    Working...
    X