I am currently using a module on Microsoft Access to Open an Excel file and paste the results into an email. The module is working properly, but the Excel file is remaining open in the background. This is causing an issue when I try to run the same module using the same file.
The Excel file I am using also automatically updates a date field, so I also need the close call to save the file beforehand, or ignore the save changes pop-up.
Public Function emailPaste(exFile As String, exSheet As String, exRange As String, _
EmailSubject As String, To_Field As String, Optional CC_Field As String)
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim ApXL As Object
Set ApXL = CreateObject("Excel.Application")
ApXL.Workbooks.Open (exFile)
Set rng = Nothing
' Only send the visible cells in the selection.
Set rng = Sheets(exSheet).Range(exRange).SpecialCells(xlCellTypeVisible)
'If rng Is Nothing Then
'MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
'Exit Sub
'End If
With ApXL.Application
.EnableEvents = False
.ScreenUpdating = False
End With
Call OpenOutlook
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = To_Field
.CC = CC_Field
.Subject = EmailSubject
.HTMLBody = "<BODY style=font-size:12pt;font-family:Calibri> The report: " & EmailSubject & " " & _
"is pasted below. <br><br> Please review it and contact me if there are any issues.<br><br> " _
& RangetoHTML(rng) & ""
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
.Display
End With
On Error GoTo 0
With ApXL.Application
.EnableEvents = True
.ScreenUpdating = True
End With
ApXL.Quit
Set ApXL = Nothing
Set OutMail = Nothing
Set OutApp = Nothing
End Function
How can I add at the end the code needed to save the excel file and close it without any user intervention?
You must be very strict in opening the Excel objects and closing them in reverse order - as done in this example:
Public Sub RenameWorkSheet()
Dim xls As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Set xls = New Excel.Application
Set wkb = xls.Workbooks.Open("c:\test\workbook1.xlsx")
Set wks = wkb.Worksheets(1)
wks.Name = "My New Name"
wkb.Close True
Set wks = Nothing
Set wkb = Nothing
xls.Quit
Set xls = Nothing
End Sub
You should try to tell the Application, that the Worksheet is saved
as it is.
Then Close the Worksheet
Then try to Close the Application.
something like this:
exFile.Sheets(exSheet).Saved = True
exFile.Sheets(exSheet).Close
ApXL.Quit
Or tell, that it doesn't have to save on closing...:
exFile.Sheets(exSheet).Close False
ApXL.Quit
I'd also propose, that you should store a direct reference to the Sheet and not implicitly calling the sheet via the active window...
Something like
dim wsh as Worksheet
set wsh = exFile.Sheets(exSheet)
then you can work with the variable wsh... more comfortable
Related
I am trying to save a list of email in msg format to htm format so that Xceptor tool can read the email as pdf. (Without a vba, Currently I manually open the email in Outlook and save as htm one by one.)
I found below script but I get
"Run Time error 287: Application-defined or object-defined error".
Sub SaveMSG_as_HTML()
Dim olMsg As MailItem
Dim strPath As String
Dim strMsg As String
Dim strHTML As String
strPath = "\\Hbap.adroot.hsbc\hk\Finance\224017\AMH_A2R_2\WRK\AAC\PL\To GFC\Movement Table\MvtXceptor\Configuration\Table18.1\"
strMsg = "RE CRR Inquiry as atJan-00-00 - --.msg"
strHTML = Left(strMsg, InStrRev(strMsg, Chr(46))) & "html"
Set olMsg = Session.OpenSharedItem(strPath & strMsg)
olMsg.SaveAs Path:=strPath & strHTML, Type:=olHTML
olMsg.Close olDiscard
lbl_Exit:
Set olMsg = Nothing
Exit Sub
End Sub
Without a vba, i need to open the email in outlook and save as htm one by one.
Without VBA? So I guess you want to use VBScript? Say, directly run it from desktop by clicking on the .vbs file? If yes, then you need to declare and create/get the outlook object before you can work with it. Otherwise how will your code know what is Session? Also olHTML and olDiscard are Outlook constants. VbScript will not know what they are.
Is this what you are trying? Paste this in Notepad and save it as Sample.Vbs
Private Const olHTML = 5
Private Const olDiscard = 1
Dim OutApp
Dim olMsg
Dim nsOutlook
Dim strPath
Dim strMsg
Dim strHTML
'~~> I used these values for testing. Change as applicable
strPath = "C:\Temp\"
strMsg = "test.msg"
strHTML = "test.html"
Set OutApp = CreateObject("Outlook.Application")
Set nsOutlook = OutApp.GetNamespace("MAPI")
Set olMsg = nsOutlook.OpenSharedItem(strPath & strMsg)
olMsg.SaveAs strPath & strHTML, olHTML
olMsg.Close olDiscard
Set olMsg = Nothing
Set nsOutlook = Nothing
Set OutApp = Nothing
What I am trying to do.
I highlight some text in an email then run my macro.
It 'copies' the highlighted text and stores it in variable strText.
Then it creates a file called Artwork List.xlsx if it does not exist and if it exists it opens it.
After that it copies the text into the file in column A row 1 if the lastrow is 1, and if not, it appends to lastrow + 1
My code throws
'Run-time error 424, Object required'
To narrow down, the error should be coming from:
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
or anything related to this line.
Sub copyArts2File()
MsgBox "ok"
Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim strText As String
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim strTextArr As Variant
On Error Resume Next
'Get Outlook if it's running
Set OutApp = GetObject(, "Outlook.Application")
'Outlook wasn't running, so cancel
If Err <> 0 Then
MsgBox "Outlook is not running so nothing can be selected!"
GoTo lbl_Exit
End If
On Error GoTo 0
Set OutMail = OutApp.ActiveExplorer.Selection.Item(1)
With OutMail
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
strText = wdDoc.Application.Selection.Range.Text
End With
'MsgBox strText
lbl_Exit:
Set OutMail = Nothing
Set OutApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
FileName = "Artwork List.xlsx"
fileDoesExist = Dir("C:\Users\quaer\Desktop\DL Arts\" & FileName) > ""
' Check for existing file
If fileDoesExist Then
' Open Excel file
Set xlBook = xlApp.Workbooks.Open("C:\Users\quaer\Desktop\DL Arts\" & FileName)
Set xlSheet = xlBook.Sheets(1)
Else
' Add Excel file
Set xlBook = xlApp.Workbooks.Add
With xlBook
.SaveAs FileName:="C:\Users\quaer\Desktop\DL Arts\" & FileName
End With
Set xlSheet = xlBook.Sheets(1)
End If
' Do stuff with Excel workbook
Dim i As Integer
Dim lastrow As Long
With xlApp
With xlBook
With xlSheet
strTextArr = Split(strText, "Adding file")
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
MsgBox lastrow
If lastrow = 1 Then
For i = 1 To UBound(strTextArr)
.Range("A" & i).Value = strTextArr(i)
Next i
Else
For i = 1 To UBound(strTextArr)
.Range("A" & (i + lastrow)).Value = strTextArr(i)
Next i
End If
.Close SaveChanges:=True
End With
End With
End With
xlApp.Visible = True
Exit Sub
End Sub
Try replacing this line, lastrow = .Cells(Rows.Count, 1).End(xlUp).Row, with:
lastrow = .Cells(1048576, 1).End(xlUp).Row
or
lastrow = .Cells(Rows.Count +1, 1).End(xlUp).Row
Jeeez this is crazy. I have found the problem finally and got a working code for anyone wanting similar usage. 1st off, I need to add the Microsoft excel add in. So in Outlook VBA, Tools -> references -> check Microsoft Excel 16.0 Object Library. This is to get rid of the 424 object required error, as I was trying to a call a excel built in method I guess. this is the line:
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
Pls note that I am calling this macro from Outlook.
After this I faced a couple of other issues.
1. errors such as 424 run time, remote server machine does not exist or is not available.
first time running, it throws this error, 2nd time I click, the problem goes away. This is an issue with non specific use of the app, book and worksheet and so leaves VBA to assign on its own. Lesson learnt, be explicit about every thing.
leaves a copy of excel process even after program ends. This can be seen in task manager. This causes issues because then my excel file is linked to this process and not able to open without either read only or notify. Its locked with the process. So I cannot run again next time.
Anyway. Here is the final code. And I have also changed it to .Range instead of .Cells. I believe it does not matter if I used either but the key culprit is : xlSheet.Rows.Count. Instead of just Rows.Count, explicitly use xlSheet.Rows.Count.
Option Explicit
Sub copyArts2File()
MsgBox "ok"
Dim OutApp As Object, OutMail As Object, olInsp As Object, wdDoc As Object
Dim xlApp As Excel.Application, xlBook As Excel.Workbook, xlSheet As Object
Dim strText As String
Dim strTextArr As Variant
Dim fName As String
Dim fileDoesExist As Boolean
Dim i As Integer
Dim lastrow As Long
On Error Resume Next
'Get Outlook if it's running
Set OutApp = GetObject(, "Outlook.Application")
'Outlook wasn't running, so cancel
If Err <> 0 Then
MsgBox "Outlook is not running so nothing can be selected!"
GoTo lbl_Exit
End If
On Error GoTo 0
Set OutMail = OutApp.ActiveExplorer.Selection.Item(1)
With OutMail
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
strText = wdDoc.Application.Selection.Range.Text
End With
'MsgBox strText
'Close out all shit
Set OutMail = Nothing
Set OutApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
lbl_Exit:
Set OutMail = Nothing
Set OutApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
On Error Resume Next 'Create or use a Excel Application
Set xlApp = GetObject(, "Excel.Application")
If Err.Number > 0 Then Set xlApp = CreateObject("Excel.Application")
On Error GoTo 0
xlApp.Visible = False
xlApp.DisplayAlerts = False
fName = "Artwork List.xlsx"
fileDoesExist = Dir("C:\Users\quaer\Desktop\DL Arts\" & fName) > ""
' Check for existing file
If fileDoesExist Then
' Open Excel file if present
Set xlBook = xlApp.Workbooks.Open("C:\Users\quaer\Desktop\DL Arts\" & fName)
Else
' Add Excel file if not present
Set xlBook = xlApp.Workbooks.Add
xlBook.SaveAs fileName:="C:\Users\quaer\Desktop\DL Arts\" & fName
End If
Set xlSheet = xlBook.Worksheets(1)
' Do stuff with Excel workbook
strTextArr = Split(strText, "Adding file")
lastrow = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row
If lastrow = 1 Then
For i = 1 To UBound(strTextArr)
xlSheet.Range("A" & i).Value = strTextArr(i)
Next i
Else
For i = 1 To UBound(strTextArr)
xlSheet.Range("A" & (i + lastrow)).Value = strTextArr(i)
Next i
End If
xlBook.SaveAs fileName:="C:\Users\quaer\Desktop\DL Arts\" & fName, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
xlBook.Close (True)
Set xlBook = Nothing
Set xlSheet = Nothing
xlApp.Visible = True
xlApp.Quit
Set xlApp = Nothing
MsgBox "Done!"
Exit Sub
End Sub
Thanks for the help and suggestions nonetheless.
I am trying to loop through a set of worksheets, save each of them as a separate workbook, and then send them as attachment by mail.
However when running the below code, I end up with error 287 triggered by .Send. I have outlook open, so that is not the problem. If I change .Send to .Display, the mails are generated as drafts as displayed properly with the correct sheet attached.
Sub SendWorksheetsByMail()
Dim wb As Workbook
Dim destinationWb As Workbook
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Set wb = Workbooks("Test.xlsm")
Application.EnableEvents = False
Application.ScreenUpdating = False
For Each ws In wb.Worksheets
'Ignore Summary and Config
If ws.Name <> "Summary" And ws.Name <> "Config" Then
'On Error Resume Next
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
ws.Copy
Set destinationWb = ActiveWorkbook
destinationWb.SaveAs "C:\****************\" & ws.Name & ".xlsx", FileFormat:=51
With OutMail
.To = "*******************"
.Subject = "Test"
.Body = "Test"
.Attachments.Add destinationWb.FullName
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next ws
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Edit: "It also fails even without an attachment. Essentially generating a message containing only the subject and text "test"."
Any suggestions for how to solve this? It would save a lot of time to not have to click Send for each individual mail, as the number of mails to send could potentially become quite large.
This is what I used to send a mail with attachment to multiple addresses, listed in column H while the name of the receiver is listed in another column
Sub Mail()
'####################################
'### Save the file as pdf ######
'####################################
Dim FSO As Object
Dim s(1) As String
Dim sNewFilePath As String
Set FSO = CreateObject("Scripting.FileSystemObject")
s(0) = ThisWorkbook.FullName
If FSO.FileExists(s(0)) Then
'//Change Excel Extension to PDF extension in FilePath
s(1) = FSO.GetExtensionName(s(0))
If s(1) <> "" Then
s(1) = "." & s(1)
sNewFilePath = Replace(s(0), s(1), ".pdf")
'//Export to PDF with new File Path
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sNewFilePath, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End If
Else
'//Error: file path not found
MsgBox "Error: this workbook may be unsaved. Please save and try again."
End If
Set FSO = Nothing
'##########################################
'### Attach the file and mail it ######
'##########################################
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("sheet")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("H").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "file delivery "
.Body = "Hi " & cell.Offset(0, -3).Value & " here is my file"
.Attachments.Add sNewFilePath
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Try .GetInspector before .Send. It would be like .Display without displaying.
I found a two step soultion. By changing .Send to .Display in the code above, the messages will be created as drafts in outlook and Displayed. If you do not want an extra window per e-mail, changing .Display to .Save will just put them in the draft folder.
Then I can use a macro written in Outlook to send all drafts. Code based on solution found at the mrexcel forums.
I also discovered after reading this answer on SO that the drafts folder can not be selected when running the macro.
Hope this helps others running into the same problem.
Public Sub SendDrafts()
Dim lDraftItem As Long
Dim myOutlook As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolders As Outlook.Folders
Dim myDraftsFolder As Outlook.MAPIFolder
'Send all items in the "Drafts" folder that have a "To" address filled in.
'Setup Outlook
Set myOutlook = Outlook.Application
Set myNameSpace = myOutlook.GetNamespace("MAPI")
Set myFolders = myNameSpace.Folders
'Set Draft Folder.
Set myDraftsFolder = myFolders("*******#****.com").Folders("Drafts")
'Loop through all Draft Items
For lDraftItem = myDraftsFolder.Items.Count To 1 Step -1
'Check for "To" address and only send if "To" is filled in.
If Len(Trim(myDraftsFolder.Items.Item(lDraftItem).To)) > 0 Then
'Send Item
myDraftsFolder.Items.Item(lDraftItem).Send
End If
Next lDraftItem
'Clean-up
Set myDraftsFolder = Nothing
Set myNameSpace = Nothing
Set myOutlook = Nothing
End Sub
Might be a good idea to add code that differntiates the messages you are trying to send from other drafts that may already be in the folder.
Would still prefere a one step solution, so I will wait with marking this as a solution.
I finally found the answer googling a lot.
The problem is not with the .send method, but rather the session object.
Replace Set myOutlook = Outlook.Application with
Set objOutlook = ThisOutlookSession
This ensures that your macro is using the same outlook session that is open. Atleast it did the trick for me
I'm creating an Outlook email from Excel (Office 2013). I want to paste a range of cells (C3:S52) into the email as a picture.
Below is the code I have so far. Where am I going wrong?
Sub Button193_Click()
'
' Button193_Click Macro
'
'
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("C3:S52").Select
Selection.Copy
End Sub
Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("E55")
Set rngSubject = .Range("E56")
Set rngBody = .Range("E57")
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Display 'Instead of .Display, you can use .Send to send the email _
or .Save to save a copy in the drafts folder
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub
Sub Button235_Click()
'
' Button235_Click Macro
'
'
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("A1:M27").Select
Selection.Copy
End Sub
Sub RunThemAll()
Application.Run "Button193_Click"
Application.Run "CreateMail"
End Sub
Here's a worked example, tested in Office 2010:
'Copy range of interest
Dim r As Range
Set r = Range("B2:D5")
r.Copy
'Open a new mail item
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim outMail As Outlook.MailItem
Set outMail = outlookApp.CreateItem(olMailItem)
'Get its Word editor
outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = outMail.GetInspector.WordEditor
'To paste as picture
wordDoc.Range.PasteAndFormat wdChartPicture
'To paste as a table
'wordDoc.Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
Result:
In the code above I used early binding to have access to autocomplete; to use this code you need to set references to the Microsoft Outlook and Microsoft Word object libraries: Tools > References... > set checkmarks like this:
Alternatively, you can forget about the references and use late binding, declaring all the Outlook and Word objects As Object instead of As Outlook.Application and As Word.Document etc.
Apparently you're having trouble implementing the above; the range pastes as a table rather than a picture in your email message. I have no explanation for why that would happen.
An alternative is then to paste as an image in Excel, and then cut and paste that image into your e-mail:
'Copy range of interest
Dim r As Range
Set r = Range("B2:D5")
r.Copy
'Paste as picture in sheet and cut immediately
Dim p As Picture
Set p = ActiveSheet.Pictures.Paste
p.Cut
'Open a new mail item
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim outMail As Outlook.MailItem
Set outMail = outlookApp.CreateItem(olMailItem)
'Get its Word editor
outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = outMail.GetInspector.WordEditor
'Paste picture
wordDoc.Range.Paste
As pointed out by WizzleWuzzle, there is also the option of using PasteSpecial instead of PasteAndFormat or Paste...
wordDoc.Range.PasteSpecial , , , , wdPasteBitmap
... but for some reason, the resulting image doesn't render as well. See how the lower table is kind of blurry:
I am providing an alternative solution to the above problem as Outlook.MailItem.GetInspector.WordEditor does not work in some organizational environments.
For security purposes, the HTMLBody, HTMLEditor, Body and WordEditor properties all are subject to address-information security prompts because the body of a message often contains the sender's or other people's e-mail addresses. And, if Group Policy does not permit then these prompts do not come on-screen. In simple words, as a developer, you are bound to change your code, because neither registry changes can be made nor group policy can be modified.
Hence, if your code suddenly stopped working after migrating to Office 365 or for any other reasons, please refer to the code below. Comments have been added for easy understanding and implementation.
If you have administrative rights then try the registry changes given at below link:
https://support.microsoft.com/en-au/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo
However, as developer, I recommend a code that's rather compatible with all versions of Excel instead of making system changes because system changes will be required on each end user's machine as well.
Code Compatible: Excel 2003, Excel 2007, Excel 2010, Excel 2013, Excel 2016, Office 365
Option Explicit
Sub Create_Email(ByVal strTo As String, ByVal strSubject As String)
Dim rngToPicture As Range
Dim outlookApp As Object
Dim Outmail As Object
Dim strTempFilePath As String
Dim strTempFileName As String
'Name it anything, doesn't matter
strTempFileName = "RangeAsPNG"
'rngToPicture is defined as NAMED RANGE in the workbook, do modify this name before use
Set rngToPicture = Range("rngToPicture")
Set outlookApp = CreateObject("Outlook.Application")
Set Outmail = outlookApp.CreateItem(olMailItem)
'Create an email
With Outmail
.To = strTo
.Subject = strSubject
'Create the range as a PNG file and store it in temp folder
Call createPNG(rngToPicture, strTempFileName)
'Embed the image in Outlook
strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
.Attachments.Add strTempFilePath, olByValue, 0
'Change the HTML below to add Header (Dear John) or signature (Kind Regards) using newline tag (<br />)
.HTMLBody = "<img src='cid:DashboardFile.png' style='border:0'>"
.Display
End With
Set Outmail = Nothing
Set outlookApp = Nothing
Set rngToPicture = Nothing
End Sub
Sub createPNG(ByRef rngToPicture As Range, nameFile As String)
Dim wksName As String
wksName = rngToPicture.Parent.Name
'Delete the existing PNG file of same name, if exists
On Error Resume Next
Kill Environ$("temp") & "\" & nameFile & ".png"
On Error GoTo 0
'Copy the range as picture
rngToPicture.CopyPicture
'Paste the picture in Chart area of same dimensions
With ThisWorkbook.Worksheets(wksName).ChartObjects.Add(rngToPicture.Left, rngToPicture.Top, rngToPicture.Width, rngToPicture.Height)
.Activate
.Chart.Paste
'Export the chart as PNG File to Temp folder
.Chart.Export Environ$("temp") & "\" & nameFile & ".png", "PNG"
End With
Worksheets(wksName).ChartObjects(Worksheets(wksName).ChartObjects.Count).Delete
End Sub
I am trying to create a Outlook VBA code to save attachments from a particular mail to a folder,then copy paste the data from the attachment in another excel.And then mail the 2nd excel to some ids.
I have created a rule 1st to move the incoming auto mail to a particular mail folder,Then save its attachment to the desktop folder.After saving the attachment the data gets copied to the 2nd excel. The code is like this
Public Sub ExportFile(MyMail As MailItem)
Dim outNS As Outlook.NameSpace
Dim outFolder As Outlook.MAPIFolder
Dim outNewMail As Outlook.MailItem
Dim strDir As String
Set outNS = GetNamespace("MAPI")
Set outFolder = outNS.GetDefaultFolder(olFolderInbox).Folders("Network Critical Report")
Set outNewMail = outFolder.Items.GetLast
strDir = "C:\Users\soumyajitd\Desktop\December\Network Critical Report\"
If outNewMail.Attachments.count = 0 Then GoTo Err
outNewMail.Attachments(1).SaveAsFile strDir & "Network_Critical_Report.csv"
Dim xlApp As Excel.Application
Dim wbTarget As Excel.Workbook 'workbook where the data is to be pasted
Dim wsTarget As Excel.Worksheet
Dim wbThis As Excel.Workbook 'workbook from where the data is to copied
Dim wsThis As Excel.Worksheet
Dim strName As String 'name of the source sheet/ target workbook
Set xlApp = New Excel.Application
xlApp.DisplayAlerts = False
'xlApp.Workbooks.Open strDir & "Network_Critical_Report.csv"
'xlApp.Workbooks.Open strDir & "Test.xlsx"
Set wbThis = xlApp.Workbooks.Open("C:\Users\soumyajitd\Desktop\December\Network Critical Report\Network_Critical_Report.csv")
Set wsThis = wbThis.Worksheets("Network_Critical_Report")
Set wbTarget = xlApp.Workbooks.Open("C:\Users\soumyajitd\Desktop\December\Network Critical Report\Test.xlsx")
Set wsTarget = wbTarget.Worksheets("Raw_Data")
'select cell A1 on the target book
'clear existing values form target book
wsTarget.UsedRange.ClearContents
'activate the source book
wbThis.Activate
xlApp.CutCopyMode = False
'copy the range from source book
wsThis.UsedRange.Copy
'paste the data on the target book
wsTarget.Range("A1").PasteSpecial Paste:=xlPasteValues
'save the target book
wbTarget.Save
'close the workbook
wbTarget.Close
wbThis.Close
xlApp.CutCopyMode = False
Kill ("C:\Users\soumyajitd\Desktop\December\Network Critical Report\Network_Critical_Report.csv")
'clear memory
Set wbTarget = Nothing
Set wbThis = Nothing
Set xlApp = Nothing
Set outNewMail = Nothing
Set outFolder = Nothing
Set outNS = Nothing
Err:
Set outFolder = Nothing
Set OuNewMail = Nothing
Set outNS = Nothing
End Sub
The second code is to send a new email with "Test.xlsx" as attachment.It is like this :
Sub SendNew(Item As Outlook.MailItem)
Dim objMsg As MailItem
Dim ToRecipient As Variant
Dim ccRecipient As Variant
Dim Subject As String
Dim Body As String
Dim FilePathtoAdd As String
Set objMsg = Application.CreateItem(olMailItem)
objMsg.ToRecipients.Add "alias#mail.com"
objMsg.CCRecipients.Add "xx#yy.com"
objMsg.Subject = "Subject"
objMsg.Body = "Body"
If FilePathtoAdd <> "" Then
objMsg.Attachments.Add "C:\Users\soumyajitd\Desktop\December\Network Critical Report\Test.xlsx"
End If
objMsg.Send
I have very little experience in VBA coding.I have taken all these codes from different forums and have modified them to suit my need.
Now there are 3 problems.
The attachment which is getting saved is not from the last mail,it is taking the data from the 2nd last mail.
I am trying to run the script by adding rule for receiving mail,but it is showing only the 2 different scripts. I tried many ways but couldnot combine both of them.
The 2nd script is not working,giving an error "Runtime error '-2147467259(8004005)':
"Outlook doesnot recongnize 1 or more names"
For your 1st Problem, see THIS
For your 2nd Problem
To combine, either join both the scripts in one SUB or call the other from the first.
For your 3rd Problem
There is no property called .ToRecipients and .CCRecipients. Change it to objMsg.To = "alias#mail.com" and objMsg.CC = "xx#yy.com" respectively.
Also your FilePathtoAdd = "" so your if condition is not met. Either delete that IF Condition or change your code to this
FilePathtoAdd = "C:\Users\soumyajitd\Desktop\December\Network Critical Report\Test.xlsx"
With objMsg
.To = "alias#mail.com"
.CC = "xx#yy.com"
.Subject = "Subject"
.Body = "Body"
.Attachments.Add FilePathtoAdd
End With