Can not open .msg files - excel

I have about 90 .msg, outlook files that I need to open, convert the excel attachment to .csv files and save off. Presently, the code below is to simply open the .msg outlook file, but the error appears :
How can I permit the .msg files to be opened.
Script:
Sub OpenMSGRenameDownloadAttachement()
Dim objOL As Outlook.Application
Dim Msg As Outlook.MailItem
Dim MsgCount As Integer
Set objOL = CreateObject("Outlook.Application")
'Change the path given month, ie. do this for Jan, Feb, April
inPath = "C:\January Messages"
thisFile = LCase(Dir(inPath & "\*.msg"))
Do While thisFile <> ""
Set Msg = objOL.Session.OpenSharedItem(thisFile)
Msg.Display
MsgBox Msg.Subject
thisFile = Dir
Loop
Set objOL = Nothing
Set Msg = Nothing
End Sub

Try this:
Sub OpenMSGRenameDownloadAttachement()
Dim Msg As Outlook.MailItem
Dim objAtt As Outlook.Attachment
Set objOL = CreateObject("Outlook.Application")
Set objNs = objOL.GetNamespace("MAPI")
'objNs.Logon
inPath = "C:\January Messages\"
outPath = "C:\January Messages\attachments\" 'create this folder for attachments or use your own
thisFile = Dir(inPath & "*.msg")
Do While Len(thisFile) > 0
Set Msg = objNs.OpenSharedItem(inPath & thisFile)
'MsgBox inPath & thisFile
'MsgBox Msg.Subject
'MsgBox Msg.SenderEmailAddress
'MsgBox Msg.Recipients.Item(1).Address
For Each objAtt In Msg.Attachments
If Right(objAtt, 4) = "xlsx" Or Right(objAtt, 3) = "xls" Then
objAtt.SaveAsFile outPath & Split(objAtt.DisplayName, ".")(0) & ".csv"
End If
Next
thisFile = Dir
Loop
Set objOL = Nothing
Set objNs = Nothing
End Sub

Related

Reply to All on Latest Sent Email Using Partial Subject Name

I send reports with Subject Name Like "Sales Report till 01-Sep-2022" in which only the date changes and initial like "Sales Report till*" remains the same.
Below is the code for "Replying to All" from sent items, which works well on "Replying to All" from sent items. The only problem is it's not replying on latest Sent Email.
It picks any email with "Sales Report till" whether that sent mail is from last week or last month.
I want to Reply to All on the latest Sent Email.
Sub OL_Email_Reply_To_All_WFN()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim objMail As Object
Dim objReplyToThisMail As MailItem
Dim lngCount As Long
Dim objConversation As Conversation
Dim objTable As Table
Dim objVar As Variant
Dim Path, WFN, SN As String
Dim WFN_Sub, WFN_RN, WFN_MB As String
Path = ThisWorkbook.Sheets("Main_Sheet").Range("B1") & "\" '''''Path to pick from "Main_Sheet" of ThisWorkbook
WFN = Path & ThisWorkbook.Sheets("Main_Sheet").Range("B2") ''''' Working File Name can be diffrent will change on sheet.
''''WFN_Sub = ThisWorkbook.Sheets("Main_Sheet").Range("B3")
''''WFN_RN = ThisWorkbook.Sheets("Main_Sheet").Range("B4")
''''WFN_MB = ThisWorkbook.Sheets("Main_Sheet").Range("B5")
''''WFN_SN = ThisWorkbook.Sheets("Main_Sheet").Range("B6")
'''''Original Subject Name looks like "Sales Report till 01-Sep-2022" in which date changes every everytime.
WFN_Sub = "Test Email" '''''Subject to find should be intial only
WFN_RN = "Hi Friend" '''''Recipient Name
WFN_MB = "Please ignore it's a Test Email" ''''''''''Mail Body
SN = "My Name" '''''''''Senders Name
Set olApp = Session.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderSentMail)
lngCount = 1
ThisWorkbook.Activate
For Each objMail In Fldr.Items
If TypeName(objMail) = "MailItem" Then
If InStr(objMail.Subject, WFN_Sub) <> 0 Then
Set objConversation = objMail.GetConversation
Set objTable = objConversation.GetTable
objVar = objTable.GetArray(objTable.GetRowCount)
Set objReplyToThisMail = olApp.Session.GetItemFromID(objVar(UBound(objVar), 0))
With objReplyToThisMail.ReplyAll
.Subject = WFN_Sub & " " & Format(Now() - 1, "DD-MMM-YYYY")
.HTMLBody = WFN_RN & "<br> <br>" & WFN_MB & "<br> <br>" & "Kind Regards" & "<br>" & SN
.display
.Attachments.Add WFN
End With
Exit For
End If
End If
Next objMail
Set olApp = Nothing
Set olNs = Nothing
Set Fldr = Nothing
Set objMail = Nothing
Set objReplyToThisMail = Nothing
lngCount = Empty
Set objConversation = Nothing
Set objTable = Nothing
If IsArray(objVar) Then Erase objVar
End Sub
Before getting the last row in the table (retrieved from the conversation object) you need to sort items based on the recieved date:
'Sort by ReceivedTime in descending order
table.Sort "[ReceivedTime]", True
Only after that you may rely on the last item in the code.
There is possibly simpler code.
Option Explicit
Sub OL_Email_Reply_To_All_WFN()
' reference Microsoft Outlook XX.X Object Library
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.Folder
Dim objMail As Object
Dim Path As String, WFN As String, SN As String
Dim WFN_Sub As String, WFN_RN As String, WFN_MB As String
'Path = ThisWorkbook.Sheets("Main_Sheet").Range("B1") & "\" '''''Path to pick from "Main_Sheet" of ThisWorkbook
'WFN = Path & ThisWorkbook.Sheets("Main_Sheet").Range("B2") ''''' Working File Name can be diffrent will change on sheet.
''''WFN_Sub = ThisWorkbook.Sheets("Main_Sheet").Range("B3")
''''WFN_RN = ThisWorkbook.Sheets("Main_Sheet").Range("B4")
''''WFN_MB = ThisWorkbook.Sheets("Main_Sheet").Range("B5")
''''WFN_SN = ThisWorkbook.Sheets("Main_Sheet").Range("B6")
'''''Original Subject Name looks like "Sales Report till 01-Sep-2022" in which date changes every everytime.
WFN_Sub = "Test Email" '''''Subject to find should be intial only
WFN_RN = "Hi Friend" '''''Recipient Name
WFN_MB = "Please ignore it's a Test Email" ''''''''''Mail Body
SN = "My Name" '''''''''Senders Name
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderSentMail)
Dim fldrItems As Outlook.Items
Set fldrItems = olFldr.Items
fldrItems.Sort "[ReceivedTime]", True
Dim i As Long
For i = 1 To fldrItems.Count
If TypeName(fldrItems(i)) = "MailItem" Then
If InStr(fldrItems(i).Subject, WFN_Sub) <> 0 Then
Debug.Print fldrItems(i).ReceivedTime
With fldrItems(i).ReplyAll
.Subject = WFN_Sub & " " & Format(Now() - 1, "DD-MMM-YYYY")
.htmlbody = WFN_RN & "<br> <br>" & WFN_MB & "<br> <br>" & "Kind Regards" & "<br>" & SN
.Display
'.Attachments.Add WFN
End With
Exit For
End If
End If
Next
Set olApp = Nothing
Set olNs = Nothing
Set olFldr = Nothing
Set fldrItems = Nothing
Set objMail = Nothing
End Sub

Attach files in batches of 7, change Subject & Body accordingly

The below code attaches one file per email. I need to attach seven files from the folder.
I have approximately 150 files.
I need to
In the first email attach the first 7 files and then loop to attach 7 files to each subsequent email then in the last email attach the remaining three PDF files.
Subject for the first email: Invoice 001 to Invoice 007
Body for First Email:
Please find attached the following invoices
Invoice 001 to Invoice 007 (7 invoices)
...
Subject for the last email: Invoice 148 to Invoice 150
Body for last Email:
Please find attached the following invoices
Invoice 148 to Invoice 150 (3 invoices)
Sub sendmailsss()
Dim path As String
Dim counter As Integer
counter = ThisWorkbook.Worksheets("Sheet").Range("I4")
path = ThisWorkbook.Worksheets("Sheet").Range("M2")
If ThisWorkbook.Worksheets("Sheet").Range("M2") = "" Then
MsgBox "No folder selected. Please Select a folder with Invoives."
Exit Sub
End If
fpath = path & "\*.pdf"
fname = Dir(path)
Dim OutApp As Outlook.Application
Dim Source As String
Dim subj() As String
Do While fname <> ""
subj = Split(fname, ".")
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
Dim OutMail As Outlook.MailItem
Dim OutAccount As Outlook.Account
Set OutAccount = OutApp.Session.Accounts.Item(2)
Set OutMail = OutApp.CreateItem(olMailItem)
Source = path & fname
With OutMail
.To = "info#abc.co.uk"
.Subject = "Company Ltd " & subj(0)
.HTMLBody = "Invoice attached"
.Attachments.Add Source
.SendUsingAccount = OutAccount
'.Display
.Send
End With
If Err Then
MsgBox "Error while sending Email" & vbLf & "Press OK to check it in the Outlook", vbExclamation
'.Display
Else
ms = ms + 1
End If
On Error GoTo 0
Application.Wait Now + #12:00:10 AM#
fname = Dir()
'If ms = 3 Then
' Exit Do
'End If
Loop
MsgBox "Process Completed. " & ms & " emails sent."
End Sub
Here is the re-built code:
Sub SendMailSSS()
Dim path As String
'Dim counter As Integer
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outAccount As Outlook.Account
Dim source As String
'Dim subj() As String
Dim fPath As String
Dim fName As String
Dim fileList As Variant
Dim innerLoop As Integer
Dim fileCounter As Integer
'counter = ThisWorkbook.Worksheets("Sheet").Range("I4")
path = ThisWorkbook.Worksheets("Sheet1").Range("M2")
If path <> "" Then
fileList = FncGetFilesFromPath(path)
fileCounter = 0
Do While fileCounter < UBound(fileList)
Set outApp = CreateObject("Outlook.Application")
Set outAccount = outApp.Session.Accounts.Item(2)
Set outMail = outApp.CreateItem(olMailItem)
With outMail
.To = "info#abc.co.uk"
.Subject = "Company Ltd " & "Whatever 'subj' array was supposed to be doing in your code"
.HTMLBody = "Invoice attached"
.SendUsingAccount = outAccount
'Gets next up to 7 files
For innerLoop = fileCounter To (fileCounter + 7)
If innerLoop <= UBound(fileList) Then
.Attachments.Add fileList(innerLoop)
Else
Exit For
End If
Next innerLoop
End With
outMail.Send
fileCounter = fileCounter + innerLoop
Loop
Else
MsgBox "No folder selected. Please Select a folder with Invoices."
End If
Set outApp = Nothing
Set outMail = Nothing
Set outAccount = Nothing
End Sub
Private Function FncGetFilesFromPath(fPath As String) As Variant
Dim result As Variant
Dim fName As String
Dim i As Integer
ReDim result(0)
i = 0
fName = Dir(fPath)
Do While fName <> ""
ReDim Preserve result(i)
result(i) = fPath & fName
i = i + 1
fName = Dir()
Loop
FncGetFilesFromPath = result
End Function
You should be able to adapt this into your existing code. What you need to do I think is add all the references to the attachment files to an array first. This will allow you to loop over them according to your specific counting requirements of 7 per e-mail:
Sub SendMailSSS()
Dim path As String
'Dim counter As Integer
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outAccount As Outlook.Account
Dim source As String
'Dim subj() As String
Dim fPath As String
Dim fName As String
Dim fileList As Variant
Dim innerLoop As Integer
Dim fileCounter As Integer
'counter = ThisWorkbook.Worksheets("Sheet").Range("I4")
path = ThisWorkbook.Worksheets("Sheet1").Range("M2")
If path <> "" Then
fileList = FncGetFilesFromPath(path & "\*.pdf")
fileCounter = 0
Do While fileCounter < UBound(fileList)
Set outApp = CreateObject("Outlook.Application")
Set outAccount = outApp.Session.Accounts.Item(2)
Set outMail = outApp.CreateItem(olMailItem)
With outMail
.To = "info#abc.co.uk"
.Subject = "Company Ltd " & "Whatever 'subj' array was supposed to be doing in your code"
.HTMLBody = "Invoice attached"
.SendUsingAccount = outAccount
'Gets next up to 7 files
For innerLoop = fileCounter To (fileCounter + 7)
If innerLoop <= UBound(fileList) Then
.Attachments.Add fileList(innerLoop)
Else
Exit For
End If
Next innerLoop
End With
outMail.Send
fileCounter = fileCounter + innerLoop
Loop
Else
MsgBox "No folder selected. Please Select a folder with Invoices."
End If
Set outApp = Nothing
Set outMail = Nothing
Set outAccount = Nothing
End Sub
Private Function FncGetFilesFromPath(fPath As String) As Variant
Dim result As Variant
Dim fName As String
Dim i As Integer
ReDim result(0)
i = 0
fName = Dir(fPath)
Do While fName <> ""
ReDim Preserve result(i)
result(i) = fPath & fName
i = i + 1
fName = Dir()
Loop
FncGetFilesFromPath = result
End Function
I'm not sure what "subj" or "counter" are supposed to be doing in your code so I have commented them out. I cannot 100% test this, because I don't have Outlook on this machine, but it should give you the idea of how the looping will work.

Getting Run-Time Error '-2147221233 (8004010f)', then getting Run-time error '462' The remote server machine does not exist or is unavailable

The following code used to work but has suddenly started producing the above error message. It's designed to take contact details from each email in a folder, then send a new email out. I've run bug checks and yhe line that fails is:
Set objFolder = objFolder.Folders("Inbox").Folders("Test")
Here's the code:
Sub ListMailsInFolder()
Dim objNS As Outlook.Namespace
Dim objFolder As Outlook.MAPIFolder
Dim Lines() As String
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetFirst ' folders of your current account
Set objFolder =
objFolder.Folders("Inbox").Folders("Test")
Worksheets("Sheet2").Cells.ClearContents
a = 1
For Each Item In objFolder.Items
If TypeName(Item) = "MailItem" Then
Item.Display
Worksheets("Sheet2").Cells(1, a).Value =
Item.Body
Item.Close 1
a = a + 1
Debug.Print Item.ConversationTopic
End If
Next
For x = 1 To 208
If Worksheets("Sheet2").Cells(1, x) = "" Then
Exit For
End If
Set OutApp = CreateObject("Outlook.Application")
Set objOutlookMsg = OutApp.CreateItem(olMailItem)
Set Recipients = objOutlookMsg.Recipients
Set objOutlookRecip =
Recipients.Add("<email removed for forum>")
objOutlookRecip.Type = 1
objOutlookMsg.SentOnBehalfOfName =
"<email removed for forum>"
objOutlookMsg.Subject = "Fleet Insurance"
objOutlookMsg.Body = "Testing this macro" & vbCrLf &
vbCrLf & "First Name: " & Worksheets("Sheet3").Cells(7, x) & vbCrLf & "Last Name: " & Worksheets("Sheet3").Cells(10, x) & vbCrLf & "Email Address: " & Worksheets("Sheet3").Cells(14, x)
'Fleet client relationship team in signature
'Resolve each Recipient's name.
For Each objOutlookRecip In objOutlookMsg.Recipients
objOutlookRecip.Resolve
Next
objOutlookMsg.Send
'objOutlookMsg.Display
Set OutApp = Nothing
Next x
End Sub
To reliably reference the default Inbox:
Option Explicit
Sub ListMailsInDefaultAccountFolder()
Dim objNS As Namespace
Dim objFolder As Folder
Dim defInboxFolder As Folder
Dim itmCount As Long
Dim i As Long
Set objNS = GetNamespace("MAPI")
Set defInboxFolder = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = defInboxFolder.Folders("Test")
itmCount = objFolder.Items.Count
For i = 1 To itmCount
Debug.Print objFolder.Items(i).Subject
Next
End Sub
The error code is MAPI_E_NOT_FOUND. Make sure the folder named "Test" exist under Inbox.
The folders you are looking for, are most likely missing (not according to your Outlook, but according to your code). One reason this can happen is if your Inbox changes name, which it can do if you aren't using an English Outlook. Try this:
Set objFolder = objNS.Folders.GetFirst
For Each folder In objFolder.Folders
Debug.Print folder.Name
Next
It lists all folders where the Inbox should be. Hopefully you'll find something that you can identify as your Inbox. Replace that name in your code.

Attaching a file

The idea is to attach an Excel file using Attachment.Add.
A macro reads the files within a folder and displays it in a column. I would like to attach those files via Excel.
I get an error on
.Attachments.Add Filelist & "\" & "Attch"
Sub Sendemailusingword()
Dim Olapp As Outlook.Application
Dim Olemail As Outlook.MailItem
Dim olmail As Object
Dim olinsp As Outlook.Inspector
Dim wddoc As Word.Document
Dim count As Integer
Dim x As Integer
Dim Filelist As String
Dim Attch As String
x = 1
row_number = 7
count = Sheet1.Range("K1")
For x = 1 To count
row_number = row_number + 1
Attch = Sheet1.Range("D" & row_number).Value
Filelist = "K:\3SHARE\2016 Plan\Statment Email Send"
Set Olapp = New Outlook.Application
Set Olemail = Olapp.CreateItem(olMailItem)
With Olemail
.Display
.To = Sheet1.Range("G" & row_number)
.Subject = Sheet1.Range("D6") & Sheet1.Range("F" & row_number)
.SentOnBehalfOfName = "ComdataCommissions#comdata.com"
.BodyFormat = olFormatHTML
.CC = Sheet1.Range("H" & row_number) & ";" & Sheet1.Range("I" & row_number)
Set olinsp = .GetInspector
Set wddoc = olinsp.WordEditor
Sheet1.Activate
Range("B2").CurrentRegion.Copy
wddoc.Range.Paste
.Attachments.Add Filelist & "\" & "Attch"
End With
Next x
End Sub
.Attachments.Add Filelist & "\" & Attch
Assuming the variable Attch contains the filename of the file to be attached.
EDIT: noticed you tagged with excel-vba-mac, in which case I don't think backslash will work as a path separator. : or maybe / should work, or use Application.PathSeparator

Runtime error while opening an oft template

I have a mailing tool to create Outlook templates. The templates are stored as OLEObjects in one of the worksheets.
To use the templates I am creating a copy of them in the Temp folder. Afterwards the tool references it directly and opens with CreateItemFromTemplate. This works only on my PC. Others in my company get an error.
Code recreating the OLE object:
Sub RecreateObject(ObjectName As String, TemplateName As String) 'creates a copy of the template stored in config in the users temp folder so that we can reference it from hard drive
Dim objShell As Object
Dim objFolder As Variant
Dim objFolderItem As Variant
Dim oleObj As OLEObject
Set objShell = CreateObject("shell.application")
Set objFolder = objShell.Namespace(Environ("USERPROFILE") & "\Documents" & Application.PathSeparator)
Set objFolderItem = objFolder.Self
Set oleObj = wsConfig.OLEObjects(ObjectName)
'On Error GoTo Error1:
oleObj.Copy
If Dir(CStr(Environ("USERPROFILE") & "\Documents\" & TemplateName & ".oft"), vbDirectory) = vbNullString Then
objFolderItem.InvokeVerb ("Paste")
Else
Kill Environ("USERPROFILE") & "\Documents\" & TemplateName & ".oft"
oleObj.Copy
objFolderItem.InvokeVerb ("Paste")
End If
EndThisSub:
Set objShell = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
Set oleObj = Nothing
Exit Sub
Error1:
MsgBox "Please re-open this file - template recreation failed."
GoTo EndThisSub:
End Sub
Code opening the template:
Sub OpenTemplate(TemplateName As String, InsHeight As Long, InsWidth As Long, InsTop As Long, InsLeft As Long)
Dim response
Dim varEditedTempBody As Variant, varEditedTempSubject As Variant
'On Error GoTo Error1:
Set objOutlook = CreateObject("Outlook.Application")
'On Error GoTo Error2:
If objMail Is Nothing Then 'checks if any mails opened, if not fires procedure
If curProcess = AddingTemplate Then
Set objMail = objOutlook.CreateItem(0)
Set objInspector = objMail.GetInspector
objMail.Display
objMail.Body = "" 'clearing the automatic signature
End If
If curProcess = EditingTemplate Then
Set objMail = objOutlook.CreateItemFromTemplate(Environ("USERPROFILE") & "\Documents\" & frmTemplates.Controls(TemplateName).Value & ".oft")
'clearing the automatic signature by copying in the template after displaying
varEditedTempBody = objMail.HTMLBody
varEditedTempSubject = objMail.Subject
Set objMail = objOutlook.CreateItemFromTemplate(Environ("USERPROFILE") & "\Documents\" & frmTemplates.Controls(TemplateName).Value & ".oft")
With objMail
.Display
.HTMLBody = varEditedTempBody
.Subject = varEditedTempSubject
End With
Set objInspector = objMail.GetInspector
End If
With objInspector
.WindowState = 2
.Height = InsHeight
.Width = InsWidth
.Top = InsTop
.Left = InsLeft
End With
Else
response = MsgBox("A mail template is already opened. Would you like to proceed and close it without save?", vbYesNo)
If response = vbYes Then 'if user agrees to closing procedure fires
Call CloseTemplate
If curProcess = AddingTemplate Then
Set objMail = objOutlook.CreateItem(0)
Set objInspector = objMail.GetInspector
objMail.Display
objMail.Body = "" 'clearing the automatic signature
End If
If curProcess = EditingTemplate Then
Set objMail = objOutlook.CreateItemFromTemplate(Environ("USERPROFILE") & "\Documents" & Application.PathSeparator & frmTemplates.Controls(TemplateName).Value & ".oft")
varEditedTempBody = objMail.HTMLBody
varEditedTempSubject = objMail.Subject
Set objMail = objOutlook.CreateItemFromTemplate(Environ("USERPROFILE") & "\Documents" & Application.PathSeparator & frmTemplates.Controls(TemplateName).Value & ".oft")
With objMail
.Display
.HTMLBody = varEditedTempBody
.Subject = varEditedTempSubject
End With
Set objInspector = objMail.GetInspector
End If
With objInspector
.WindowState = 2
.Height = InsHeight
.Width = InsWidth
.Top = InsTop
.Left = InsLeft
End With
Else
objMail.Display
Exit Sub
End If
End If
ExitThisSub:
Exit Sub
Error1:
MsgBox "Cannot open the Outlook application. Please note that mailer uses Outlook by default and without it it's not possible to use the program."
GoTo ExitThisSub:
Error2:
MsgBox "The template cannot be opened from hard drive. Please contact ...."
GoTo ExitThisSub:
End Sub
I get the error on this line:
Set objMail = objOutlook.CreateItemFromTemplate(Environ("USERPROFILE") & "\Documents\" & frmTemplates.Controls(TemplateName).Value & ".oft")
saying: run-time error '-2147286960(80030050)' Cannot open the file /path/ . the file may not exist, you may not have the permission to open it...
I read about this and the suggestion was that an instance of objOutlook may somehow lock the file. So I've set it to nothing everywhere after playing with templates or recreating them but it still returned this error.
Your file or directory is ReadOnly. Change the properties of the directory and that's all.

Resources