I want to view the source of an outlook mail and save it as an HTML file. But the mailItem.HTMLBody is not giving me full source, it is truncated in the mid.
Set app = CreateObject("Outlook.Application")
Set nameSpace = app.GetNamespace("MAPI")
Set MyFolders = nameSpace.GetDefaultFolder(6)
'Read unread items in Inbox
Set cols = MyFolders.Items
dim a
For each mail In cols
If mail.unread Then
a = mail.HTMLbody
msgbox a
End If
Next
'MSgbox a doesn't show full html source*
The .HTMLbody property is complete. It's MsgBox() that truncates the string.
Save it to file, just as you originally intended.
Set FSO = CreateObject("Scripting.FileSystemObject")
' ...
For Each mail In cols
If mail.unread Then
With FSO.CreateTextFile("C:\Temp\messagebody.html", True, True)
.Write mail.HTMLbody
.Close
End With
End If
Next
If you plan on using the message subject as the filename, make sure that you replace all characters that are invalid in filenames and that you the check overall path length limit (~255 characters).
The FileSystemObject is documented here: https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/createtextfile-method
Related
This question already has answers here:
VBScript to send email without running Outlook
(2 answers)
Closed 3 years ago.
I want to select files within Windows Explorer and then by pressing a shortcut (assigned to a VBS-script) to send these files with Outlook (2010).
I found two working code snippets:
Code snippet1 (Creating Email):
Dim objOutl
Set objOutl = CreateObject("Outlook.Application")
Set objMailItem = objOutl.CreateItem(olMailItem)
'comment the next line if you do not want to see the outlook window
objMailItem.Display
strEmailAddr = "test#test.com"
objMailItem.Recipients.Add strEmailAddr
objMailItem.Body = "Hi, this is the body.."
objMailItem.Attachments.Add "C:\test.txt"
'objMailItem.Send
Set objMailItem = nothing
Set objOutl = nothing
Code snippet2 (returning paths of the selected files in Windows Explorer):
Function GetSelectedFiles() 'Returns paths as array of strings
Dim FileList, Window, SelectedItem
'avoid duplicates by storing paths in dictionary keys
Set FileList = CreateObject("Scripting.Dictionary")
With CreateObject("Shell.Application")
For Each Window In .Windows
'skip IE Windows
If InStr(1, Window.FullName, "iexplore.exe", vbTextCompare) = 0 Then
For Each SelectedItem In Window.Document.SelectedItems
FileList(SelectedItem.Path) = Null
'MsgBox SelectedItem.Path
Next
End If
Next
End With
GetSelectedFiles = FileList.Keys 'array of paths
End Function
MsgBox "Click OK after selecting the items", vbOKOnly Or vbInformation, "Select a few items"
Dim SelectedFiles
SelectedFiles = GetSelectedFiles
MsgBox "You selected: " & vbNewLine & vbNewLine & Join(SelectedFiles, vbNewLine), vbOKOnly Or vbInformation, "Selected Items"
How to combine these code snippets to achieve my purpose? I tried to give the SelectedItem.Path a variable to add it to the objMailItem.Attachments.Add but it is not working.
I tried the cdo approach but this issue seems to be more complex. I have an office365-account and the configuration settings seems to differ from VBScript to send email without running Outlook.
Yesss I got it working and it is very cool, I love it :-)
Dim x ,objOutl ,objMailItem ,strEmailAddr
Set objOutl = CreateObject("Outlook.Application")
Set objMailItem = objOutl.CreateItem(olMailItem)
'comment the next line if you do not want to see the outlook window
objMailItem.Display
strEmailAddr = "test#test.com"
objMailItem.Recipients.Add strEmailAddr
objMailItem.Subject = "Test"
objMailItem.Body = "Hi, this is the body.."
'in the next line it will jump in to function "GetSelectedFiles"
x=GetSelectedFiles
'comment out the next three lines for sending directly..
'objMailItem.Send
'Set objMailItem = nothing
'Set objOutl = nothing
Function GetSelectedFiles() 'Returns paths as array of strings
Dim FileList, Window, SelectedItem
'avoid duplicates by storing paths in dictionary keys
Set FileList = CreateObject("Scripting.Dictionary")
With CreateObject("Shell.Application")
For Each Window In .Windows
'skip IE Windows
If InStr(1, Window.FullName, "iexplore.exe", vbTextCompare) = 0 Then
For Each SelectedItem In Window.Document.SelectedItems
FileList(SelectedItem.Path) = Null
x = SelectedItem.Path
'next line is just for debugging..
'msgBox x
'The next line was the solution
objMailItem.Attachments.Add x
Next
End If
Next
End With
GetSelectedFiles = x 'array of paths
End Function
I am developing a script to send an email according to certain inputs, I am able to craft the email but not send it using the .Send method.
I am getting the following error: (please note that the line is matching the .Send use in the original case)
I have already successfully sent emails using the .SendKeys(^~) method, but I would like to be use Outlook object to do so and not simply send shortcuts.
This is my current code:
' Declare all variables that will be used later on
Dim outobj, mailobj, emailto, cc, subject, body, attachement
Dim strFileText
Dim objFileToRead
Dim splitEmailto
' Set the outlook application object
Set outobj = CreateObject("Outlook.Application")
' set the namespace
Set myNamespace = outobj.GetNameSpace("MAPI")
msgbox myNamespace.Folders(2)
' Set the mail item object
Set mailobj = outobj.CreateItem(olMailItem)
' Set a shell
Set WshShell = WScript.CreateObject("WScript.shell")
' Get all the argument and assign
emailto = "name#domain.eu"
cc = "name#domain.eu"
subject = "Simple Email"
body = "Some Text"
attachement = "C:\Users\name\Desktop\fileName.xls"
' Craft the email object
With mailobj
.Display
' assign the tos
.To = cstr(emailto)
' add CCs
.CC = cstr(cc)
' attach the relevant files
If attachement <> "" Then
If instr(attachement, ";") Then
splitAtt = split(attachement, ";")
For Each att In splitAtt
If att <> "" Then
.Attachments.add cstr(att)
End If
Next
Else
.Attachments.add cstr(attachement)
End If
End If
If Subject <> "" Then
.Subject = Subject ' sets the subject
End If
If body <> "" Then
.Body = body ' sets the body
End If
.Send
End With
' Clear the memory
Set outobj = Nothing
Set mailobj = Nothing
' check for no more events in the sending event
' Report out & Quits
WScript.StdOut.WriteLine("Email sent")
WScript.Quit
I would like to be able to send the email with the .Send. any idea?
The error is E_ABORT.
Why are you displaying the message and immediately calling Send? You either display the message (Display, but no Send), or just send it outwith displaying (Send, but no Display).
Being I'm a novice at VBS, I'm have a hard time determining why this short script is not returning a column count of 193, One time I'll get the correct count and others I get 0.
Thank you in advance for any and all suggestions.
OldCityCat
Sub VerifyOrders
Dim Results
Dim objFSO, objTextFile, objReadFile, Contents, objFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.GetFile("C:\TestFileWith_194_characters.csv")
Set objTextFile = objFSO.OpenTextFile("C:\TestFileWith_194_characters.csv")
Set objReadFile = objFSO.OpenTextFile("C:\TestFileWith_194_characters.csv",1)
objReadFile.ReadAll
Contents = objReadFile.Column -1
WScript.Echo Contents
If Contents < 194 Then
Results = "No Orders"
Else
Results = "Has Orders"
End if
objReadFile.Close
If Results = "No Orders" Then
Call NoOrders
Else
Call OpenAccess
End If
End Sub
'/ If no orders the send email end script. Else If orders process them
Sub NoOrders
If Results = "No Orders" Then
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
objMail.Display
objMail.Recipients.Add ("gchichester#wilk.us.com")
objMail.Subject = "No Sales Orders to Process"
objMail.Body = "Respect didn't receive any orders for Pine Castle"
objMail.Send
objOutlook.Quit
Set objMail = Nothing
Set objOutlook = Nothing
End If
End Sub
Sub OpenAccess
Set WshShell = WScript.CreateObject("WScript.Shell")
WshShell.Exec("C:\Program Files (x86)\Microsoft Office\Office14\MSACCESS.EXE "&" C:\DropBox\Inflow\DrugSales.accdb /x OnOpen")
WScript.Sleep 60000
WshShell.SendKeys "%{F4}"
End Sub
You are getting 0 when the contents of the text file you're reading from has written a newline character, but nothing else.
From the Microsoft documentation:
After a newline character has been written, but before any other character is written, Column is equal to 1.
Throughly examine the contents of the text file before you attempt to read it in as a text stream.
Of note but not relevant to my answer above: you do not need to declare or set objFile or objTextFile since you are using objReadFile. Suggest removing both the declaration and set operations for both of those variables.
I'm using the following function in my VBScript to copy a string onto the clipboard without the use of the external clip command (which isn't and cannot be installed due to security policies):
Function CopyToClipboard(sText)
Dim oWord : Set oWord = CreateObject("Word.Application")
With oWord
.Visible = False
.Documents.Add
.Selection.TypeText sText
.Selection.WholeStory
.Selection.Copy
.Quit False
End With
Set oWord = Nothing
End Function
The problem is that the string being copied comes with the standard formatting inherited by the "normal.dot" template.
Given that I have Word 2003, this formatting is Times New Roman, 12pt and in black. So when it gets pasted into an email or document, the formatting doesn't match with the existing content.
Is there any way to remove the formatting on the string in the clipboard?
After playing around a bit, I developed a solution that doesn't use the Word object model, but does copy unformatted text to the clipboard - which is what I needed to do:
Function CopyToClipboard(sText)
' Create temporary text file to avoid IE clipboard warnings
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim sTemp : sTemp = fso.GetSpecialFolder(2) & "\" & fso.GetTempName
Dim oFile : Set oFile = fso.CreateTextFile(sTemp, True)
oFile.Write "This file can be safely deleted"
oFile.Close
Set oFile = Nothing
' Start Internet Explorer in the local zone
Dim oIE : Set oIE = CreateObject("InternetExplorer.Application")
oIE.Visible = 0
oIE.Navigate2 sTemp
Do
WScript.Sleep 100
Loop Until oIE.Document.ReadyState = "complete"
' Copy contents to clipboard
oIE.Document.ParentWindow.ClipboardData.SetData "text", sText
' Clean up
fso.DeleteFile sTemp
Set oIE = Nothing
Set fso = Nothing
End Function
This code uses Internet Explorer's ability to access the clipboard in order to paste in the contents of sText. You'll notice that about:blank isn't used as the starting page and this is because it will generate the following warning:
In order to get around this we create a temporary file locally (with some copy to indicate that it is benign) and then navigate to this file. As a result Internet Explorer treats this page in the "Local Intranet" zone and allows access to the clipboard without generating a pop-up confirmation.
I need a method to check the contents of the text entered to make sure they are correctly entering a folder path. So it needs to be in the format of:
Drive Letter :\ Folder
e.g. C:\My Documents
If they haven't typed in that format I need to stop and show a message telling them to double check.
I have tried the Filter function but I haven't quite got it to work. Any help would be awesome. I don't have any code to show because I am nto sure where to start.
I also tried the common dialog, but the user jsut needs the type the path, not select the file. All I want to check is if the text type is within that format DRIVE:\FOLDER, that is it. So if the type "BLAH" in the text bax a message says Hey you type a correct path.
In VB6, to test whether your text contains a valid folder:
If Len(Dir("c:\My Documents", vbDirectory))>0 Then
'it's a folder
End If
Have you thought of implemeting the common dialog control to allow the selection of a correct folder instead - it'll be much more likely to be accurate.
Some example code of folder browsing from here:
Private Sub Command1_Click()
On Error Resume Next
Const WINDOW_HANDLE = 0
Const NO_OPTIONS = 0
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, "select folder:", NO_OPTIONS, "C:Scripts")
Set objFolderItem = objFolder.Self
objPath = objFolderItem.Path
objPath = Replace(objPath, "", "\")
Print objPath
End Sub
Alternatively you could validate the folder first you could check for ":\" using eith instr or mid
then you could validate the folder and even include an option to create it if not present with the filesystemobject (needs a reference set) here it is in function form, you can pass the contents of the textbox for validation.
Function DirExists(pFile As String, Optional pCreate As Boolean = False)
'
Dim fso As New FileSystemObject
Dim vPath As Variant
Dim sPath As String
Dim y As Variant
DirExists = False
If fso.FolderExists(pFile) Then
DirExists = True
Else
If pCreate Then
vPath = Split(pFile, "\")
For Each y In vPath
sPath = sPath & y & "\"
If Not fso.FolderExists(sPath) Then
fso.CreateFolder (sPath)
If fso.FolderExists(pFile) Then
DirExists = True
Exit Function
End If
End If
Next
End If
End If
End Function