Consulting

Results 1 to 6 of 6

Thread: Moving Sent Items To Another ARCHIVE Sent Folder.

  1. #1
    VBAX Regular
    Joined
    Oct 2017
    Posts
    18
    Location

    Moving Sent Items To Another ARCHIVE Sent Folder.

    I had this code which work pretty well from this user here.
    https://www.mrexcel.com/forum/excel-...-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

  2. #2

  3. #3
    VBAX Regular
    Joined
    Oct 2017
    Posts
    18
    Location
    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
    Last edited by harky; 08-15-2019 at 01:43 AM.

  4. #4
    VBAX Regular
    Joined
    Oct 2017
    Posts
    18
    Location
    try this in outlook 2019
    got error..


  5. #5
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    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/h...ve-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
    
    NET::ERR_CERT_COMMON_NAME_INVALID

  6. #6
    VBAX Regular
    Joined
    Oct 2017
    Posts
    18
    Location
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •