MACRO not working

[cockles]

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

[gmayor]

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

[cockles]

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

[gmayor]

Sorry my fault - it should be

For x = myOlSel.Count To 1 Step -1

I have altered the code in my earlier reply

[cockles]

It worked.


Thank you thank you thank you


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

[gmayor]

You are welcome :) Have a good Christmas.