No announcement yet.

Moving Sent Items To Another ARCHIVE Sent Folder.

This topic is closed.
  • 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

    Subfolder: SendFolder

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

    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()
                            wks.Range("I" & i).Value = "ERROR Wrong File URL"
                            sErr = True
                        End If
                        On Error GoTo 0
                        wks.Range("I" & i).Value = "ERROR Wrong Folder URL"
                        sErr = True
                    End If
                End If
                If sErr = False Then
                    '.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
                        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
    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