Consulting

Results 1 to 6 of 6

Thread: MACRO not working

  1. #1
    VBAX Newbie
    Joined
    Dec 2017
    Posts
    3
    Location

    MACRO not working

    For some reason this macro has stopped working and am getting runtime error 287. I didnt create it and know very little about them, however I use this one often. Any help would be appreciated.

    Sub SAVEALERTEMAILU()
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim myItem As Outlook.MailItem
    Dim MsgTxt As String
    Dim x As Integer
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
    mypath = "\\Wsh1\rootfs1\Caughline475\Archived_Emails\"
    For x = 1 To myOlSel.Count

    Set myItem = myOlSel.Item(x)
    strDate = Format(myItem.ReceivedTime, "YYYYMMDD_HHMMSS")

    If myItem.Subject <> vbNullString Then
    strname = myItem.Subject
    Else
    strname = "No_Subject"
    End If
    sreplace = ""
    'create an array to loop through subject
    For Each mychar In Array("Release-Authorised: ", "Release-Authorised:", "release-authorised:", "Release-authorised:")
    'do the replacement for each release phrase
    strname = Trim(Replace(strname, mychar, sreplace))
    Next mychar
    sreplace = "_"
    'create an array to loop through illegal characters (saves lines)
    For Each mychar In Array("/", "\", ": ", ":", "?", Chr(34), "<", ">", "|", "__", "_ ", "*")
    'do the replacement for each character that's illegal
    strname = Trim(Replace(strname, mychar, sreplace))
    Next mychar

    myItem.SaveAs mypath & strDate & x & "-" & strname & "-U.msg", olMSG
    myItem.Delete

    Next x
    MsgTxt = "You have saved: " & x - 1 & " Items"
    MsgBox MsgTxt
    End
    End Sub

  2. #2
    It seems to work OK, though you have several undeclared variables and you should run the process in reverse order as the deletions will upset the count. (See below).
    If you are running the code from Outlook there is no need to create a new Outlook application to run the code.

    I assume the path exists?

    Option Explicit
    
    Sub SAVEALERTEMAILU()
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim myItem As Outlook.MailItem
    Dim MsgTxt As String
    Dim strDate As String
    Dim strName As String
    Dim sReplace As String
    Dim x As Integer
    Dim myChar As Variant
    Dim oFSO As Object
    Const myPath As String = "\\Wsh1\rootfs1\Caughline475\Archived_Emails\"
    
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        If Not oFSO.FolderExists(myPath) Then
            MsgBox "The folder" & vbCr & myPath & vbCr & "is not available."
            Exit Sub
        End If
        Set myOlExp = ActiveExplorer
        Set myOlSel = myOlExp.Selection
        For x = myOlSel.Count To 1 Step -1
    
            Set myItem = myOlSel.Item(x)
            strDate = Format(myItem.ReceivedTime, "YYYYMMDD_HHMMSS")
    
            If myItem.Subject <> vbNullString Then
                strName = myItem.Subject
            Else
                strName = "No_Subject"
            End If
            sReplace = ""
            'create an array to loop through subject
            For Each myChar In Array("Release-Authorised: ", "Release-Authorised:", "release-authorised:", "Release-authorised:")
                'do the replacement for each release phrase
                strName = Trim(Replace(strName, myChar, sReplace))
            Next myChar
            sReplace = "_"
            'create an array to loop through illegal characters (saves lines)
            For Each myChar In Array("/", "\", ": ", ":", "?", Chr(34), "<", ">", "|", "__", "_ ", "*")
                'do the replacement for each character that's illegal
                strName = Trim(Replace(strName, myChar, sReplace))
            Next myChar
    
            myItem.SaveAs myPath & strDate & x & "-" & strName & "-U.msg", olMsg
            myItem.Delete
    
        Next x
        MsgBox "You have saved: " & x - 1 & " Items"
    lbl_Exit:
        Exit Sub
    End Sub
    Last edited by gmayor; 12-21-2017 at 06:52 AM.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Newbie
    Joined
    Dec 2017
    Posts
    3
    Location
    Yes the path works, Ive tried to copy the above and run it and am now getting an error '424' with the following line being highlighted.

    For x = yOlSel.Count To 1 Step -1

  4. #4
    Sorry my fault - it should be

    For x = myOlSel.Count To 1 Step -1

    I have altered the code in my earlier reply
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    VBAX Newbie
    Joined
    Dec 2017
    Posts
    3
    Location
    It worked.


    Thank you thank you thank you

    Quote Originally Posted by gmayor View Post
    It seems to work OK, though you have several undeclared variables and you should run the process in reverse order as the deletions will upset the count. (See below).
    If you are running the code from Outlook there is no need to create a new Outlook application to run the code.

    I assume the path exists?

    Option Explicit
    
    Sub SAVEALERTEMAILU()
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim myItem As Outlook.MailItem
    Dim MsgTxt As String
    Dim strDate As String
    Dim strName As String
    Dim sReplace As String
    Dim x As Integer
    Dim myChar As Variant
    Dim oFSO As Object
    Const myPath As String = "\\Wsh1\rootfs1\Caughline475\Archived_Emails\"
    
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        If Not oFSO.FolderExists(myPath) Then
            MsgBox "The folder" & vbCr & myPath & vbCr & "is not available."
            Exit Sub
        End If
        Set myOlExp = ActiveExplorer
        Set myOlSel = myOlExp.Selection
        For x = myOlSel.Count To 1 Step -1
    
            Set myItem = myOlSel.Item(x)
            strDate = Format(myItem.ReceivedTime, "YYYYMMDD_HHMMSS")
    
            If myItem.Subject <> vbNullString Then
                strName = myItem.Subject
            Else
                strName = "No_Subject"
            End If
            sReplace = ""
            'create an array to loop through subject
            For Each myChar In Array("Release-Authorised: ", "Release-Authorised:", "release-authorised:", "Release-authorised:")
                'do the replacement for each release phrase
                strName = Trim(Replace(strName, myChar, sReplace))
            Next myChar
            sReplace = "_"
            'create an array to loop through illegal characters (saves lines)
            For Each myChar In Array("/", "\", ": ", ":", "?", Chr(34), "<", ">", "|", "__", "_ ", "*")
                'do the replacement for each character that's illegal
                strName = Trim(Replace(strName, myChar, sReplace))
            Next myChar
    
            myItem.SaveAs myPath & strDate & x & "-" & strName & "-U.msg", olMsg
            myItem.Delete
    
        Next x
        MsgBox "You have saved: " & x - 1 & " Items"
    lbl_Exit:
        Exit Sub
    End Sub
    Last edited by cockles; 12-21-2017 at 07:03 AM. Reason: submitted too quick

  6. #6
    You are welcome Have a good Christmas.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Posting Permissions

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