I would like to add all excel files in a folder to an email with the following code:
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
Set MItem = OutlookApp.CreateItem(olMailItem)
MItem.Display
With MItem
.Bcc = EmailAddr
.Subject = Subj
.Body = Msg
For Each File In fs.GetFolder(CurDir&"Final").Files
If fs.GetExtensionName(File) = "xlsx" Then
.Attachments.Add File
End If
Next
.Importance = 2
.Send
End With
Set MItem = Nothing
Set OutlookApp = Nothing
Set fso = Nothing
However, I am getting error "Object doesn't support this property or method.
While as I attach individual files it's working.
Is there anything I am missing? Thanks in advance for the help!
Related
Please help to automate the process which consists of 2 Subs:
Import - I need to make Silent import without target & destination folder selection dialog.
I need to import to my "INBOX/Imported" subfolder in Outlook and want to understand where in this code I can mention it explicitly.
I need to grab .EML files from the folder "D:\Emails" without redundant dialogue for folder selection:
Sub Redemp()
Dim objShell: Set objShell = CreateObject("Shell.Application")
Dim objFolder: Set objFolder = objShell.BrowseForFolder(0, "Select the folder containing eml-files", 0)
Dim Item
If (Not objFolder Is Nothing) Then
Set WShell = CreateObject("WScript.Shell")
Set objOutlook = CreateObject("Outlook.Application")
Set Folder = objOutlook.Session.PickFolder
If Not Folder Is Nothing Then
For Each Item In objFolder.Items
If Right(Item.name, 4) = ".eml" And Item.IsFolder = False Then
Set objPost = Folder.Items.Add(6)
Set objSafePost = CreateObject("Redemption.SafePostItem")
objSafePost.Item = objPost
objSafePost.Import Item.Path, 1024
objSafePost.MessageClass = "IPM.Note"
' remove IPM.Post icon
Set utils = CreateObject("Redemption.MAPIUtils")
PrIconIndex = &H10800003
utils.HrSetOneProp objSafePost, PrIconIndex, 256, True 'Also saves the message
End If
Next
End If
End If
MsgBox "Import completed.", 64, "Import EML"
Set objFolder = Nothing
Set objShell = Nothing
End Sub
Also, it would be great to avoid imported messages appearing in Outlook as if I already started replying to (not very convenient). If I use the above code and select imported message it doesn't look like originally received, but rather looks like text that I reply to.
I need to unify the below code that corrects ReceivedTime property of imported message (or it can modify EML file before import, sequence of actions is not important) with above import procedure.
Sub Redemp_sentreceived()
Set rSession = CreateObject("Redemption.RDOSession")
rSession.MAPIOBJECT = Application.Session.MAPIOBJECT
Set Msg = rSession.GetRDOObjectFromOutlookObject(Application.ActiveExplorer.CurrentFolder)
For Each Item In Msg.Items
Item.ReceivedTime = Item.SentOn
Item.Save
Next
End Sub
Ultimately imported .EML files should be in target folder with correct ReceivedTime.
Many thanks for helping me out in advance!
There is really no reason to use Safe*Item objects in this case - use RDOSession object, set the MAPIOBJECT property just like you do in the second example.
Off the top of my head:
Set rSession = CreateObject("Redemption.RDOSession")
rSession.MAPIOBJECT = Application.Session.MAPIOBJECT
Set folder = rSession.GetDefaultFolder(plFolderInbox).Folders.Items("Imported")
Set fileFolder = objFSO.GetFolder("D:\Emails")
For Each objFile in fileFolder.Files
set msg = folder.Items.Add("IPM.Note")
msg.Sent = true
msg.Import objFile.Path, 1031
msg.Save
Next
The problem was in number pointed in Import (I changed 1031 -> 1024) and now it works like a charm!
Sub MailImport()
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set rSession = CreateObject("Redemption.RDOSession")
rSession.MAPIOBJECT = Application.Session.MAPIOBJECT
Set Folder = rSession.GetDefaultFolder(olFolderInbox)
Set fileFolder = objFSO.GetFolder("D:\Emails")
For Each objFile In fileFolder.Files
Set msg = Folder.Items.Add("IPM.Note")
msg.sent = True
msg.Import objFile.Path, 1024
msg.ReceivedTime = msg.SentOn
msg.Save
objFile.Delete
Next
Set objFSO = Nothing
End Sub
Set MyApp = CreateObject("Outlook.Application")
Set MyItem = MyApp.CreateItem(0) 'olMailItem
With MyItem
.To = Vdistro
.CC = Vregion
.Subject = Vsubject
.AddAttachment "C:\VzW\Ankur.txt"
.HTMLBody = EmailComments & EmailBody & "<br><b>Regards,</b>" + mysignature
'.Importance = Vimportance
'.FlagStatus = Vflagstatus
on above code everything working except attachment. I have also tried MyApp..AddAttachment "C:\VzW\Ankur.txt" but no luck.
The line
.AddAttachment "C:\VzW\Ankur.txt"
must be
.Attachments.Add "C:\VzW\Ankur.txt"
I bet you have On Error Resume Next somewhere. Please remove it - it masks all problems in your code.
Thanks for your help in advance.
I am running a VbScript(code below) to edit a .csv file and save it as another file, however, I keep getting the following error:
Line: 30 Char: 1 Error: SaveAs method of Workbook class failed Code: 800A03EC
Dim xlApp, xlWkb, xlSh, SourceFolder, TargetFolder, file
Dim str, strClean
Dim cell
Set xlApp = CreateObject("excel.application")
Set fs = CreateObject("Scripting.FileSystemObject")
SourceFolder="I:\Documents\Rajarshi_SVN Repositorywc\Global Fund Services - Long Funds\02_Funds STP\02_Funds STP Phase 1\03_Test scripts\04_Test data\CSV - Chk"
TargetFolder="I:\Documents\Rajarshi_SVN Repositorywc\Global Fund Services - Long Funds\02_Funds STP\02_Funds STP Phase 1\03_Test scripts\04_Test data\CSV - New"
xlApp.visible = false
For Each file in fs.GetFolder(SourceFolder).files
Set xlWkb = xlApp.Workbooks.Open(file)
BaseName = fs.getbasename(file)
Set xlSh = xlWkb.Worksheets(1)
For Each cell in xlSh.Range("A2:XFD2")
With CreateObject("vbscript.regexp")
.Pattern = "[\/[0-9a-zA-Z]*\/]*"
.Global = True
cell = .Replace(cell, vbNullString)
End With
Next
FullTargetPath=TargetFolder & "\" & BaseName & ".csv"
xlWkb.SaveAs FullTargetPath, xlCSV, , , , , , 2
xlWkb.Saved = True
xlWkb.Close
Set xlSh = Nothing
Set xlWkb = Nothing
Next
Set xlApp = Nothing
Set fs = Nothing
MsgBox "XML Files headers converted successfully"
I am okay even if I am able to simply save the file.
How can I get this script to load the contents of a HTML file and send it as the email body.
I keep getting an error that says
Line 8
Invalid procedure call or argument
Code: 800A0005
I have tried that and it works thanks.
But when it reads the htm file the script breaks because there are more than one “ in the file.
I am getting this error
Line: 13
Object doesn't support this property or method: 'objEmail.CreateMHTMLBody'
code: 800A01B6
What can I do to fix it.
Dim fso
Set objEmail = CreateObject("CDO.Message")
objEmail.From = "user#Example.com"
objEmail.Subject = "Test Email"
Const ForReading=1
Set fso = CreateObject("Scripting.FileSystemObject")
Set dict = CreateObject("Scripting.Dictionary")
BodyText = fso.OpenTextFile("C:\Users\user\Desktop\Email.htm",ForReading).ReadAll
objEmail.CreateMHTMLBody = BodyText
objEmail.AddAttachment "C:\Users\user\Desktop\test.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
Set dict = CreateObject("Scripting.Dictionary")
Set file = fso.OpenTextFile ("C:\Users\user\Desktop\address.txt", 1)
row = 0
Do Until file.AtEndOfStream
line = file.Readline
dict.Add row, line
row = row + 1
objEmail.To = line
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = _
"127.0.0.1"
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objEmail.Configuration.Fields.Update
objEmail.Send
Loop
Set statement assigns an object reference to a variable or property;
ReadAll method reads an entire TextStream file and returns the resulting string.
Hence, next code snippet should work:
Const ForReading=1
Set fso = CreateObject("Scripting.FileSystemObject")
Set dict = CreateObject("Scripting.Dictionary")
BodyText = fso.OpenTextFile("C:\Users\user\Desktop\Email.htm",ForReading).ReadAll
' superabundant Set fso = CreateObject("Scripting.FileSystemObject")
' superabundant Set dict = CreateObject("Scripting.Dictionary")
Set file = fso.OpenTextFile ("C:\Users\user\Desktop\address.txt", 1)
' …
'
objEmail.Subject = "Test Email"
objEmail.HtmlBody = BodyText
'…
Please read Paul R. Sadowski's article VBScript To Send Email Using CDO. There is a hint how to send a webpage from a file on your machine using CreateMHTMLBody method instead of setting HTMLBody property.
We want to upgrade our VB6 code to use Outlook 2010, but we're getting the following error:
Active x cannot create object
This is our current code:
Public Sub SendEmail()
Set emailOutlookApp = CreateObject("Outlook.Application.12")
Set emailNameSpace = emailOutlookApp.GetNamespace("MAPI")
Set emailFolder = emailNameSpace.GetDefaultFolder(olFolderInbox)
Set emailItem = emailOutlookApp.CreateItem(olMailItem)
Set EmailRecipient = emailItem.Recipients
EmailRecipient.Add (EmailAddress)
EmailRecipient.Add (EmailAddress2)
emailItem.Importance = olImportanceHigh
emailItem.Subject = "My Subject"
emailItem.Body = "The Body"
'-----Send the Email-----'
emailItem.Save
emailItem.Send
'-----Clear out the memory space held by variables-----'
Set emailNameSpace = Nothing
Set emailFolder = Nothing
Set emailItem = Nothing
Set emailOutlookApp = Nothing
Exit Sub
I'm not sure if "Outlook.Application.12" is correct. But I can't find a definitive answer for this.
For Outlook 2010, this is definitly corect Outlook.Application.14.
But, I don't know what about office 2007.
I think it's Outlook.Application.12 and for lower versions it is simply "Outlook.Application".
Here's the code I switched to for 2010:
Private Sub EmailBlahbutton_Click()
Dim mOutlookApp As Object
Dim OutMail As Object
Dim Intro As String
On Error GoTo ErrorHandler
Set mOutlookApp = GetObject("", "Outlook.application")
Set OutMail = mOutlookApp.CreateItem(0)
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'These are the ranges being emailed.
ActiveSheet.Range(blahblahblah).Select
'Intro is the first line of the email
Intro = "BLAHBLAHBLHA"
'Set the To and Subject lines. Send the message.
With OutMail
.To = "blahblah#blah.com"
.Subject = "More BLAH here"
.HTMLBody = Intro & RangetoHTML(Selection)
.Send
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
ActiveSheet.Range("A1").Select
ActiveWindow.ScrollColumn = ActiveCell.Column
ActiveWindow.ScrollRow = ActiveCell.Row
Set OutMail = Nothing
Set mOutlookApp = Nothing
Exit Sub
ErrorHandler:
Set mOutlookApp = CreateObject("Outlook.application")
Resume Next
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Why do you explicitly specify the version? Why not simply
Set emailOutlookApp = CreateObject("Outlook.Application")
Try "Outlook.Application.14". Not sure if this is related though: 2007 to 2010 upgrade issue
I realize it's not the exact issue, but it may lead you down the right path.