I'm not a programmer so I apologize in advance.
I have three different worksheets in a workbook. Each sheet has a specific macro so that after numbers are entered, shift supervisors can press a button with the assigned macro and metrics from that sheet will be copied and pasted to a different worksheet in a format with filter-able/pivot-able columns. It then saves and closes the data, goes back to the shift report worksheet, copies the pertinent cells, then opens lotus and formats a new message with a subject line stating the correct shift number and date and pastes the shift report data into the body of the e-mail.
Since there is a different button to press on 3 worksheets, and I can't count on supervisors to enter numbers in any specific order, I need to be able to tell if Lotus has already opened and created an e-mail with that specific subject line to see if it needs to be created or if it exists with some information already in the body. Does anyone know if this is possible?
Dim NSession As Object
Dim NDatabase As Object
Dim NUIWorkSpace As Object
Dim NDoc As Object
Dim NUIdoc As Object
Dim WordApp As Object
Dim WordDoc As Object
Dim msg As String
msg = "Leads Report " & Now() & vbNewLine & vbNewLine & _
"Finishing:" & vbNewLine & _
"**PASTE Leadsheet CELLS HERE**" & vbNewLine & vbNewLine
Sheets("Leadsheet").Select
Set newRange = Range("e4")
mystring = RangeToString(newRange)
Set NSession = CreateObject("Notes.NotesSession")
Set NUIWorkSpace = CreateObject("Notes.NotesUIWorkspace")
Set NDatabase = NSession.GetDatabase("", "")
If Not NDatabase.IsOpen Then
NDatabase.OPENMAIL
End If
'Create a new document
'******************************(if statement to see
'if a document with specific subject line has already been
'created....'subject = doc.GetItemValue("subject")(0)???????
'****************************************
Set NDoc = NDatabase.createdocument
With NDoc
.SendTo = "email#email.com" 'CHANGE THIS
.CopyTo = ""
.Subject = Format(Date, "mm-dd-yyyy") & " Lead Report Shift " & mystring
'Email body text, including marker text which will be replaced by the Excel cells
.Body = msg
.Save True, False
End With
'Edit the just-created document to copy and paste the Excel cells into it
Set NUIdoc = NUIWorkSpace.editdocument(True, NDoc)
'Find the marker text in the Body item
'Replace it with the Excel cell
With NUIdoc
'leadsheet
Workbooks("Master Shift Report Sheet.xlsm").Activate
Sheets("LeadSheet").Select
Range("B2:o62").Select
ActiveWindow.zoom = 86
Selection.copy
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Add
With WordApp.Selection
.PasteSpecial DataType:=4 & vbNewLine
.wholestory
.copy
End With
.gotofield ("Body")
.findstring "**PASTE Leadsheet CELLS HERE**"
.Paste
'Application.CutCopyMode = False
'.Send
'.Close
End With
Set NSession = Nothing
anything else looks wonky don't hesitate to point it out! I'm learning.
Related
I have a workbook that is essentially an automated test, marking and feedback tool for end of topic tests for students. On the '701Test' sheetThey input their teaching group via a drop down list and the select their from subsequent list. They answer the multiple choice questions and press a button when finished. The button takes them to a 'results' page which gives their marks for each question, give feedback for incorrect answers and gives a total score. They then hit the finish button which generates a PDF copy of the mark sheet in their my documents folder and then emails a copy to themselves and the Schools email account. At this point I also wanted to post the final score to the students record on a central registry using a loop through the student list to find the name and offset to post the Score value from the 'Results' page and finally return to the test page. This last bit I wrote the code for in a module and it executes perfectly, but when added to the main code and run from the button the loop part fails to execute but the return to the test page does work, but no error is recorded for the loop failure.
Here is the 'Results' page code in full the 'With Central reg' bit at the bottom is the problem, any help is greatly appreciated.
Private Sub CommandButton1_Click()
Dim IsCreated As Boolean
Dim PdfFile As String, Title As String
Dim OutlApp As Object
Dim cell As Range
Dim Students As Range
Title = Range("D1").Value
sname = Range("B2").Value
PdfFile = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\" & sname & Title & ".pdf"
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
With OutlApp.CreateItem(0)
.Subject = Title
.to = Range("B2").Value ' <-- Put email of the recipient here"
.CC = "" ' <-- Put email of 'copy to' recipient here
.Body = "Hi," & vbLf & vbLf _
& "Yr 7 701 EOT test attached in PDF format." & vbLf & vbLf _
& "Regards," & vbLf _
& "KDS ICT Dept" & vbLf & vbLf
.Attachments.Add PdfFile
Application.Visible = True
.Display
End With
If IsCreated Then OutlApp.Quit
Set OutlApp = Nothing
With CentralReg
For Each cell In Range("A2:A250")
If cell = Range("Results!B2").Value Then
cell.Offset(0, 4).Activate
ActiveCell.Value = Range("Results!B27").Value
End If
Next
End With
End Sub
I believe you are trying to refer to CentralReg which is a worksheet, which means you should qualify it as such.
Also, you should not dim variables that are similar to defined objects/properties in VBE. Try MyCell instead of cell (good practice, not required).
I am assuming you want to see if the value on sheet CentralReg in Column A is equal to sheet Result B2. If this condition is met, your MyCell will take on the value equal sheet Result B27
Dim MyCell As Range
Dim Result, NewValue as Variant
Result = ThisWorkbook.Sheets("Result").Range("B2")
NewValue = ThisWorkbook.Sheets("Result").Range("B27")
With ThisWorkbook.Sheets("CentralReg")
For Each MyCell In .Range("A2:A250")
If MyCell = Result Then MyCell.Offset(, 4) = NewValue
Next MyCell
End With
That with statement is useless as nothing actually uses it within the construct.
Delete with CentralReg and End with and it will work.
alternatively if CentralReg IS something like a sheet then you need to precede your code with a . so this: Range("A2:A250") becomes this: .Range("A2:A250") and so on, the . tells the code that it is related to whatever your with construct surrounds
I have some undeliverable emails in a folder. I am trying to go through each email in the folder and pull out the intended recipients email address by searching the message.
I have some VBA code that works on regular emails, but since undeliverable's aren't Outlook "Mail Items", they are Outlook "Report Items", I am having issues searching the message. The search function is coming back empty and after a lot of research, it seems that maybe "Report Items" do not actually have a "body" that can be searched.
The email in all the error reports are in the following format in the report.
(xxxxxx#xxxxxx.com)
Here is the code I am using, which works on normal Mail Items.
Sub Undeliver()
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("MAPI")
'Selects the current active folder to use
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
'creates excel spreadsheet where data will go
Set xlobj = CreateObject("excel.application")
xlobj.Visible = True
xlobj.Workbooks.Add
'names column a row 1 "email" and column b row 1 "else"
xlobj.Range("a" & 1).Value = "Email"
xlobj.Range("b" & 1).Value = "Else"
'loops through all the items in the current folder selected
For I = 1 To myfolder.Items.Count
Set myitem = myfolder.Items(I)
'selects the body of the current email being searched
msgtext = myitem.Body
'searches the body for the first open parentheses and first close
'parentheses and copies the value in between into an array
delimtedMessage = Replace(msgtext, "(", "###")
delimtedMessage = Replace(delimtedMessage, ")", "###")
'splits the array up into two pieces
messageArray = Split(delimitedMessage, "###")
'this inputs the values of the array into my excel spreadsheet
xlobj.Range("a" & I + 1).Value = messageArray(1)
xlobj.Range("b" & I + 1).Value = messageArray(2)
Next I
End Sub
Does anyone know how I can access the message part of the report for searching purposes?
The solution I ended up going with involved converting the body of the message back to Unicode and then searching for what I needed. This ended up being very simple to implement.
Here is my finished, working code for future reference. I ended up adding a progress bar to monitor where it was in the code. It unfortunately runs fairly slow but it gets the job done.
Hopefully this helps someone in the future!
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("MAPI")
Set xlobj = CreateObject("excel.application")
xlobj.Visible = True
xlobj.Workbooks.Add
xlobj.Range("a" & 1).Value = "Email"
xlobj.Application.displayStatusBar = True
For I = 1 To myOlApp.ActiveExplorer.CurrentFolder.Items.Count
Set myitem = myOlApp.ActiveExplorer.CurrentFolder.Items(I)
msgtext = StrConv(myitem.Body, vbUnicode)
delimtedMessage = Replace(msgtext, "mailto:", "###")
delimtedMessage = Replace(delimtedMessage, "</a><br>", "###")
messageArray = Split(delimtedMessage, "###")
xlobj.Range("a" & I + 1).Value = Split(messageArray(1), """")(0)
xlobj.Application.StatusBar = "Progress: " & I & " of " & myOlApp.ActiveExplorer.CurrentFolder.Items.Count & Format(I / myOlApp.ActiveExplorer.CurrentFolder.Items.Count, " 0%")
Next I
xlobj.Application.displayStatusBar = False
Well, there is always this solution.
The gist is that ReportItem.Body returns an unreadable string, so this solution saves the ReportItem as a text file, then parses the text file. Its not exactly elegant, but it should work.
Hope this helps!
I have a worksheet that tracks invoices and I am trying to generate an auto-emailer that if a cell in column 12 contains AUTOEMAIL it will combine all of the rows with a similar email address which I've generated using a TRIM function. It will pull all of the like rows (Email Addresses based on column 15) into a LotusNotes Email. Ron De Bruin has some fantastic examples on his site. I attempted to write a loop which attempts to loop through and copy all rows based on an email address. When I go to run, the code does nothing but no errors are presented. There are instances online of this done in Outlook, but they don't apply to LotusNotes as the issue is late vs early binding. I'm newer to VBA automation as well.
Sub Send_Data()
Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim vaRecipient As Variant
Dim rnBody As Range
Dim Data As DataObject
Const stSubject As String = "TEST"
Const stMsg As String = "TEST"
Const stPrompt As String = "Please select the range:"
lastrow = Range("N" & Rows.Count).End(xlUp).row
For Each Cell In Range("N8:N" & lastrow)
If WorksheetFunction.CountIf(Range("N8:N" & Cell.row), Cell) = 1 Then
If Cells(Cell.row, 11) = "AUTOEMAIL" Then
rnBody = "Hello" & vbNewLine & vbNewLine & _
ActiveCell.EntireRow.Select
On Error Resume Next
'The user canceled the operation.
If rnBody Is Nothing Then Exit Sub
On Error GoTo 0
'Instantiate Lotus Notes COM's objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
'Make sure Lotus Notes is open and available.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Create the document for the e-mail.
Set noDocument = noDatabase.CreateDocument
'Copy the selected range into memory.
rnBody.Copy
'Retrieve the data from then copied range.
Set Data = New DataObject
Data.GetFromClipboard
'Add data to the mainproperties of the e-mail's document.
With noDocument
.Form = "Memo"
.SendTo = vaRecipient
.Subject = stSubject
'Retrieve the data from the clipboard.
.Body = stMsg & " " & Data.GetText
.SaveMessageOnSend = True
End With
' SEND EMAIL
With noDocument
.PostedDate = Now()
.Send 0, vaRecipient
End With
' REMOVE FROM MEMORY
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
'SWITCH BACK TO EXCEL
AppActivate "Microsoft Excel"
'EMPTY COPY-PAST CLIPBOARD
Application.CutCopyMode = False
' DISPLAYS TO USER IF SUCCESSFUL
MsgBox "Complete!", vbInformation
End If
End If
Next Cell
End Sub
I set the email body range as a Prompt Box where the user could highlight the cells and then another prompt box in which it asked for the email that was created using a TRIM() function. I realized that the way the code was set-up would not allow for what I wanted to do. The new method works quite well
Treevar
I have 10 columns of data with a varying number of rows which is emailed as an unformatted range. I want to be able to right pad the cells in each column with spaces so the unformatted range copies over as evenly spaced. The reason the range is unformatted is I am using LotusNotes and I don't have the integration options like I have with Outlook. Is there anyway without adding columns that I can pad the cells with a space character so the range looks good in an email?
EDIT: So this allows me to type in an email via an input box and select a range. It will create the email and send but it dosen't preserve the cell formatting (i.e spacing) Can this be done? I have tried using the MIME entities to use HTML however I'm not sure how I'd copy the range into the HTML body
Updated Code:
Sub Lotus_Email()
Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim vaRecipient As String
Dim rnBody As Range
Dim Data As DataObject
Const stSubject As String = "EMAIL SUBJECT"
Const stMsg As String = "Please review the following Purchase Orders and advise."
Const stPrompt As String = "Please select the range:"
'This is one technique to send an e-mail to many recipients but for larger
'number of recipients it's more convenient to read the recipient-list from
'a range in the workbook.
vaRecipient = InputBox("Please enter an e-mail address", "E-Mail Address Entry")
On Error Resume Next
Set rnBody = Application.InputBox(Prompt:=stPrompt, _
Default:=Selection.Address, Type:=8)
'The user canceled the operation.
If rnBody Is Nothing Then Exit Sub
On Error GoTo 0
'Instantiate Lotus Notes COM's objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
'Make sure Lotus Notes is open and available.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Create the document for the e-mail.
Set noDocument = noDatabase.CreateDocument
'Copy the selected range into memory.
rnBody.Copy
Set rtItem = noDocument.CreateRichTextItem("Body")
With rtItem
.appendtext ("LINE 1")
.addnewline (2)
.appendtext ("LINE 2")
.addnewline (2)
.addnewline (1)
.appendtext ("Please review and respond to the email noted above")
.appendtext ("TEST")
rnBody.PasteSpecial
End With
'Add data to the mainproperties of the e-mail's document.
With noDocument
.Form = "Memo"
.SendTo = vaRecipient
.Subject = stSubject
'Retrieve the data from the clipboard.
' NON-HTML BODY OFF
' .Body = stMsg & vbCrLf & vbCrLf & vbCrLf & vbCrLf & Data.GetText
.SaveMessageOnSend = True
End With
'Send the e-mail.
With noDocument
.PostedDate = Now()
.Send 0, vaRecipient
End With
'Release objects from memory.
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
'Activate Excel for the user.
AppActivate "Microsoft Excel"
'Empty the clipboard.
Application.CutCopyMode = False
MsgBox "The e-mail has successfully been created and distributed.", vbInformation
End Sub
UNTESTED. Maybe something like this?:
=A1&REPT(" ",25-LEN(A1))
So after using LotusNotes MIME I could import Rich Text, however it wouldn't preserve column width and excel formatting. I created a temp workbook with my range selection and attached it as an attachment. This seems to be the way to handle this with LotusNotes.
I am trying to create a tool that generates an invitation for a meeting using excel and lotus notes, and I am able to generate the email I want using code I found in StackOverflow and Lotus Notes API.
The only detail is that when I try to save the meeting in the calendar (without sending it. just save as a draft so someone could check the meeting details before sending the invitations) Lotus Notes will display the following message:
.
Is there a way to remove this message so the user won't see this message?
The code generating the meetings is below:
Private Sub salvaAppointment()
'Lotus notes objects
Set session = CreateObject("Notes.NotesSession")
Set Db = session.GetDatabase("", "")
'Prepare a document for the meeting
Call Db.OPENMAIL
Set doc = Db.CreateDocument
Set richText = doc.CreateRichTextItem("Body")
'Set meeting properties
Call doc.ReplaceItemValue("Form", "Appointment")
Call doc.ReplaceItemValue("AppointmentType", "3")
doc.Subject = "Reunião Caixa Rápido"
doc.CALENDARDATETIME = DateAdd("h", 15, Date)
doc.StartDateTime = DateAdd("h", 15, Date)
doc.EndDateTime = DateAdd("h", 17, Date)
doc.StartDate = Date
doc.Location = "Sala CCB"
'Email body
Call richText.AppendText("Modelo A3: ")
Call richText.AddNewLine(1, True)
modA3 = Application.ActiveWorkbook.Path & "\A3 Mod Modelo teste.ppt"
Call richText.EmbedObject(1454, modA3, modA3, "Attachment")
Call richText.AddNewLine(2, True)
Call richText.AppendText("**template**")
Call richText.Update
'Opens UI object to edit the document
Set UIWorkSpace = CreateObject("Notes.NotesUIWorkspace")
Set uidoc = UIWorkSpace.EDITDocument(True, doc)
'Fills meeting required destination
Set nomes = Range(Range("F1"), Range("F" & Rows.Count).End(xlUp))
For Each nome In nomes
Call uidoc.FieldAppendText("EnterSendTo", nome & ",")
Next nome
'Copy Excel cells to clipboard
Dim lastRow As Integer
lastRow = Range("E" & Rows.Count).End(xlUp).Row
Range("A1:E" & lastRow).Copy 'CHANGE SHEET AND RANGE TO BE COPIED AND PASTED
'Create a temporary Word Document
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False 'True to aid debugging
Set wdTemplate = WordApp.Documents.Open(Application.ActiveWorkbook.Path & "\templateEmail.doc")
'Paste into Word document and copy to clipboard
With wdTemplate.Bookmarks
.item("tabela").Range.PasteSpecial DataType:=10
End With
With WordApp.Selection
.WholeStory
.Copy
End With
'Find the marker text in the Body item
uidoc.GotoField ("Body")
uidoc.FINDSTRING "**template**"
'Paste from clipboard (Word) to Lotus Notes document
uidoc.Paste
Application.CutCopyMode = False
WordApp.Quit False
'When I call the below line, it displays the message
Call uidoc.Save
uidoc.Close
'Liberar memória
Set session = Nothing
Set UIWorkSpace = Nothing
'Deleta as planilhas temporárias
Sheets("dados").Delete
Sheets("temp").Delete
End Sub
I appreciate any help.
Notes recognizes a reserved field called MailOptions that is used to control automatic emailing when a document is saved. Try adding this within the block of code that you've got commented with 'Set meeting properties':
doc.ReplaceItemValue("MailOptions","0")