F
FLWIII
Outlook 2000 VBA code to copy attachments to file on network drive works. I
added the line Item.SaveAs "C:\Temp" & Item.Subject
The macro returns the error "Internal Application Error" on this line of code.
The basic code is below. This is acting like a bug in Outlook 2000. I have
SP3 installed on Outlook. Again, saving the attachments work, saving the
Email as a text file does not. Is this a bug or am I missing something?
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder1 As MAPIFolder
Dim SubFolder2 As MAPIFolder
Dim SubFolder3 As MAPIFolder
Dim Item As MailItem
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder1 = Inbox.Folders("OS2i")
Set SubFolder2 = SubFolder1.Folders("CVs")
Set SubFolder3 = SubFolder1.Folders("MovedCVs")
i = 0
If SubFolder2.Items.Count = 0 Then
MsgBox "There are no messages in the CVs Folder.", vbInformation,
"Nothing Found"
Exit Sub
End If
For Each Item In SubFolder2.Items
Item.SaveAs "C:\Temp\" & Item.Subject
For Each Atmt In Item.Attachments
If Left(Atmt.FileName, 2) = "TO" Then
FileName = "X:\SourcingGuides\" & Atmt.FileName
Else
FileName = "X:\CVAttachments\" & Atmt.FileName
End If
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Item.Move SubFolder3
Next Item
Thanks
Frank
added the line Item.SaveAs "C:\Temp" & Item.Subject
The macro returns the error "Internal Application Error" on this line of code.
The basic code is below. This is acting like a bug in Outlook 2000. I have
SP3 installed on Outlook. Again, saving the attachments work, saving the
Email as a text file does not. Is this a bug or am I missing something?
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder1 As MAPIFolder
Dim SubFolder2 As MAPIFolder
Dim SubFolder3 As MAPIFolder
Dim Item As MailItem
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder1 = Inbox.Folders("OS2i")
Set SubFolder2 = SubFolder1.Folders("CVs")
Set SubFolder3 = SubFolder1.Folders("MovedCVs")
i = 0
If SubFolder2.Items.Count = 0 Then
MsgBox "There are no messages in the CVs Folder.", vbInformation,
"Nothing Found"
Exit Sub
End If
For Each Item In SubFolder2.Items
Item.SaveAs "C:\Temp\" & Item.Subject
For Each Atmt In Item.Attachments
If Left(Atmt.FileName, 2) = "TO" Then
FileName = "X:\SourcingGuides\" & Atmt.FileName
Else
FileName = "X:\CVAttachments\" & Atmt.FileName
End If
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Item.Move SubFolder3
Next Item
Thanks
Frank