I have the following code:
set app = CreateObject("Excel.Application")
Set wb = app.Workbooks.Open("Y:\Billing_Common\autoemail\*.xls")
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
set wb = nothing
set app = nothing
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
It works fine when run off my local machine, but when run off Windows server it throws out an error at the line:
Set wb = app.Workbooks.Open("Y:\Billing_Common\autoemail\*.xls")
Saying it cannot find the file specified, the server has Office 2003 on it and I have ran out of ideas on why it's not working.
Any help would be much appreciated!
Thanks.
Most likely the Open method of Office 2003 doesn't support wildcards in the path. You'll have to enumerate the files in that folder:
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)
...
wb.Close
End If
Next
Related
I am trying to send email using outlook and vbs.
Parse through excel
take subject, email, name, attachment etc from there. the based on attachment name, i need to insert table from attachment excel into body of email.
set app = CreateObject("Excel.Application")
' get current path
Dim WshShell
Set WshShell = CreateObject("WScript.Shell")
strPath = WshShell.CurrentDirectory
Set WshShell = Nothing
'converting csv to xlsx
Set wb = app.Workbooks.Open (strPath+"\"+"rbo1.csv")
WB.SaveAs Replace(WB.FullName, ".csv", ".xlsx"), 51
WB.Close False
wb.close 0
set wb =nothing
Set wb = app.Workbooks.Open (strPath+"\"+"rbo1.xlsx")
set sh = wb.Sheets(1)
row = 2
set name sh.cells("C" & row)
set email = sh.Range("L" & row)
set subject = sh.Range("M" & row)
set attach = sh.Range("N" & row)
Set Cur_date = sh.range("A" & row)
Set Prev_date = sh.range("B" & row)
Set Prev_Bal = sh.range("G" & row)
Set Cur_Bal = sh.range("H" & row)
LastRow = sh.UsedRange.Rows.Count
For r = row to LastRow
If App.WorkSheetFunction.CountA(sh.Rows(r)) <> 0 Then
SendMessage email, name, subject, TRUE, attach, strPath, Cur_date, Prev_date,_
Prev_Bal , Cur_Bal
row = row + 1
name sh.cells("C" & row)
email = sh.Range("L" & row)
subject = sh.Range("M" & row)
attach = sh.Range("N" & row)
Cur_date = sh.range("A" & row)
Prev_date = sh.range("B" & row)
Prev_Bal = sh.range("G" & row)
Cur_Bal = sh.range("H" & row)
End if
Next
wb.close
set wb = nothing
set app = nothing
Sub SendMessage(EmailAddress, DisplayName, Subject, DisplayMsg, AttachmentPath, strPath, Cur_date, Prev_date, Prev_Bal , Cur_Bal)
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
objXl = app.Workbooks.Open(strPath+"\"+AttachmentPath)
htmlmsg = extracttablehtml(objXl.worksheets(1), objXl.worksheets(1).usedRange)
' 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
.HTMLBody = "<table> <br> Dear Sir, <br><br> given under details the change balance+"<br> for any query please call under signed<br><br>" + htmlmsg
' Should we display the message before sending?
If DisplayMsg Then
.Display
Else
.Save
' .Send
End If
End With
objXl.close 0
set objXl = Nothing
Set objOutlook = Nothing
End Sub
Function extracttablehtml(ws, rng)
Dim HtmlContent
Dim i
Dim j
On Error GoTo 0
HtmlContent = "<table>"
For i = 1 To rng.Rows.Count
HtmlContent = HtmlContent & "<tr>"
For j = 1 To rng.Columns.Count
HtmlContent = HtmlContent & "<td>" & ws.Cells(i, j).Value & "</td>"
Next
HtmlContent = HtmlContent & "</tr>"
Next
HtmlContent = HtmlContent & "</table>"
extracttablehtml = HtmlContent
End Function
two problems
extracttablehtml is not working as desired please advise whats the problem
now modification i need to do is to choose only rows based on given criteria
thanks in advance
I am trying to send bulk email via Outlook with two attachments (one logo and one picture of a signature).
When I .send the images don't show in the received email.
They do show, if I first use .display then send manually.
Sub GenerateEMail()
'set abbreviations for workbook and sheets
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsInput As Worksheet: Set wsInput = wb.Sheets("Input")
Dim wsTool As Worksheet: Set wsTool = wb.Sheets("Tool")
Dim outObj As Object
Dim Mail As Object
Set outObj = CreateObject("Outlook.Application")
'Dim olkPA As Outlook.PropertyAccessor
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
'Fasten Macro
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
'get information from sheet "Tool"
'E-Mail
Subject = wsTool.Range("Subjet").Value
Text = wsTool.Range("Text").Value
'Signatures
Signature = wsTool.Range("Sig").Value & "\" & wsTool.Range("NameSig").Value
'Logo
Logo = wsTool.Range("Logo").Value & "\" & wsTool.Range("NameLogo").Value
'get relevant columns from sheet "Input"
ColEMail = Split(Cells(1, Application.WorksheetFunction.Match(wsTool.Range("ColNameMail"), wsInput.Range("1:1"), 0)).Address, "$")(1)
'generate E-Mail for each line (range defined in wsTool)
firstRow = wsTool.Range("From").Value
If wsTool.Range("To").Value <> "" And wsTool.Range("To").Value <> " " Then
lastRow = wsTool.Range("To").Value
Else
lastRow = wsInput.Cells(wsInput.Rows.Count, "A").End(xlUp).Row
End If
For Line = firstRow To lastRow
'opens additional E-Mail
Set Mail = outObj.createitem(0)
Set olkPA = Mail.PropertyAccessor
olkPA.SetProperty PR_ATTACH_CONTENT_ID, "Signature.png"
olkPA.SetProperty PR_ATTACH_CONTENT_ID, "Logo.png"
.Subject = Subject
'.
'Body with Foto of Signatures & Logo
.HTMLBody = "<img src='" & Logo & "'>" & "<br><br>" & _
Text & "<br>" & _
"<img src='" & Signature & "'>"
.To = wsInput.Range(ColEMail & Line).Value
End With
Mail.send
Next Line
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
You are setting PR_ATTACH_CONTENT_ID property on the message itself - you must add the attachment (MailItem.Attachments.Add) and then set the PR_ATTACH_CONTENT_ID property on the returned Attachment object to the value matching the cid attribute on the img tag.
I have a macro to send some emails, but the embed images goes with a "x" to the recievers.
My email have: anex, body text and the embed images.
Option Explicit
Dim lsave As String
Sub Arquivoanex()
Application.DisplayAlerts = False
Dim OutApp As Object
Dim OutMail As Object
Dim oEmail As Object
Dim strBody As String
Dim line As String
Dim subject As String
Dim destine As String
Dim anex As String
Dim product As String
Dim unit As String
Dim retval As String
Dim anex_name As String
Dim validation As String
Dim signature As String
line = 3
product = "x"
Do While product <> ""
Set oEmail = CreateObject("CDO.Message")
product = Sheets("Send_Emails").Range("M" & line)
unit = Sheets("Send_Emails").Range("N" & line)
destine = Sheets("Send_Emails").Range("O" & line)
subject = Sheets("Send_Emails").Range("P" & line)
anex = Sheets("Send_Emails").Range("Q" & line)
anex_name = Sheets("Send_Emails").Range("R" & line)
validation = Sheets("Send_Emails").Range("L" & line)
signature = "\\...\signature.png"
Sheets("Send_Emails").Range("S1") = product
retval = Dir(anex)
If retval = anex_name Then
Else
GoTo next_anex
End If
If anex = "" Then
GoTo next_anex
End If
Sheets("Send_Emails").Select
ActiveSheet.Calculate
Select Case product
Case Is = "X"
Sheets("X").Select
Range("K3") = unit
ActiveSheet.Calculate
Case Is = "Y"
If validation = "Send" Then
Sheets("Y").Select
Range("K3") = unit
ActiveSheet.Calculate
Else: GoTo next_anex
End If
End Select
On Error Resume Next
Call lCriarImagem 'Creates the image and give the location
strBody = Sheets("Send_Emails").Range("B9") & "<img src=""cid:TempExportChart.bmp""height=520 width=750>" & "<br/><br/>TKS! <br/><br/></body>"
MailItem.Attachments.Add FName, 1, 0
With oEmail
.Display
oEmail.From = "mail_from#mail"
oEmail.To = "mail_to#mail"
oEmail.subject = subject
oEmail.Attachments.Add FName, 1, 0
oEmail.AddAttachment anex
oEmail.HTMLBody = strBody & .HTMLBody
oEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
oEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "myserver.server"
oEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/authenticate") = 1
oEmail.Configuration.Fields.Update
oEmail.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
next_anex:
line = line + 1
Loop
Application.DisplayAlerts = True
End Sub
It's posible to fix this problems using this code structure?
Obs: This is the code after all the sugestions.
I still facing the problems with the "X" on the email:https://ibb.co/0hX6Dvf ("The photo cannot be show. Maybe the file cam be moved, renamed or excluded. Verify if the destiny is in the correct location").
You need to add the images as file attachments, set the "content-id" MIME header on these attachment MIME parts, and make suire teh HTML body refers to the image attachents by content id (e.g. <img src="cid:my-xcontent-id">).
You need to add the image and hide it. The position 0 will add and hide it.
MailItem.Attachments.Add Fname, 1, 0
The 1 is the Outlook Constant olByValue.
Once you add the image then you have to use "cid:FILENAME.jpg" as shown below. For example:
With OutMail
.To = tName
.Subject = "Hello world!"
.Attachments.Add Fname, 1, 0
.HTMLBody = "<img src=""cid:Claims.jpg""height=520 width=750>"
.Display
End With
Also, you may set the attachment content ID explicitly:
Function SendasAttachment(fName As String)
Dim olApp As Outlook.Application
Dim olMsg As Outlook.MailItem
Dim olAtt As Outlook.Attachments
Set olApp = Outlook.Application
Set olMsg = olApp.CreateItem(0) ' email
Set olAtt = olMsg.Attachments
Const PR_ATTACH_MIME_TAG = "http://schemas.microsoft.com/mapi/proptag/0x370E001E"
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
Const PR_ATTACHMENT_HIDDEN = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
' attach file
olAtt.Add (fldName & fName)
Set l_Attach = olAtt.Add(fldName & fName)
Set oPA = l_Attach.PropertyAccessor
oPA.SetProperty PR_ATTACH_MIME_TAG, "image/jpeg"
oPA.SetProperty PR_ATTACH_CONTENT_ID, "myident"
oPA.SetProperty PR_ATTACHMENT_HIDDEN, True
olMsg.PropertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/8514000B", True
olMsg.To = "test#somedomain.com"
msgHTMLBody = "<HTML>" & _
"<head>" & _
"</head>" & _
"<BODY>" & "Hi " & olMsg.To & ", <br /><br /> I have attached " & fName & " as you requested." & _
"<br /><img align=baseline border=1 hspace=0 src=cid:myident width='400'/>" & _
"</BODY></HTML>"
' send message
With olMsg
.Subject = "Hello world!"
.BodyFormat = olFormatHTML
.HTMLBody = msgHTMLBody
.Save
'.Display
.Send
End With
End Function
I have a mailing tool to create Outlook templates. The templates are stored as OLEObjects in one of the worksheets.
To use the templates I am creating a copy of them in the Temp folder. Afterwards the tool references it directly and opens with CreateItemFromTemplate. This works only on my PC. Others in my company get an error.
Code recreating the OLE object:
Sub RecreateObject(ObjectName As String, TemplateName As String) 'creates a copy of the template stored in config in the users temp folder so that we can reference it from hard drive
Dim objShell As Object
Dim objFolder As Variant
Dim objFolderItem As Variant
Dim oleObj As OLEObject
Set objShell = CreateObject("shell.application")
Set objFolder = objShell.Namespace(Environ("USERPROFILE") & "\Documents" & Application.PathSeparator)
Set objFolderItem = objFolder.Self
Set oleObj = wsConfig.OLEObjects(ObjectName)
'On Error GoTo Error1:
oleObj.Copy
If Dir(CStr(Environ("USERPROFILE") & "\Documents\" & TemplateName & ".oft"), vbDirectory) = vbNullString Then
objFolderItem.InvokeVerb ("Paste")
Else
Kill Environ("USERPROFILE") & "\Documents\" & TemplateName & ".oft"
oleObj.Copy
objFolderItem.InvokeVerb ("Paste")
End If
EndThisSub:
Set objShell = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
Set oleObj = Nothing
Exit Sub
Error1:
MsgBox "Please re-open this file - template recreation failed."
GoTo EndThisSub:
End Sub
Code opening the template:
Sub OpenTemplate(TemplateName As String, InsHeight As Long, InsWidth As Long, InsTop As Long, InsLeft As Long)
Dim response
Dim varEditedTempBody As Variant, varEditedTempSubject As Variant
'On Error GoTo Error1:
Set objOutlook = CreateObject("Outlook.Application")
'On Error GoTo Error2:
If objMail Is Nothing Then 'checks if any mails opened, if not fires procedure
If curProcess = AddingTemplate Then
Set objMail = objOutlook.CreateItem(0)
Set objInspector = objMail.GetInspector
objMail.Display
objMail.Body = "" 'clearing the automatic signature
End If
If curProcess = EditingTemplate Then
Set objMail = objOutlook.CreateItemFromTemplate(Environ("USERPROFILE") & "\Documents\" & frmTemplates.Controls(TemplateName).Value & ".oft")
'clearing the automatic signature by copying in the template after displaying
varEditedTempBody = objMail.HTMLBody
varEditedTempSubject = objMail.Subject
Set objMail = objOutlook.CreateItemFromTemplate(Environ("USERPROFILE") & "\Documents\" & frmTemplates.Controls(TemplateName).Value & ".oft")
With objMail
.Display
.HTMLBody = varEditedTempBody
.Subject = varEditedTempSubject
End With
Set objInspector = objMail.GetInspector
End If
With objInspector
.WindowState = 2
.Height = InsHeight
.Width = InsWidth
.Top = InsTop
.Left = InsLeft
End With
Else
response = MsgBox("A mail template is already opened. Would you like to proceed and close it without save?", vbYesNo)
If response = vbYes Then 'if user agrees to closing procedure fires
Call CloseTemplate
If curProcess = AddingTemplate Then
Set objMail = objOutlook.CreateItem(0)
Set objInspector = objMail.GetInspector
objMail.Display
objMail.Body = "" 'clearing the automatic signature
End If
If curProcess = EditingTemplate Then
Set objMail = objOutlook.CreateItemFromTemplate(Environ("USERPROFILE") & "\Documents" & Application.PathSeparator & frmTemplates.Controls(TemplateName).Value & ".oft")
varEditedTempBody = objMail.HTMLBody
varEditedTempSubject = objMail.Subject
Set objMail = objOutlook.CreateItemFromTemplate(Environ("USERPROFILE") & "\Documents" & Application.PathSeparator & frmTemplates.Controls(TemplateName).Value & ".oft")
With objMail
.Display
.HTMLBody = varEditedTempBody
.Subject = varEditedTempSubject
End With
Set objInspector = objMail.GetInspector
End If
With objInspector
.WindowState = 2
.Height = InsHeight
.Width = InsWidth
.Top = InsTop
.Left = InsLeft
End With
Else
objMail.Display
Exit Sub
End If
End If
ExitThisSub:
Exit Sub
Error1:
MsgBox "Cannot open the Outlook application. Please note that mailer uses Outlook by default and without it it's not possible to use the program."
GoTo ExitThisSub:
Error2:
MsgBox "The template cannot be opened from hard drive. Please contact ...."
GoTo ExitThisSub:
End Sub
I get the error on this line:
Set objMail = objOutlook.CreateItemFromTemplate(Environ("USERPROFILE") & "\Documents\" & frmTemplates.Controls(TemplateName).Value & ".oft")
saying: run-time error '-2147286960(80030050)' Cannot open the file /path/ . the file may not exist, you may not have the permission to open it...
I read about this and the suggestion was that an instance of objOutlook may somehow lock the file. So I've set it to nothing everywhere after playing with templates or recreating them but it still returned this error.
Your file or directory is ReadOnly. Change the properties of the directory and that's all.
I am not a strong coder (but trying to become a strong one) and was wondering if anyone has any experience in writing a VBScript to OPEN an Excel Workbook (in Application Server VM) and execute an ActiveX Command Button (e.g., commandbutton_Click()).
I got all the way to opening the Excel workbook but am stuck at executing the ActiveX Command Button.
Option Explicit
'Dim pc, iMsg, iConf, Flds
Dim szHostName
Dim objExcel
Set objExcel = Wscript.CreateObject("Wscript.Shell")
'get the computer name
szHostName = objExcel.ExpandEnvironmentStrings( "%COMPUTERNAME%" )
Call Test1()
Call SendAlertEmail(szHostName, "john.doe#corp.com", "test alert <no-reply#corp.com","Test E-mail Subject", "Test e-mail body")
objExcel.ActiveWorkbook.Close
objExcel.DisplayAlerts = False
objExcel.Application.Quit
'objExcel.DisplayAlerts = False
WScript.Echo "Finished."
WScript.Quit
'====================================================================================================
Public Sub Test1()
Dim objWorkbook
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("E:\testfolder\test.xlsm", 0, False)
objExcel.Application.Visible = True
objExcel.Application.Run "test.xlsm!Summary.cmdCycle_Click()"
End Sub
'/////////////////////////////////////////////
' --------------------------------------------------------------------------------- SendAlertEmail routine--------------------------------Start
Public Sub SendAlertEmail(ByVal servername, ByVal tostr, ByVal fromstr, ByVal subjectstr, ByVal bodystr)
Dim pc, iMsg, iConf, Flds
Set pc = CreateObject("Wscript.Network")
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields
Const schema = "http://schemas.microsoft.com/cdo/configuration/"
Dim emailBody
Flds.Item(schema & "sendusing") = 2
Flds.Item(schema & "smtpserver") = "relay.exelonds.com"
Flds.Item(schema & "smtpserverport") = 25
Flds.Item(schema & "smtpauthenticate") = 0
Flds.Item(schema & "smtpusessl") = 0
Flds.Update()
With iMsg
.To = tostr
.From = fromstr
.Subject = servername & ":" & subjectstr
emailBody = bodystr
.HTMLBody = emailBody
.Sender = "Morning Report <noreply#corp.com>"
.Organization = "ABC Corporation"
.ReplyTo = "noreply#corp.com"
.Configuration = iConf
.Send()
End With
' Release Interfaces
Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing
End Sub
I believe this should work:
Dim sheetName$
sheetName = "Name of your worksheet" '# MODIFY THIS LINE
xlBook.Application.run "'" & xlBook.Name & "'!" & sheetName & ".cmdCycle_Click"