I've build a VBA-Project that checks the inbox on special emails,
extracts the attachement and save the attachement on the network.
this all happens when the user clicks on a button.
My problem now is that I want to automate this.
Therefore I've tried to rewrite the VBA project but
when an email arrives I always get the error message
'Unzulässiger oder nicht ausreichend defnierter Verweis'
(tr. Improper or no sufficient defined reference)
I can't figure out what to do and therefore I'm trying
to get an answer here.
Attached you'll find the code which is placed in 'ThisOutlookSession'
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim objNs As Outlook.NameSpace
Dim X As Integer
Set objNs = GetNamespace("MAPI")
Set Items = objNs.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
Dim objNs As Outlook.NameSpace
Dim strPath, strAuditPath, strSavPath, strFolderName As String
Dim oAttachment As Outlook.Attachment
Dim objTrash As Outlook.Folder
Dim intAnlagen, intTotal, i As Integer
Set objNs = GetNamespace("MAPI")
On Error GoTo check_error
If TypeOf Item Is Outlook.MailItem Then
Dim Msg As Outlook.MailItem
Set Msg = Item
If Msg.SenderEmailAddress = "notify#someone.com" Then
If Left(Msg.Subject, 8) = "QHST-Log" Then
strSavPath = "D:\Users\AS400_QHST_Logs\"
strPath = "T:\DOKUMENTE\AS400\QHST-Logs\"
strAuditPath = "D:\Dropbox\QHST-Log\"
strFolderName = Right(Msg.Subject, 4)
If Dir(strPath & strFolderName, vbDirectory) = vbNullString Then 'Prüfen ob Subfolder der Form JJJJ angelegt ist.
MkDir strPath & strFolderName
MkDir strAuditPath & strFolderName
MkDir strSavPath & strFolderName
End If
strPath = strPath & strFolderName & "\"
strAuditPath = strAuditPath & strFolderName & "\"
strSavPath = strSavPath & strFolderName & "\"
strFolderName = Mid(.Subject, 14, 2)
If Dir(strPath & strFolderName, vbDirectory) = vbNullString Then
MkDir strPath & strFolderName
MkDir strAuditPath & strFolderName
MkDir strSavPath & strFolderName
End If
strPath = strPath & strFolderName & "\"
strAuditPath = strAuditPath & strFolderName & "\"
strSavPath = strSavPath & strFolderName & "\"
intAnlagen = Msg.Attachments.Count
intTotal = intTotal + intAnlagen
'Debug.Print objNewMail & ": "; intanlagen
If intAnlagen > 0 Then
For i = 1 To intAnlagen
Set oAttachment = Msg.Attachments.Item(i)
oAttachment.SaveAsFile strPath & oAttachment.FileName
oAttachment.SaveAsFile strAuditPath & oAttachment.FileName
Next i
End If
Msg.UnRead = False
Msg.Delete
End If
End If
End If
check_error:
Debug.Print Err.Number; Err.Description
If Err.Number = 75 Then
Err.Clear
GoTo Back1:
Else
Err.Raise Err.Number, Err.Description
End If
Err.Clear
Resume Next
End Sub
Try
Set objNs = Application.GetNamespace("MAPI")
Edit: Reference the Application Object
http://msdn.microsoft.com/en-us/library/office/ff865800%28v=office.15%29.aspx
Syntax
expression .GetNamespace(Type)
expression A variable that represents an Application object.
Related
I'm trying to set up a macro in ThisOutlookSession to save attachments to file.
I previously used rules and 'run a script', but it is not enabled for all users.
The below code either returns a 91 error (object or variable not set), or it runs without error, but doesn't save.
The code is looking at a subfolder, to save all attachments to a location based on subject. The emails are sent to the subfolder through a rule.
I want to rename the attachments based on the ReceivedTime, and I think this is where the issue arises. If I use Msg.ReceivedTime, I get the 91 error. If I use Item.ReceivedTime, there is no error, but the file is not saved.
Here is the source where I derived most of the code and customized. https://www.tachytelic.net/2017/10/how-to-run-a-vba-macro-when-new-mail-is-received-in-outlook/
Private WithEvents folderItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set folderItems = objectNS.GetDefaultFolder(olFolderInbox).Folders("Operations").Folders("Test").Items
End Sub
Private Sub folderItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim att As Outlook.Attachment
Dim msg As Outlook.MailItem
Dim filepath As String, filedate As String
filepath = "C:\Documents\"
filedate = Format(Item.ReceivedTime, "YYYYMMDD") 'This is the line which I think is the problem. If I do Msg.ReceivedTime, I get 91 error, but if I do Item.ReceivedTime, it does not save
If TypeName(Item) = "MailItem" Then
If InStr(Item.Subject, "XXX") > 0 Then
For Each att In Item.Attachments
att.SaveAsFile filepath & "XXX\" & filedate & "_raw.csv"
Next
ElseIf InStr(Item.Subject, "YYY") > 0 Then
For Each att In Item.Attachments
att.SaveAsFile filepath & "YYY\" & filedate & "_raw.xlsx"
Next
ElseIf InStr(Item.Subject, "ZZZ") > 0 Then
For Each att In Item.Attachments
att.SaveAsFile filepath & "ZZZ.csv"
Next
End If
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub
My hypothesis is that the ReceivedTime is the issue. If I can use Msg.ReceivedTime, how do I set the variable? Or, if Item.ReceivedTime is correct, why does it not save?
Try the following
Dim att As Outlook.attachment
Dim msg As Outlook.MailItem
Dim filepath As String, filedate As String
filepath = "C:\Documents\"
If TypeName(Item) = "MailItem" Then
Set msg = Item
Debug.Print msg.ReceivedTime ' print on Immediate Window
filedate = Format(msg.ReceivedTime, "YYYYMMDD")
If InStr(msg.Subject, "XXX") > 0 Then
For Each att In msg.Attachments
att.SaveAsFile filepath & "XXX\" & filedate & "_raw.csv"
Next
ElseIf InStr(msg.Subject, "YYY") > 0 Then
For Each att In msg.Attachments
att.SaveAsFile filepath & "YYY\" & filedate & "_raw.xlsx"
Next
ElseIf InStr(msg.Subject, "ZZZ") > 0 Then
For Each att In msg.Attachments
att.SaveAsFile filepath & "ZZZ.csv"
Next
End If
End If
also you don't need outlookApp when the code is running within Outlook Application, simply use Application.
Example
Private Sub Application_Startup()
Dim objectNS As Outlook.NameSpace
Set objectNS = Application.GetNamespace("MAPI")
Set folderItems = objectNS.GetDefaultFolder(olFolderInbox) _
.Folders("Operations") _
.Folders("Test").Items
End Sub
This Run a Script code to save attachments stops saving attachments because the rule turns off.
Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
sSaveFolder = "C:\Users\andra.aeras\Documents\Test\"
For Each oAttachment In MItem.Attachments
If Right(oAttachment.FileName, 4) = "xlsx" Then
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
End If
Next
End Sub
Is there a way to "enable" the rules or improve this code to run properly or run without using rules?
Try it like this.
Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
ExtString As String, DestFolder As String)
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim I As Integer
Dim wsh As Object
Dim fs As Object
On Error GoTo ThisMacro_err
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
I = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
vbInformation, "Nothing Found"
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Exit Sub
End If
'Create DestFolder if DestFolder = ""
If DestFolder = "" Then
Set wsh = CreateObject("WScript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
MyDocPath = wsh.SpecialFolders.Item("mydocuments")
DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
If Not fs.FolderExists(DestFolder) Then
fs.CreateFolder DestFolder
End If
End If
If Right(DestFolder, 1) <> "\" Then
DestFolder = DestFolder & "\"
End If
' Check each message for attachments and extensions
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
Atmt.SaveAsFile FileName
I = I + 1
End If
Next Atmt
Next Item
' Show this message when Finished
If I > 0 Then
MsgBox "You can find the files here : " _
& DestFolder, vbInformation, "Finished!"
Else
MsgBox "No attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set fs = Nothing
Set wsh = Nothing
Exit Sub
' Error information
ThisMacro_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume ThisMacro_exit
End Sub
Sub Test()
'Arg 1 = Folder name of folder inside your Inbox
'Arg 2 = File extension, "" is every file
'Arg 3 = Save folder, "C:\Users\Ron\test" or ""
' If you use "" it will create a date/time stamped folder for you in your "Documents" folder
' Note: If you use this "C:\Users\Ron\test" the folder must exist.
SaveEmailAttachmentsToFolder "MyFolder", "xls", ""
End Sub
Steps to follow:
1) Go to the VBA editor, Alt -F11
2) Tools>References in the Menu bar
3) Place a Checkmark before Microsoft Outlook ? Object Library
? is the Outlook version number
4) Insert>Module
5) Paste the code (two macros) in this module
6) Alt q to close the editor
7) Save the file
I've been using a piece of code for awhile to save selected emails as .msg files but I cant figure out what to modify to get it to save all emails:
Option Explicit
Public Sub SaveMessageAsMsg()
Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
Dim strFolderpath As String
enviro = CStr(Environ("USERPROFILE"))
strFolderpath = BrowseForFolder(enviro & "\documents\")
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
sName = oMail.Subject
ReplaceCharsForFileName sName, "-"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
sPath = strFolderpath & "\"
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
End If
Next
End Sub
I know I need to change the For Each objItem In ActiveExplorer.Selection section to include all items but I'm not overly familiar with VB and haven't found what it needs to be replaced with.
I have tried using current folder and a few other options.
Example would be
Option Explicit
Public Sub Example()
Dim olNs As Outlook.NameSpace
Set olNs = Application.Session
Dim Inbox As Outlook.MAPIFolder
Set Inbox = olNs.GetDefaultFolder(olFolderInbox) ' Inbox
' // Process Current Folder
CURRENT_FOLDER Inbox
End Sub
Private Sub CURRENT_FOLDER(ByVal ParentFolder As Outlook.MAPIFolder)
Dim SUBFOLDER As Outlook.MAPIFolder
Dim Items As Outlook.Items
Set Items = ParentFolder.Items
Debug.Print ParentFolder.Name ' Print on Immediate Window
Dim i As Long
For i = Items.Count To 1 Step -1
DoEvents
Debug.Print Items(i).Subject ' Print on Immediate Window
Next
' // Recurse through subfolders
If ParentFolder.Folders.Count > 0 Then
For Each SUBFOLDER In ParentFolder.Folders
CURRENT_FOLDER SUBFOLDER
Next
End If
End Sub
Create a function that takes MAPIFolder as a parameter and loops through all items in the MAPIFolder.Items collection. The function must then call itself recursively for all subfolders in the MAPIFOlder.Folders collection.
Your code above must call that function for all folders in the Application.Session.Folders collection (represents all top level folders in Outlook).
Here is the full code I am using to do what I was needing
Option Explicit
Dim StrSavePath As String
Sub SaveAllEmails_ProcessAllSubFolders()
Dim i As Long
Dim j As Long
Dim n As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrReceived As String
Dim StrFolder As String
Dim StrSaveFolder As String
Dim StrFolderPath As String
Dim iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim SubFolder As MAPIFolder
Dim mItem As MailItem
Dim FSO As Object
Dim ChosenFolder As Object
Dim Folders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If
BrowseForFolder StrSavePath
Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & "\" & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm")
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, 3
Next j
On Error GoTo 0
Next i
ExitSub:
End Sub
Function StripIllegalChar(StrInput)
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[\" & Chr(34) & "\!\#\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
Set RegX = Nothing
End Function
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)
Dim SubFolder As MAPIFolder
Folders.Add Fld.FolderPath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder
ExitSub:
Set SubFolder = Nothing
End Sub
Function BrowseForFolder(StrSavePath As String, Optional OpenAt As String) As String
Dim objShell As Object
Dim objFolder ' As Folder
Dim enviro
enviro = CStr(Environ("USERPROFILE"))
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", 0, enviro & "\Documents\")
StrSavePath = objFolder.self.Path
On Error Resume Next
On Error GoTo 0
ExitFunction:
Set objShell = Nothing
End Function
I am having trouble getting this loop to work. Any advice?
Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
ExtString As String, DestFolder As String)
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim i As Integer
Dim wsh As Object
Dim fs As Object
Dim InboxMsg As Object
On Error GoTo ThisMacro_err
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
'To fix my issue I may have to change the loop to repeat the same number of
times as attachments
' Check subfolder for messages and exit of none found
' strFilter = "[Unread] = True"
' Set inboxItems =
ns.GetDefaultFolder(olFolderInbox).Folders(OutlookFolderInInbox).Items.Restrict(strFilter)
If SubFolder.UnReadItemCount = 0 Then
MsgBox "There are no New messages in this folder : " &
OutlookFolderInInbox, _
vbInformation, "Nothing Found"
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Exit Sub
End If
'Create DestFolder if DestFolder = ""
If DestFolder = "" Then
Set wsh = CreateObject("WScript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
MyDocPath = wsh.SpecialFolders.Item("mydocuments")
DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
If Not fs.FolderExists(DestFolder) Then
fs.CreateFolder DestFolder
End If
End If
If Right(DestFolder, 1) <> "\" Then
DestFolder = DestFolder & "\"
End If
' Check each message for attachments and extensions
strFilter = "[Unread] = True"
Set inboxItems =
ns.GetDefaultFolder(olFolderInbox).Folders(OutlookFolderInInbox).Items.Restrict(strFilter)
' For Each Item In inboxItems
For i = inboxItems.Count To 1 Step -1 'Iterates from the end backwards
Set InboxMsg = Inbox.Items(i)
'For Each Item In inboxItems
' For Each Atmt In inboxItems(I).Attachments
For Each Atmt In InboxMsg.Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString)
Then
FileName = DestFolder & Format(Item.ReceivedTime, "yyyy-mmm-dd") & Atmt.FileName
Atmt.SaveAsFile FileName
End If
Item.UnRead = "False"
' inboxItems(I).UnRead = "False"
Next Atmt
' Item.UnRead = "false"
Next
' Show this message when Finished
If i = 0 Then
MsgBox "You can find the files here : " _
& DestFolder, vbInformation, "Finished!"
Else
MsgBox "No attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set fs = Nothing
Set wsh = Nothing
Exit Sub
' Error information
ThisMacro_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume ThisMacro_exit
End Sub
Here is Quick example, set filter for both UnRead & Items with Attachments
Option Explicit
Public Sub Example()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim i As Long
Dim Filter As String
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:hasattachment" & _
Chr(34) & "=1 AND " & _
Chr(34) & "urn:schemas:httpmail:read" & _
Chr(34) & "=0"
Set Items = Inbox.Items.Restrict(Filter)
For i = Items.Count To 1 Step -1
Debug.Print Items(i) 'Immediate Window
Next
End Sub
I wrote a script that creates a PDF version of an email, this version below makes sure that an email doesn't have an attachment (version with attachment behaves in exactly the same way, by the way). It runs smoothly and without any problems until it reaches the 65-ish email, and then it stops with this error:
Run-Time error '-2147467259 (80004005)'
Any idea why this might be happening?
Here is my code:
Sub PrintEmails()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim myItem As Object, myItems As Object, objDoc As Object, objInspector As Object
Dim FolderPath As String
Dim FileNumber As Long
FileNumber = 2
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("NewEmails")
Set myItems = olFolder.Items
FolderPath = "F:\MyFolder\VBA\Emails\"
For Each myItem In myItems
If myItem.Attachments.Count = 0 Then
FileName = myItem.Subject
IllegalCharacters = Array("/", "\", ":", "?", "<", ">", "|", "&", "%", "*", "{", "}", "[", "]", "!")
For Each Character In IllegalCharacters
FileName = Replace(FileName, Character, " ")
Next Character
Do While FileOrDirExists(FolderPath & FileName & "(" & CStr(FileNumber) & ")" & ".pdf")
FileNumber = FileNumber + 1
Loop
If FileOrDirExists(FolderPath & FileName & ".pdf") Then
Set objInspector = myItem.GetInspector
Set objDoc = objInspector.WordEditor
objDoc.ExportAsFixedFormat FolderPath & FileName & "(" & CStr(FileNumber) & ")" & ".pdf", 17
Set objInspector = Nothing
Set objDoc = Nothing
FileNumber = FileNumber + 1
Else
Set objInspector = myItem.GetInspector
Set objDoc = objInspector.WordEditor
objDoc.ExportAsFixedFormat FolderPath & FileName & ".pdf", 17
Set objInspector = Nothing
Set objDoc = Nothing
End If
Else
End If
Next myItem
End Sub
Function FileOrDirExists(PathName As String) As Boolean
Dim iTemp As Integer
'Ignore errors to allow for error evaluation
On Error Resume Next
iTemp = GetAttr(PathName)
'Check if error exists and set response appropriately
Select Case Err.Number
Case Is = 0
FileOrDirExists = True
Case Else
FileOrDirExists = False
End Select
'Resume error checking
On Error GoTo 0
End Function
Thank you for your help!
I'm still unable to find a reason why the script would stop working around 65-ish email, but thanks to a few suggestions from #DmitryStreblechenko I came up with this "workaround" solution:
Sub PrintEmails()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim myItem As Object, myItems As Object
Dim FolderPath As String
Dim FileNumber As Long
Dim objWord As Object, objDoc As Object
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents
FileNumber = 2
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("NewEmails")
Set myItems = olFolder.Items
FolderPath = "F:\MyFolder\VBA\Emails\"
For Each myItem In myItems
If myItem.Attachments.Count = 0 Then
FileName = myItem.SenderName
IllegalCharacters = Array("/", "\", ":", "?", "<", ">", "|", "&", "%", "*", "{", "}", "[", "]", "!")
For Each Character In IllegalCharacters
FileName = Replace(FileName, Character, " ")
Next Character
Do While FileOrDirExists(FolderPath & FileName & "(" & CStr(FileNumber) & ")" & ".doc")
FileNumber = FileNumber + 1
Loop
If FileOrDirExists(FolderPath & FileName & ".doc") Then
myItem.SaveAs FolderPath & FileName & "(" & CStr(FileNumber) & ")" & ".doc", olDoc
FileNumber = FileNumber + 1
Else
myItem.SaveAs FolderPath & FileName & ".doc", olDoc
End If
FileNumber = 2
Else
End If
FileNumber = 2
Next myItem
wFile = Dir(FolderPath & "*.doc")
Do While wFile <> ""
Set objDoc = objWord.Documents.Open(FolderPath & wFile)
objDoc.ExportAsFixedFormat OutputFileName:=FolderPath & Replace(wFile, ".doc", ".pdf"), ExportFormat:=wdExportFormatPDF
objDoc.Close (True)
wFile = Dir
Loop
objWord.Quit
End Sub
Function FileOrDirExists(PathName As String) As Boolean
Dim iTemp As Integer
'Ignore errors to allow for error evaluation
On Error Resume Next
iTemp = GetAttr(PathName)
'Check if error exists and set response appropriately
Select Case Err.Number
Case Is = 0
FileOrDirExists = True
Case Else
FileOrDirExists = False
End Select
'Resume error checking
On Error GoTo 0
End Function
Thank you!