I am trying to send mail in a particular time with task scheduler on windows.
The output I have in body is not what I expect and does not give a newline.
Is there any way to control the format of the output?
<%#LANGUAGE="VBSCRIPT" CODEPAGE="CP65001"%>
Const MSG_RECIPIENT_LIST = "foor#bar.com"
Const MSG_SUBJECT = "力"
Const MSG_BODY = "これをやろう" + vbNewLine + "我々は一緒に大きなものを達成する"
Dim olkApp, olkSes, olkMsg
Set olkApp = CreateObject("Outlook.Application")
Set olkSes = olkApp.GetNamespace("MAPI")
olkSes.Logon olkApp.DefaultProfileName
Set olkMsg = olkApp.CreateItem(0)
With olkMsg
.To = MSG_RECIPIENT_LIST
.Subject = MSG_SUBJECT
.HTMLBody = MSG_BODY
.Send
End With
olkSes.Logoff
Set olkMsg = Nothing
Set olkSes = Nothing
Set olkApp = Nothing
Related
This code is working well as long as every file is there.
What is missing in the code for sending an email even if a file is missing?
I have tried to find a solution but without success.
Set fso=CreateObject("Scripting.FileSystemObject")
strSMTP="smtp.telenor.no"
strSubject="Files form me to you"
strSubject="XXXXX"
strSubject="XXXX"
strBody="XXXXXX"
strAttach="File 1.csv"
strAttach1="File 2.csv"
strAttach2="File 3.csv"
If fso.FileExists(strAttach) then
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTP
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
With iMsg
Set .Configuration = iConf
.To = "XXXX"
.CC = ""
.BCC = ""
.From = "XXXX"
.Subject = strSubject
.TextBody = strBody
.AddAttachment strAttach
.AddAttachment strAttach1
.AddAttachment strAttach2
.Send
End With
Set iMsg = Nothing
Set iConf = Nothing
Else
MsgBox "The specified attachment does not exist"
End if
The following uses an ArrayList to hold your attachments and adds them to the message one by one, checking if the file exists first:
Dim iCounter
Dim sAttachment
Dim objAttachments
Set objAttachments = CreateObject("System.Collections.ArrayList")
objAttachments.Add "File 1.csv"
objAttachments.Add "File 2.csv"
objAttachments.Add "File 3.csv"
Set objFSO = CreateObject("Scripting.FileSystemObject")
strSMTP = "smtp.telenor.no"
strSubject = "Files form me to you"
strSubject = "XXXXX"
strSubject = "XXXX"
strBody = "XXXXXX"
' Create message and configuration
Set objMessage = CreateObject("CDO.Message")
Set objConf = CreateObject("CDO.Configuration")
objConf.Load -1 ' CDO Source Defaults
Set objFields = objConf.Fields
With objFields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTP
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
' Initalize message
With objMessage
Set .Configuration = objConf
.To = "XXXX"
.CC = ""
.BCC = ""
.From = "XXXX"
.Subject = strSubject
.TextBody = strBody
End With
' Add attachments
For iCounter = 1 To objAttachments.Count
sAttachment = objAttachments.Item(iCounter - 1)
If objFSO.FileExists(sAttachment) Then objMessage.AddAttachment sAttachment
Next
' Send Message
objMessage.Send
I'm writing a VBScript to send email notification when a file arrives in Test folder. I want to attach that file to my email. The file name is not constant. Each time a file arrives with different name.
Below is my code:
Const PATH = "F:\Test"
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
Dim folder: Set folder = fso.GetFolder(PATH)
If folder.Files.Count <> 0 Then
strSMTPFrom = "errorfile#test.com"
strSMTPTo = "test#test.com"
strSMTPRelay = "127.0.0.1"
strTextBody = "The attached file arrived in Test folder"
strSubject = "File arrived in Test folder"
strAttachment =
Set oMessage = CreateObject("CDO.Message")
oMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
oMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTPRelay
oMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
oMessage.Configuration.Fields.Update
oMessage.Subject = strSubject
oMessage.From = strSMTPFrom
oMessage.To = strSMTPTo
oMessage.TextBody = strTextBody
oMessage.AddAttachment strAttachment
oMessage.Send
End If
I'd say what you actually want is a filesystem monitor. Something like this:
Sub SendNotification(filename)
'your mail sending code goes here
End Sub
Function CreateMonitor(path)
Set wmi = GetObject("winmgmts://./root/cimv2")
Set fso = CreateObject("Scripting.FileSystemObject")
path = Split(fso.GetAbsolutePathName(path), ":")
drv = path(0) & ":"
dir = Replace(path(1), "\", "\\")
If Right(dir, 2) <> "\\" Then dir = dir & "\\"
query = "SELECT * FROM __InstanceOperationEvent" & _
" WITHIN 1" _
" WHERE Targetinstance ISA 'CIM_DataFile'" & _
" AND TargetInstance.Drive=""" & drv & """" & _
" AND TargetInstance.Path=""" & dir & """"
Set CreateMonitor = wmi.ExecNotificationQuery(query)
End Function
Set monitor = CreateMonitor("F:\Test")
Do
Set evt = monitor.NextEvent()
If evt.Path_.Class = "__InstanceCreationEvent" Then
SendNotification evt.TargetInstance.Name
End If
Loop
The Name property of the TargetInstance object contains the full path to the new file. Put your mail sending code into the SendNotification function and have it attach filename to the mail.
To find the newest file in a folder, use this code:
Const PATH = "F:\Test"
dim fso: set fso = CreateObject("Scripting.FileSystemObject")
dim myFolder: set myFolder = fso.getFolder(PATH)
dim myFile
dim recentFile
For Each myFile in myFolder.Files
If (isempty(recentFile)) Then
Set recentFile = myFile
ElseIf (myFile.DateLastModified > recentFile.DateLastModified) Then
Set recentFile = myFile
End If
Next
Then just use its path to attach the file.
strAttachment = recentFile.path
I got some script to convert string to base64 and write encoded data to text file that's all goes fine and result stored in encoded.txt but I need each line to be double quoted at the start and '& _' with double quotes at the end so how to make this script do that automatically for each line? here is my script
Option Explicit
Const fsDoOverwrite = true
Const fsAsASCII = false
Const adTypeBinary = 1
Dim objFSO
Dim objFileOut
Dim objXML
Dim objDocElem
Dim objStream
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = adTypeBinary
objStream.Open()
objStream.LoadFromFile(Wscript.scriptfullname)
Set objXML = CreateObject("MSXml2.DOMDocument")
Set objDocElem = objXML.createElement("Base64Data")
objDocElem.dataType = "bin.base64"
objDocElem.nodeTypedValue = objStream.Read()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFileOut = objFSO.CreateTextFile("encoded.txt", fsDoOverwrite, fsAsASCII)
objFileOut.Write objDocElem.text
objFileOut.Close()
Set objFSO = Nothing
Set objFileOut = Nothing
Set objXML = Nothing
Set objDocElem = Nothing
Set objStream = Nothing
Sub encodeFileBase64( inputFile, outputFile )
Const fsDoOverwrite = True
Const fsAsASCII = False
Const adTypeBinary = 1
Dim stream, strBuffer
Set stream = WScript.CreateObject("ADODB.Stream")
With stream
.Type = adTypeBinary
.Open
.LoadFromFile inputFile
End With
With WScript.CreateObject("MSXML2.DOMDocument").CreateElement("Base64Data")
.dataType = "bin.base64"
.nodeTypedValue = stream.Read()
strBuffer = .Text
End With
stream.Close
With New RegExp
.Multiline = True
.Global = True
.IgnoreCase = False
.Pattern = "[\r\n]+(?=[0-9A-Za-z])"
strBuffer = Chr(34) & .Replace(strBuffer, Chr(34) & " & _" & vbCrLf & Chr(34) ) & Chr(34)
End With
WScript.CreateObject("Scripting.FileSystemObject").CreateTextFile( outputFile, fsDoOverwrite, fsAsASCII ).Write strBuffer
End Sub
encodeFileBase64 WScript.ScriptFullName, WScript.ScriptFullName & ".b64"
This will use a regular expression object to replace all intermediate line endings with the adecuated line termination/start and two aditional quotes, one at the start and one at the end.
Split the text by a line break, then loop through and put it all back together while you add the quotes. (not tested, but probably close, code follows; there is a strong chance you'll need to find the right type of line feed for your situation - I picked vbCr as an example):
allTextArray = SPLIT(originalText, vbCr)
For i=0 to UBound(allTextArray)
allTextWithQuotes = allTextWithQuotes & """" & allTextArray(i) & """"
Next
set cdoConfig = CreateObject("CDO.Configuration")
with cdoConfig.Fields
.Item(cdoSendUsingMethod) = cdoSendUsingPort
.Item(cdoSMTPServer) = "localhost"
.Item(cdoSMTPAuthenticate) = 1
.Item(cdoSendUsername) = "contact#example.com"
.Item(cdoSendPassword) = "password"
.Update
end with
set cdoMessage = CreateObject("CDO.Message")
with cdomessage
set .Configuration = cdoConfig
.From = "contact#example.com"
.To = email
.Subject = subject
.HTMLBody = message
.AddAttachment "c:/i/report.pdf"
.Send
end with
set cdomessage = nothing
set cdoconfig = nothing
Everything sends find, but the recipient gets the message as "Untitled Attachment 000X.pdf"
How do I give the attachment a name?
I have something like this. But never tried.
'With cdomessage
.AddAttachment "c:/i/report.pdf"
.Attachments(1).Fields.Item("urn:schemas:mailheader:content-disposition") ="attachment;filename=" & NEWNAME
.Attachments(1).Fields.Update
'End With
I have set this up to auto email through the Outlook client, is it possible to change this code to work directly through an SMTP server? And could anyone possibly help me do it?
Any help would be much appreciated, thanks!
Set app = CreateObject("Excel.Application")
Set fso = CreateObject("Scripting.FileSystemObject")
For Each f In fso.GetFolder("Y:\Billing_Common\autoemail").Files
If LCase(fso.GetExtensionName(f)) = "xls" Then
Set wb = app.Workbooks.Open(f.Path)
set sh = wb.Sheets("Auto Email Script")
row = 2
name = "Customer"
email = sh.Range("A" & row)
subject = "Billing"
the = "the"
LastRow = sh.UsedRange.Rows.Count
For r = row to LastRow
If App.WorkSheetFunction.CountA(sh.Rows(r)) <> 0 Then
SendMessage email, name, subject, TRUE, _
NULL, "Y:\Billing_Common\autoemail\Script\energia-logo.gif", 143,393
row = row + 1
email = sh.Range("A" & row)
End if
Next
wb.Close
End If
Next
Sub SendMessage(EmailAddress, DisplayName, Subject, DisplayMsg, AttachmentPath, ImagePath, ImageHeight, ImageWidth)
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
template = FindTemplate()
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(0)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(EmailAddress)
objOutlookRecip.resolve
objOutlookRecip.Type = 1
' Set the Subject, Body, and Importance of the message.
.Subject = Subject
.bodyformat = 3
.Importance = 2 'High importance
body = Replace(template, "{First}", name)
body = Replace(body, "{the}", the)
if not isNull(ImagePath) then
if not ImagePath = "" then
.Attachments.add ImagePath
image = split(ImagePath,"\")(ubound(split(ImagePath,"\")))
body = Replace(body, "{image}", "<img src='cid:" & image & _
"'" & " height=" & ImageHeight &" width=" & ImageWidth & ">")
end if
else
body = Replace(body, "{image}", "")
end if
if not isNull(AttachMentPath) then
.Attachments.add AttachmentPath
end if
.HTMLBody = body
.Save
.Send
End With
Set objOutlook = Nothing
End Sub
Function FindTemplate()
Set OL = GetObject("", "Outlook.Application")
set Drafts = OL.GetNamespace("MAPI").GetDefaultFolder(16)
Set oItems = Drafts.Items
For Each Draft In oItems
If Draft.subject = "Template" Then
FindTemplate = Draft.HTMLBody
Exit Function
End If
Next
End Function
If you want to send mail directly to an SMTP server, there's no need to go through Outlook in the first place. Just use CDO. Something like this:
schema = "http://schemas.microsoft.com/cdo/configuration/"
Set msg = CreateObject("CDO.Message")
msg.Subject = "Test"
msg.From = "sender#example.com"
msg.To = "recipient#example.org"
msg.TextBody = "This is some sample message text."
With msg.Configuration.Fields
.Item(schema & "sendusing") = 2
.Item(schema & "smtpserver") = "smtp.intern.example.com"
.Item(schema & "smtpserverport") = 25
.Update
End With
msg.Send