I am using the following VBA code to try and copy a range from a workbook and paste this into an email:
This is the piece of code causing the issue. Error 438 'object doesn't support this property or method' on this line:
WB3.Range("A20:J30").SpecialCells (xlCellTypeVisible)
Code:
'Insert Range
Dim app As New Excel.Application
app.Visible = False
'open a workbook that has same name as the sheet name
Set WB3 = Workbooks.Open(Range("F" & i).value)
'select cell A1 on the target book
WB3.Range("A20:J30").SpecialCells (xlCellTypeVisible)
Call stream.WriteText(rangetoHTML(rng))
If i use ThisWorkbook, seems to work fine. It's something wrong with how i am defining the other workbook.
My cells in column F all contain valid paths like:
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\test\Accrol.xlsx
Pleas can someone show me where i am going wrong? Ideally i would rather get the range from the workbook without having to open it, but alas i am brand new to vba so not sure if this would work.
The aim is to get the range put into the body of an email.
Call stream.WriteText(rangetoHTML(rng))
Full Code:
Sub Send()
Dim answer As Integer
answer = MsgBox("Are you sure you want to Send All Announcements?", vbYesNo + vbQuestion, "Notice")
If answer = vbNo Then
Exit Sub
Else
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim Attachment As String
Dim WB3 As Workbook
Dim WB4 As Workbook
Dim rng As Range
Dim db As Object
Dim doc As Object
Dim body As Object
Dim header As Object
Dim stream As Object
Dim session As Object
Dim i As Long
Dim j As Long
Dim server, mailfile, user, usersig As String
Dim LastRow As Long, ws As Worksheet
LastRow = Worksheets(1).Range("F" & Rows.Count).End(xlUp).Row 'Finds the last used row
j = 18
With ThisWorkbook.Worksheets(1)
For i = 18 To LastRow
'Start a session of Lotus Notes
Set session = CreateObject("Notes.NotesSession")
'This line prompts for password of current ID noted in Notes.INI
Set db = session.CurrentDatabase
Set stream = session.CreateStream
' Turn off auto conversion to rtf
session.ConvertMime = False
'Email Code
'Create email to be sent
Set doc = db.CreateDocument
doc.Form = "Memo"
Set body = doc.CreateMIMEEntity
Set header = body.CreateHeader("Promotion Announcement for week " & Range("I8").value & ", " & Range("T8").value & " - Confirmation required")
Call header.SetHeaderVal("HTML message")
'Set From
Call doc.ReplaceItemValue("Principal", "Food Specials <mailto:Food.Specials#Lidl.co.uk>")
Call doc.ReplaceItemValue("ReplyTo", "Food.Specials#Lidl.co.uk")
Call doc.ReplaceItemValue("DisplaySent", "Food.Specials#Lidl.co.uk")
'To
Set header = body.CreateHeader("To")
Call header.SetHeaderVal(Range("Q" & i).value)
'Email Body
Call stream.WriteText("<HTML>")
Call stream.WriteText("<font size=""3"" color=""black"" face=""Arial"">")
Call stream.WriteText("<p>Good " & Range("A1").value & ",</p>")
Call stream.WriteText("<p>Please see attached an announcement of the spot buy promotion for week " & Range("I8").value & ", " & Range("T8").value & ".<br>Please check, sign and send this back to us within 24 hours in confirmation of this order. Please also inform us of when we can expect the samples.</p>")
Call stream.WriteText("<p>The details are as follows:</p>")
'Insert Range
Dim app As New Excel.Application
app.Visible = False
'open a workbook that has same name as the sheet name
Set WB3 = Workbooks.Open(Range("F" & i).value)
'select cell A1 on the target book
WB3.Range("A20:J30").SpecialCells (xlCellTypeVisible)
Call stream.WriteText(rangetoHTML(rng))
Call stream.WriteText("<p><b>N.B. A volume break down by RDC will follow 4/5 weeks prior to the promotion. Please note that this is your responsibility to ensure that the orders you receive from the individual depots match the allocation.</b></p>")
Call stream.WriteText("<p>We also need a completed Product Technical Data Sheet. Please complete this sheet and attach the completed sheet in your response.</p>")
'Attach file
Attachment = Range("F" & i).value
Set AttachME = doc.CREATERICHTEXTITEM("attachment")
Set EmbedObj = AttachME.EmbedObject(1454, "", Attachment, "")
Call stream.WriteText("<BR><p>Please note the shelf life on delivery should be 75% of the shelf life on production.</p></br>")
'Signature
Call stream.WriteText("<BR><p>Kind regards / Mit freundlichen Grüßen,</p></br>")
Call stream.WriteText("<p><b>Lidl UK Food Specials Team</b></p>")
Call stream.WriteText("<table border=""0"">")
Call stream.WriteText("<tr>")
Call stream.WriteText("<td><img src=""http://www.lidl.co.uk/statics/lidl-uk/ds_img/layout/top_logo2016.jpg"" alt=""Mountain View""></td>")
Call stream.WriteText("<td><img src=""http://www.lidl.co.uk/statics/lidl-uk/ds_img/assets_x_x/BOQLOP_NEW%281%29.jpg"" alt=""Mountain View""></td>")
Call stream.WriteText("</tr>")
Call stream.WriteText("</table>")
Call stream.WriteText("</font>")
Call stream.WriteText("</body>")
Call stream.WriteText("</html>")
Call body.SetContentFromText(stream, "text/HTML;charset=UTF-8", ENC_IDENTITY_7BIT)
Call doc.Send(False)
session.ConvertMime = True ' Restore conversion - very important
'Clean Up the Object variables - Recover memory
Set db = Nothing
Set session = Nothing
Set stream = Nothing
Set doc = Nothing
Set body = Nothing
Set header = Nothing
WB3.Close savechanges:=False
Application.CutCopyMode = False
'Email Code
j = j + 1
Next i
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Success!" & vbNewLine & "Announcements have been sent."
End If
End Sub
WB3 is a Workbook object. Workbooks don't support the range property. Instead, use a worksheet object.
Example
WB3.Sheets(1).Range("A20:J30").SpecialCells(xlCellTypeVisible)
This line on it's own does not do anything. If you want to select these cells call the select method:
WB3.Sheets(1).Range("A20:J30").SpecialCells(xlCellTypeVisible).Select
EDIT
Just noticed that #Slai had already identified the root cause, in the comments.
Related
I currently have macros built that will execute when a cell value dips below a certain number. My issue, these are live prices, and that number will tick constantly, prompting the macro to run all day. Ideally this macro calls the email macro once a day, given the parameters are met.
This Excel file will sit on a computer that runs 24/7, so no issue in closing and re-opening.
Here is the code for both:
Private Sub Worksheet_Calculate()
If Range("C15").Value < 72 Then
Call Send_Email
End If
End Sub
Sub Send_Email()
Dim pApp As Object
Dim pMail As Object
Dim pBody As String
Dim rng As Range
Set rng = Range("B6:C16")
Set pApp = CreateObject("Outlook.Application")
Set pMail = pApp.CreateItem(0)
On Error Resume Next
With pMail
.To = "gmail.com"
.CC = ""
.BCC = ""
.Subject = "Account Action Price Notification"
.Body = "Hello, our recommended action price for BLANK of $72 has been hit." & vbNewLine & vbNewLine & _
"Thank you."
'Below displays the email and allows it to paste
.Display
Dim wdDoc As Object '## Word.Document
Dim wdRange As Object '## Word.Range
Set wdDoc = pMail.GetInspector.WordEditor
Set wdRange = wdDoc.Range(0, 0)
wdRange.InsertAfter vbCrLf & vbCrLf
'Copy the range in-place
rng.Copy
wdRange.Paste
'Below will auto send the email when apostrophe is removed
'.Send
End With
On Error GoTo 0
Set pMail = Nothing
Set pApp = Nothing
End Sub
I have tried working solutions from here: VBA Run Macro Once a Day
However, I am unable to get this to properly run.
Consider using a cell that logs/updates if the task has been done for the day. For example, populate the cell with a date and time after which the task may run. Then, as part of the code, include a validation if the time is past or not and escapes if it is not later. Once the time comes and the full code is permitted to run, use an additional line at the end to update the cell to the next date (and time, if desired).
I want to call a vba function from vbscript which has a parameter, I Know how to call a parameterized sub but having issue with function
Here is what I have tried, I tried the code here Calling vba function(with parameters) from vbscript and show the result , but this also didn't work, it gave an error as expected end of statement
Set xlObj = CreateObject("Excel.Application")
Set objWorkbook = xlObj.Workbooks.Open("E:\Headers.xlsm")
xlObj.Application.Visible = False
xlObj.Workbooks.Add
Dim result
result = xlObj.Application.Run("Headers.xlsm!Headers",filename)
xlFile.Close True
xlObj.Quit
this my vba function
Function Headers(filename As String) As String
Application.ScreenUpdating = False
Dim myWb As Workbook
Dim i As Integer
Dim flag As Boolean
Set myWb = Workbooks.Open(filename:=filename)
Dim arr
arr = Array("col1","col2")
For i = 1 To 2
If Cells(1, i).Value = arr(i - 1) Then
Headers = "True"
Else
Headers = "False , Not Found Header " & arr(i - 1)
Exit Function
End If
Next
myWb.Close
End Function
In your VBScript xlObj is set to be an application Set xlObj = CreateObject("Excel.Application"). That means xlObj.Application should be xlObj only.
In your VBScript Filename is not declared nor set to a value therefore it is empty. You need to define value to it.
Set xlObj = CreateObject("Excel.Application")
Set objWorkbook = xlObj.Workbooks.Open("E:\Headers.xlsm")
xlObj.Visible = False
xlObj.Workbooks.Add
Dim Filename 'declare filename and set a value to it
Filename = "E:\YourPath\Yourfile.xlsx"
Dim Result
Result = xlObj.Run("Headers.xlsm!Headers", Filename)
xlFile.Close True
xlObj.Quit
In your function you use Exit Function. This will stop the code immediately at this point, which means your workbook myWb will not be closed! It stays open because myWb.Close is never reached. Change Exit Function to Exit For to just exit the loop and continue to close the workbook.
Cells(1, i).Value is neither specified which workbook it is in nor which worksheet. This is not very reliable never call Cells or Range without specifying workbook and worksheet (or Excel will guess which one you mean, and Excel can fail if you are not precise).
Therfore I recommend to use something like myWb.Worksheets(1).Cells(1, i).Value if you always mean the first worsheet in that workbook. Alternatively if it has a defined name using its name would be more reliable: myWb.Worksheets("SheetName").Cells(1, i).Value
If you turn off ScreenUpdating don't forget to turn it on in the end.
Error handling in case filename does not exist would be nice to not break the function.
You can slightly improve speed by assuming Headers = "True" as default and just turn it False in case you find any non matching header. This way the variable is only set once to True instead of multiple times for every correct header.
Public Function Headers(ByVal Filename As String) As String
Application.ScreenUpdating = False
Dim flag As Boolean 'flag is never used! you can remove it
On Error Resume Next 'error handling here would be nice to not break if filename does not exist.
Dim myWb As Workbook
Set myWb = Workbooks.Open(Filename:=Filename)
On Error Goro 0 'always reactivate error reporting after Resume Next!!!
If Not myWb Is Nothing Then
Dim Arr() As Variant
Arr = Array("col1", "col2")
Headers = "True" 'assume True as default and just change it to False if a non matching header was found (faster because variable is only set true once instead for every column).
Dim i As Long 'better use Long since there is no benefit in using Integer
For i = 1 To UBound(arr) + 1 'use `ubound to find the upper index of the array, so if you add col3 you don't need to change the loop boundings
If Not myWb.Worksheets(1).Cells(1, i).Value = Arr(i - 1) Then 'define workbook and worksheet for cells
Headers = "False , Not Found Header " & Arr(i - 1)
Exit For '<-- just exit loop but still close the workbook
End If
Next i
Else
Headers = "File '" & Filename & "' not found!"
End If
Application.ScreenUpdating = True
myWb.Close
End Function
I've been trying to create a sub that would take some information from an Excel selection and create a new task on Outlook. The body of the task should feature the comment from the first cell (which it already does) but before all that I want to paste the range as it looks in Excel, then the comment, and then again, the range.
Here's my code:
Sub CreateReminder()
Dim olApp As Object
Dim olRem As Object
Dim myRange As Range
Dim contact As String
Dim company As String
Dim city As String
Dim state As String
Dim cmt As comment
Dim comment As String
Dim strdate As Date
Dim remdate As Date
Set olApp = CreateObject("Outlook.Application")
Set olRem = olApp.CreateItem(3)
Set myRange = Selection
If ActiveCell.comment Is Nothing Then
Exit Sub
Else
Set cmt = ActiveCell.comment
End If
company = myRange.Columns(1).Text
contact = myRange.Columns(2).Text
If InStr(contact, "/") <> 0 Then
contact = Left(contact, InStr(contact, "/") - 1)
End If
city = myRange.Columns(7).Text
state = myRange.Columns(8).Text
myRange.Copy
comment = cmt.Text
strdate = Date
remdate = Format(Now)
rangeaddress = myRange.Address
wrksheetname = ActiveSheet.Name
With olRem
.Subject = "Call " & contact & " - " & company & " - " & city & ", " & state
.display
SendKeys "{TAB 9}"
SendKeys "^{v}"
.body = Chr(10) & comment & Chr(10)
'.startdate = strdate
'.remindertime = remdate
'.reminderset = True
'.showcategoriesdialog
End With
Set olApp = Nothing
Set olRem = Nothing
End Sub
As you can see, I am able to paste using a SendKeys method, but it is sort of a hack, and not... sophisticated. I'm sure there's another way of doing it, any ideas?
I found code for pasting as HTML to an email, but as I understand, the Mail item allows for HTML, but not the Task item.
Outlook uses Word as an email editor. You can use the Word object model for making manipulatins on the message body. The WordEditor property of the Inspector class returns an instance of the Document class (from the Word object model) which represents the body. You can read more about that way and all possible ways in the Chapter 17: Working with Item Bodies.
That way you can use the Copy method of the Range class to copy the range to the Clipboard. Then you can use the Paste method from the Word object model to paste data into the document which represents the message body.
so I have set up an emailing system in which emails are sent out to people that own a specific item that have a due date coming up. There are at least 1,000 items on my excel sheet and each item has a specific owner. However the owners are labeled using an ID. The ID refers to an email address in another sheet called "Permissions" . My email function works, however I am having trouble with my recepients. I am not able to match the ID on the sheet that has the items to the email address in the other sheet. I am fairly new to VBA so please excuse my code. I am still learning. Thank you!
The worksheet name "Register" is the worksheet with all of the items and due dates.
Code :
Option Explicit
Sub TestEmailer()
Dim Row As Long
Dim lstRow As Long
Dim Message As Variant
Dim Frequency As String 'Cal Frequency
Dim DueDate As Date 'Due Date for Calibration
Dim vbCrLf As String 'For HTML formatting
Dim registerkeynumber As String 'Register Key Number
Dim class As Variant 'Class
Dim owner As String ' Owner
Dim status As String 'Status
Dim ws As Worksheet
Dim toList As Variant
Dim Ebody As String
Dim esubject As String
Dim Filter As String
Dim LQAC As String
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
Set ws = Sheets(1)
ws.Select
lstRow = WorksheetFunction.Max(2, ws.Cells(Rows.Count, Range("CalDueDate").Column).End(xlUp).Row)
For Row = 2 To lstRow
DueDate = CDate(Worksheets("Register").Cells(Row, Range("DueDate").Column).Value) 'DUE DATE
registerkeynumber = Worksheets("Register").Cells(Row, Range("RegisterKey").Column).Value
class = Worksheets("Register").Cells(Row, Range("Class").Column).Value
status = Worksheets("Register").Cells(Row, Range("Status").Column).Value
LQAC = Worksheets("Register").Cells(Row, Range("LQAC").Column).Value
Filter = Worksheets("Permissions").Cells(Row, Worksheets("Permissions").Range("MailFilter").Column).Value
If DueDate - Date <= 7 And class > 1 And status = "In Service" And DueDate <> "12:00:00 AM" Then
vbCrLf = "<br><br>"
'THIS IS WHERE I AM NOT SURE IF I AM REFERENCING CORRECTLY. I AM NOT SURE HOW TO REFERENCE THE ID FROM THE 'REGISTER' AND MATCH IT WITH THE EMAIL ADDRESS IN THE 'PERMISSIONS' WORKSHEET. AS OF NOW I AM ONLY REFERENCING THE EMAIL ADDRESS BUT THEY ARE NOT MATCHING UP.
toList = Worksheets("Permissions").Cells(Row, Worksheets("Permissions").Range("Email").Column).Value 'RECEPIENT OF EMIAL
esubject = "TEXT " & Cells(Row, Range("Equipment").Column).Value & " is due in the month of " & Format(DueDate, "mmmm-yyyy")
Ebody = "<HTML><BODY>"
Ebody = Ebody & "Dear " & Cells(Row, Range("LQAC").Column).Value & vbCrLf
Ebody = Ebody & "</BODY></HTML>"
SendEmail Bdy:=Ebody, Subjct:=esubject, Two:=toList
End If
Next Row
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
Function SendEmail(Bdy As Variant, Subjct As Variant, Optional Two As Variant = "Email#xxx", Optional ReplyTo As Variant = "Email#xxx", Optional Carbon As Variant = "Email#xxx", Optional Attch As Variant = "FilePath", Optional Review As Boolean = False)
Dim OutlookEM As Outlook.Application
Dim EMItem As MailItem
If Not EmailActive Then Exit Function
If Two = "Email#xxx" Then
MsgBox "There is no Address to send this Email"
Two = ""
Review = True
'Exit Function
End If
'Create Outlook object
Set OutlookEM = CreateObject("Outlook.Application")
'Create Mail Item
Set EMItem = OutlookEM.CreateItem(0)
With EMItem
.To = Two
.Subject = Subjct
.HTMLBody = Bdy
End With
If ReplyTo <> "Email#xxx" Then EMItem.ReplyRecipients.Add ReplyTo
If Attch <> "FilePath" Then EMItem.Attachments.Add Attch
If Carbon <> "Email#xxx" Then EMItem.CC = Carbon
If Review = True Then
EMItem.Display (True)
Else
EMItem.Display
' EMItem.Send
End If
End Function
I think I am able to follow what the issue is here. It doesn't look like your code is using any vlookup formula or matching formula to find the email. Unless they are on the same row between the different sheets, you will need to find the value.
VBA has the ability to use the functions that you would normally use in Excel.
If you tweek the code below with the correct range and column number, you should be able to find the correct email address based on an ID.
' instead of 1 below, use the column for the id to look up
lookupValue = Worksheets("Register").Cells(Row, 1).Value
' range of the ids and emails in the permissions table - edit whatever the range should be
Rng = Worksheets("Permissions").Range("A1:B100")
' column to look up - number of columns between the id and email in the permissions tab
col = 2
' whether you want excel to try to find like match for the lookup value
' pretty much never have this be true if you want to have confidence in the result
likeMatch = False
emailAddress = WorksheetFunction.VLookup(lookupValue, Rng, col, likeMatch)
I need help writing some a loop to create a command button for every cell in a range.
I achieved creating as many buttons as I need. my problem is setting the .OnAction property for each of them.
Every button will send an email through Lotus Notes to a specified address, with subject and body of the mail stored in adjacent cells. That code already works, here it is the procedure to send the email:
Sub Send(ByVal MailAddress, Subject, Message As String)
Dim Maildb As Object
Dim MailDoc As Object
Dim Body As Object
Dim Session As Object
Set Session = CreateObject("Lotus.NotesSession")
Call Session.Initialize
'Call Session.Initialize("password")
UserName = Session.UserName
Set Maildb = Session.GetDatabase("", "C:\Lotus\Notes\Data\names.nsf")
'Set Maildb = Session.GetDatabase("", MailDbName)
If Not Maildb.IsOpen = True Then Call Maildb.Open
Set MailDoc = Maildb.CreateDocument
Call MailDoc.ReplaceItemValue("Form", "Memo")
Call MailDoc.ReplaceItemValue("SendTo", MailAddress)
Call MailDoc.ReplaceItemValue("Subject", Subject)
Set Body = MailDoc.CreateRichTextItem("Body")
Call Body.AppendText(Message)
MailDoc.SaveMessageOnSend = True
Call MailDoc.ReplaceItemValue("PostedDate", Now())
Call MailDoc.Send(False)
Set Maildb = Nothing
Set MailDoc = Nothing
Set Body = Nothing
Set Session = Nothing
End Sub
Now, what I'd like to do is to create the buttons when the workbook opens, iterating through the first compiled column of my sheet. Next, I'll add/delete buttons when adding/deleting rows to the sheets. To do so I have at the moment the following code:
Private Sub Workbook_Open()
Dim L As Integer
Dim t As Range
Dim btn As Button
Dim arg As String
Application.ScreenUpdating = False
ActiveSheet.Buttons.Delete
Sheets(1).Activate
L = Application.WorksheetFunction.CountA(Range("C:C"))
For i = 2 To L
Set t = ActiveSheet.Range(Cells(i, 1), Cells(i, 1))
Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top + 5, t.Width, 20)
'arg = "'Invia Range("J1").Value , Cells(i, t.Column + 2).Value , Cells(i, t.Column+3).Value '"
With btn
.OnAction = arg
.Caption = "Invia"
.Name = "Btn" & i
End With
Next i
End Sub
My problem is I'm not able to write the string to pass to OnAction property in the correct way.
That should be the call to procedure Send with 3 parameters:
1) MailAddress: found in cell J1 (static)
2) Subject: found in columns C at the current row (i) of the loop
3) Body: found in column D at the current row (i) of the loop
Can't get it to work.
I'm quite new to VBA and I'm getting crazy with all those quotes, single quotes and double quotes.
May someone kindly help me?
Mhanks in advance,
Marco
arg = "'Send ""{1}"", ""{2}"", ""{3}"" '"
arg = Replace(arg,"{1}", Range("J1").Value)
arg = Replace(arg,"{2}", Cells(i, t.Column + 2).Value)
arg = Replace(arg,"{3}", Cells(i, t.Column+3).Value)
.OnAction = arg