I have some VBScript to send an email. But when I try to send text which is Unicode, the result is something that is unreadable. I tried something like .Charset="UTf-8" but it's hopeless. My VBScript code is below; the emailbody.txt file contains something like this "hệ điều hành khởi động !"
Option Explicit
Call Email
Function Email
Dim iMsg, iConf, Flds, schema
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields
schema = "http://schemas.microsoft.com/cdo/configuration/"
Flds.Item(schema & "sendusing") = 2
Flds.Item(schema & "smtpserver") = "smtp.gmail.com"
Flds.Item(schema & "smtpserverport") = 465
Flds.Item(schema & "smtpauthenticate") = 1
Flds.Item(schema & "sendusername") = ""
Flds.Item(schema & "sendpassword") = ""
Flds.Item(schema & "smtpusessl") = 1
Flds.Update
'These constants are defined to make the code more readable
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fso, f, BodyText, HeadText
Set fso = CreateObject("Scripting.FileSystemObject")
'Open the file for reading
Set f = fso.OpenTextFile("emailbody.txt", ForReading) 'edit path if required
'The ReadAll method reads the entire file into the variable BodyText
BodyText = f.ReadAll
'Close the file
f.Close
Set f = Nothing
Set fso = Nothing
With iMsg
.To = ""
.From = ""
.Sender = ""
.Subject = ""
.HTMLBody = BodyText
Set .Configuration = iConf
.Send
End With
set iMsg = nothing
set iConf = nothing
set Flds = nothing
End Function
Read the email body using Adodb.Stream object. Because FSO does not support reading utf-8 encoded files.
Fill the BodyText variable like that:
Dim adoStream
Set adoStream = CreateObject("Adodb.Stream")
adoStream.Open
adoStream.Charset = "UTF-8"
adoStream.LoadFromFile "emailbody.txt"
'********** !! ***************
BodyText = adoStream.ReadText(-1)
'********** !! ***************
adoStream.Close
Set adoStream = Nothing
And, set
iMsg.BodyPart.Charset = "utf-8"
Related
I want to send a personalized email generated by Excel VBA.
The email contains personalized text followed by a html file that contains images.
I tried the following code but the images are not displayed.
Sub Mail_Outlook_With_Html_Doc()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim oFSO As Object
Dim oFS As Object
Dim sText As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFS = oFSO.OpenTextFile("C:\....\invite.htm")
Do Until oFS.AtEndOfStream
sText = oFS.ReadAll()
Loop
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'strbody = personalized email body generated here
On Error Resume Next
With OutMail
.display
.To = ToAdd
.CC =
.BCC = ""
.Subject = "Test Email"
.ReadReceiptRequested = True
' the html file is appended here to the personalized email body generated
.HTMLBody = strbody & sText
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
The invite.htm referred above contains images which are not visible when the email is sent. Neither in the email messages sent nor in the email messages received.
Here ia an example that works for me you need to adapt it according to your needs.
This will embed the image in the body of the email and will attach it from what I remember. Please note you need to display the email first and then send it that is the only way to show on different device, i learn that the hard way. It can be done via code as the below example if you want to display and review the email just comment out the .Send after you are happy you can press manually send.
Option Explicit
Dim titleName As String
Dim firstName As String
Dim lastName As String
Dim fullName As String
Dim clientEmail As String
Dim ccEmail As String
Dim bccEmail As String
Dim emailMessage As String
Sub GenerateInfo()
Dim WS As Worksheet
Dim lrow As Long
Dim cRow As Long
Set WS = ActiveSheet
With WS
lrow = .Range("E" & .Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For cRow = 2 To lrow
If Not .Range("L" & cRow).value = "" Then
titleName = .Range("D" & cRow).value
firstName = .Range("E" & cRow).value
lastName = .Range("F" & cRow).value
fullName = firstName & " " & lastName
clientEmail = .Range("L" & cRow).value
Call SendEmail
.Range("Y" & cRow).value = "Yes"
.Range("Y" & cRow).Font.Color = vbGreen
Else
.Range("Y" & cRow).value = "No"
.Range("Y" & cRow).Font.Color = vbRed
End If
Next cRow
End With
Application.ScreenUpdating = True
MsgBox "Process completed!", vbInformation
End Sub
Sub SendEmail()
Dim outlookApp As Object
Dim outlookMail As Object
Dim sigString As String
Dim Signature As String
Dim insertPhoto As String
Dim photoSize As String
Set outlookApp = CreateObject("Outlook.Application")
Set outlookMail = outlookApp.CreateItem(0)
'Change only Mysig.htm to the name of your signature
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Marius.htm"
If Dir(sigString) <> "" Then
Signature = GetBoiler(sigString)
Else
Signature = ""
End If
insertPhoto = "C:\Users\marius\Desktop\Presale.jpg" 'Picture path
photoSize = "<img src=""cid:Presale.jpg""height=400 width=400>" 'Change image name here
emailMessage = "<BODY style=font-size:11pt;font-family:Calibri>Dear " & titleName & " " & fullName & "," & _
"<p>I hope my email will find you very well." & _
"<p>Our <strong>sales preview</strong> starts on Thursday the 22nd until Sunday the 25th of November." & _
"<p>I look forward to welcoming you into the store to shop on preview.<p>" & _
"<p> It really is the perfect opportunity to get some fabulous pieces for the fast approaching festive season." & _
"<p>Please feel free to contact me and book an appointment." & _
"<p>I look forward to seeing you then." & _
"<p>" & photoSize & _
"<p>Kind Regards," & _
"<br>" & _
"<br><strong>Marius</strong>" & _
"<br>Assistant Store Manager" & _
"<p>"
With outlookMail
.To = clientEmail
.CC = ""
.BCC = ""
.Subject = "PRIVATE SALE"
.BodyFormat = 2
.Attachments.Add insertPhoto, 1, 0
.HTMLBody = emailMessage & Signature 'Including photo insert and signature
'.HTMLBody = emailMessage & Signature 'Only signature
.Importance = 2
.ReadReceiptRequested = True
.Display
.Send
End With
Set outlookApp = Nothing
Set outlookMail = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
This is the VBScript code answered here to get the JSON file from computer with proper values.
Set fso = CreateObject("Scripting.FileSystemObject")
json = fso.OpenTextFile("C:\path\to\combined.json").ReadAll
Set re = New RegExp
re.Pattern = """passed"":(true|false),"
re.IgnoreCase = True
For Each m In re.Execute(json)
passed = CBool(m.SubMatches(0))
Next
But I have a JSON file that looks like this which is online,
["AA-BB-CC-MAKE-SAME.json","SS-ED-SIXSIX-TENSE.json","FF-EE-EE-EE-WW.json","ZS-WE-AS-FOUR-MINE.json","DD-RF-LATERS-LATER.json","FG-ER-DC-ED-FG.json"]
How to download this JSON file and get the values to five variables using either VBScript or batch file?
Here is an example for downloading a json from internet and parse it :
Dim http,URL
URL = "http://ip-api.com/json/"
Set http = CreateObject("Msxml2.XMLHTTP")
http.open "GET",URL,False
http.send
strJson = http.responseText
Set j = ParseJson(strJson)
Result = "IP =" & j.query & vbCrlf &_
"ISP = "& j.isp & vbCrlf &_
"Country = "& j.country & vbCrlf &_
"TimeZone = "& j.timezone
Wscript.echo Result
'--------------------------------------------------------
Function ParseJson(strJson)
Set html = CreateObject("htmlfile")
Set window = html.parentWindow
window.execScript "var json = " & strJson, "JScript"
Set ParseJson = window.json
End Function
'--------------------------------------------------------
You can give a try for this code :
Dim http,URL
URL = "https://privateURL/jsonfile/"
Set http = CreateObject("Msxml2.XMLHTTP")
http.open "GET",URL,False
http.send
strJson = http.responseText
Result = Extract(strJson,"(\x22(.*)\x22)")
Arr = Split(Result,",")
For each Item in Arr
wscript.echo Item
Next
'******************************************
Function Extract(Data,Pattern)
Dim oRE,oMatches,Match,Line
set oRE = New RegExp
oRE.IgnoreCase = True
oRE.Global = True
oRE.Pattern = Pattern
set oMatches = oRE.Execute(Data)
If not isEmpty(oMatches) then
For Each Match in oMatches
Line = Line & Trim(Match.Value) & vbCrlf
Next
Extract = Line
End if
End Function
'******************************************
I'm attempting to automate an email using an Excel worksheet and VBA. I'm able to copy the desired range into the email, but I want to use a htm file for the HTML formatting.
How do I read a htm file and add it to the .HTMLBody of my email?
Here's my code, which sends an email with the correct worksheet, but does not include the HTML formatting that is added with the test(path) function:
Sub Send_To_Outlook()
Dim AWorksheet As Worksheet
Dim Sendrng As range
Dim rng As range
Dim text As String
Dim textline As String
Dim sPath As String
sPath = "H:\My Documents\email.htm"
On Error GoTo StopMacro
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Fill in the Worksheet/range you want to mail
Set Sendrng = Worksheets("Email").range("C6:L244")
'Remember the activesheet
Set AWorksheet = ActiveSheet
With Sendrng
' Select the worksheet with the range you want to send
.Parent.Select
'Remember the ActiveCell on that worksheet
Set rng = ActiveCell
'Select the range you want to mail
.Select
' Create the mail and send it
ActiveWorkbook.EnvelopeVisible = True
With .Parent.MailEnvelope
With .Item
.To = "myemail#email.com"
.CC = ""
.BCC = ""
.Subject = "My subject"
.HTMLBody = test(sPath)
.Send
End With
End With
'select the original ActiveCell
rng.Select
End With
'Activate the sheet that was active before you run the macro
AWorksheet.Select
StopMacro:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
ActiveWorkbook.EnvelopeVisible = False
End Sub
Function test(sPath As String)
Dim oFSO As Object
Dim oFS As Object, sText As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFS = oFSO.OpenTextFile(sPath)
test= oFS.ReadAll()
End Function
Any suggestions or advice on why this isn't working would be awesome!
PS I also need to display the message instead of send, but this isn't as important of an issue.
Your function doesn't return any value.
Try this:
Function test(sPath As String)
test = CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath).ReadAll()
End Function
When you say that your code doesn't work, does that mean that you get an error or that the code executes but the email body is empty?
I would first check to see if your "test" Function is returning a null string:
Function test(sPath As String)
Dim oFSO As Object
Dim oFS As Object, sText As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFS = oFSO.OpenTextFile(sPath)
' I don't think you need to loop until EOF with .ReadAll
sText = oFS.ReadAll
' This will print sText to the Immediate Window; if it is 0, then sText is null
Debug.Print ("sText string has a length of: " & Len(sText))
End Function
My guess is that sText is null. If it is reading the .htm successfully, I would next check to make sure that the .htm is valid .html syntax.
I solved my problem. There was an issue when using html coupled with sending the worksheet range in the above code. I decided to covert the worksheet into html, export the chart into an image and insert it into the rest of the html for the email.
Sub Mail_Sheet_Outlook_Body()
Dim rng1 As range
Dim rng2 As range
Dim OutApp As Object
Dim OutMail As Object
Dim newimage As Action
Dim aPath As String
Dim bPath As String
Dim sPath As String
'Name the variables for your the needed paths
sPath = "C:\Chart1.png"
aPath = "C:\email1.htm"
bPath = "C:\email2.htm"
'Export your chart as an image
Call ExportChart("Chart1")
'Select the range your desired tables are in
Set rng1 = Worksheets("Email").range("C6:L32")
Set rng2 = Worksheets("Email").range("C45:L244")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Create the email
On Error Resume Next
With OutMail
.To = "myemail#email.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
' Place your tables in the correct location of your html for the email
.HTMLBody = test(aPath) & RangetoHTML(rng1) & "<img src=" & "'" & sPath & "'" & "width=888; height=198>" & RangetoHTML(rng2) & test(bPath)
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function ExportChart(sChartName As String)
' Export a selected chart as a picture
Const sSlash$ = "/"
Const sPicType$ = ".png"
Dim sPath$
Dim sBook$
Dim objChart As ChartObject
On Error Resume Next
' Test if there are even any embedded charts on the activesheet
' If not, let the user know
Set objChart = ActiveSheet.ChartObjects(1)
If objChart Is Nothing Then
MsgBox "No charts have been detected on this sheet", 0
Exit Function
End If
' Test if there is a single chart selected
If ActiveChart Is Nothing Then
MsgBox "You must select a single chart for exporting ", 0
Exit Function
End If
Start:
' chart is exported as a picture, Chart1.png in the same
' folder location as the workbook
sBook = ActiveWorkbook.path
sPath = sBook & sSlash & sChartName & sPicType
ActiveChart.Export Filename:=sPath, FilterName:="PNG"
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
End Function
Function RangetoHTML(rng As range)
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
Function test(sPath As String)
'Returns a string after reading the contents of a given file
test = CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath).ReadAll()
End Function
Thanks for all of your help! :)
I stole a function from somewhere online that allows me to take HTML from my clipboard and put in an Outlook 2013 email.
This works fine, but I would also like to modify it to grab the first line of text from the email body and use that as the subject line.
That way everything can be included in the HTML. However I have almost no experience with VB and after spending some time online look at API's and documentation I am still not able to figure it out. Here is what I have so far.
Sub PrependClipboardHTML()
Dim email As Outlook.MailItem
Dim cBoard As DataObject
Dim lines() As String
Set email = Application.ActiveInspector.CurrentItem
Set cBoard = New DataObject
cBoard.GetFromClipboard
email.HTMLBody = cBoard.GetText + email.HTMLBody
lines = Split(email.Body, vbNewLine)
' this does not produce anything
email.subject = lines(0)
'remove first line of email
Set cBoard = Nothing
Set email = Nothing
End Sub
To reiterate, I want to remove the first line of the post-formatted email body and use it as the subject line.
This is quick and dirty, grabbing a few mins here and there to construct, but something like this should get you started:
Public Sub PrependClipboardToHTML()
Dim email As Outlook.MailItem
Dim cBoard As DataObject
Dim cText, strLine As String
Dim strArray() As String
Set email = Application.CreateItem(olMailItem)
Set cBoard = New DataObject
cBoard.GetFromClipboard
cText = cBoard.GetText
strArray = Split(cText, vbCrLf)
strLine = CStr(strArray(0))
With email
.To = "someone#domain.com"
.Subject = strLine
.BodyFormat = olFormatHTML ' olFormatPlain == send plain text message
.HTMLBody = cText + email.HTMLBody
.Display
End With
Set email = Nothing
Set cBoard = Nothing
End Sub
I did some more research and read over the API's. In the end I figured it out. My solution is posted below. Thanks for all the help from the other commenters.
Sub PrependClipboardHTML()
Dim email As Outlook.MailItem
Dim cBoard As DataObject
Set email = Application.ActiveInspector.CurrentItem
Set cBoard = New DataObject
cBoard.GetFromClipboard
Dim sText As String
Dim headerStart As Integer
Dim headerEnd As Integer
Dim HTMLPre As String
Dim HTMLPost As String
Dim subject As String
Const headerStartLen = 20
Const headerEndStr = "</h2>"
sText = cBoard.GetText
headerStart = InStr(sText, "<h2 id=")
If headerStart > 0 Then
headerEnd = InStr(headerStart, sText, headerEndStr)
If headerEnd > 0 Then
subject = Mid(sText, _
headerStart + headerStartLen, _
headerEnd - headerStart - headerStartLen)
HTMLPre = Mid(sText, 1, headerStart - 1)
HTMLPost = Mid(sText, headerEnd + Len(headerEndStr))
End If
End If
email.HTMLBody = HTMLPre + HTMLPost + email.HTMLBody
If Len(email.subject) = 0 Then
email.subject = subject
End If
Set cBoard = Nothing
Set email = Nothing
End Sub
I have an attachment field in my accdb database file,
i'm trying to read it to extract the attachments but it keep return empty values
recording to this post Using Attachment field with Classic ASP
there is no way to do it with adodb, is true? and if yes, what other ways i have to do that ?
this is the code that i'm running:
qid = request.querystring("qid")
wikiDbAddress="database/my.accdb"
set cnWiki=server.CreateObject("adodb.connection")
cnWiki.open "DRIVER={Microsoft Access Driver (*.mdb, *.accdb)}; DBQ=" & Server.MapPath(root&wikiDbAddress)
SQL = "select * from [Knowledge Base] where id="&qid
RS.Open SQL, cnWiki
do while not RS.eof
response.write RS("attachments")
RS.movenext
loop
For now, i did some workaround that helped me, it's not efficient but does the work.
qid = request.querystring("qid")
name = request.querystring("name")
SQL = "select Attachments.FileName as fname, Attachments.FileData as data, Attachments.FileType as FileType from [Knowledge Base] where Attachments.FileName='"&name&"' and id="&qid
RS.Open SQL, cnWiki
do while not RS.eof
if rs("fname")= name then
filename = Server.MapPath("/KB_"&qid&"_"&rs("fname"))
set fs=Server.CreateObject("Scripting.FileSystemObject")
if not fs.FileExists(filename) then
SaveBinaryData filename, rs("data")
data = readBinary(filename)
' CHR(255) = FF, CHR(170) = AA
data = Mid(data, 21, Len(data) - 20)
writeBinary data,filename
end if
set fs=nothing
downloadFromFile(filename )
exit do
else
RS.movenext
end if
loop
rs.close
cnWiki.close
function downloadFromFile(strFile )
Dim objConn
Dim intCampaignRecipientID
If strFile <> "" Then
Dim objStream
Set objStream = Server.CreateObject("ADODB.Stream")
objStream.Type = 1 'adTypeBinary
objStream.Open
objStream.LoadFromFile(strFile)
Response.Clear
'Response.ContentType = "image/jpeg"
Response.Addheader "Content-Disposition", "attachment; filename=" & strFile
Response.BinaryWrite objStream.Read
objStream.Close
Set objStream = Nothing
End If
End Function
Function SaveBinaryData(FileName, ByteArray)
Const adTypeBinary = 1
Const adSaveCreateOverWrite = 2
'Create Stream object
Dim BinaryStream
Set BinaryStream = CreateObject("ADODB.Stream")
'Specify stream type - we want To save binary data.
BinaryStream.Type = adTypeBinary
'Open the stream And write binary data To the object
BinaryStream.Open
BinaryStream.Write ByteArray
'Save binary data To disk
BinaryStream.SaveToFile FileName, adSaveCreateOverWrite
End Function
Function readBinary(path)
Dim a, fso, file, i, ts
Set fso = CreateObject("Scripting.FileSystemObject")
Set file = fso.getFile(path)
If isNull(file) Then
wscript.echo "File not found: " & path
Exit Function
End If
Set ts = file.OpenAsTextStream()
a = makeArray(file.size)
i = 0
While Not ts.atEndOfStream
a(i) = ts.read(1)
i = i + 1
Wend
ts.close
readBinary = Join(a,"")
End Function
Sub writeBinary(bstr, path)
Dim fso, ts
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set ts = fso.createTextFile(path)
If Err.number <> 0 Then
wscript.echo Err.message
Exit Sub
End If
On Error GoTo 0
ts.Write(bstr)
ts.Close
End Sub
Function makeArray(n)
Dim s
s = Space(n)
makeArray = Split(s," ")
End Function