I am working on a spreadsheet that has to be completed quarterly so am looking to automate a lot of the process. I have a master tab - "#" and 16 Team tabs. On the # is a table which includes all 16 team names, I would like this table to update depending on what Teams have signed off.
Quick runthrough:
Spreadsheet is emailed out to multiple teams, each log in and review Products. After all products have been reviewed, they press the "Sign Off" button. This button does 3 things;
Inputs username and date to right of button
Sends email to spreadsheet owner
Updates table on "#" tab.
Number 3 is where I am having the issue. I have tried find, if, functions - lots of different options but just can't get it to work. Functions didn't work as the spreadsheet is reset every quarter so the cell values are cleared, so it needs to be VBA.
Some previous options I tried:
Sub If_Team 1()
'Set variables
Set sht1 = Sheets("#")
Set sht2 = Sheets("Team 1")
'Team1
If sht2.Range("M2:N2") <> "" Then
sht1.Range("C4:D4") = sht2.Range("M2:N2")
sht1.Range("B4") = "P"
Else
sht1.Range("C4:D4") = ""
sht1.Range("B4") = "O"
End If
Unfortunately this worked until I put in more If functions, where it then pasted the data in the whole table rather than just Team 1. The below also worked, until again adding more values where it pasted the data in every field where the criteria was met (which was them all).
If pfID = "Team 1" Then GoTo 1 Else
If pfID = "Team 2" Then GoTo 2 Else
1 sht2.Cells(3, 2).Value = "P"
sht2.Cells(3, 3).Value = Date
sht2.Cells(3, 4).Value = Environ("username")
On each team tab is the team name, so lets say "Team 1". Team 1 is found in Cell "F1" on the Active Team Sheet. On the # tab in the table, Team 1 is Cell "A3".
What I would like to happen is ActiveSheet.Range("F1") to find the same name on the # (sht2) tab, and then do the following if the names match (so as we know Team 1 on the # tab is "A3"):
sht2.Range("A4").Value = "P"
sht2.Cells("A5").Value = Date
sht2.Cells("A6").Value = Environ("username")
This way the spreadsheet owner will only need to review the # tab to see who has signed off, rather than go through each tab. However I don't want it to point to an invdividual cell like above as I would like it to find and match the names.
Here is the full code so far:
Sub Button2_Click() 'SIGN OFF BUTTON
Dim cellAddr As String
Dim aCol As Long
' Declare variables
Dim c As Integer ' Column
Dim emBody As String ' Body text of email
Dim emCnt As Integer ' Count of email addressees
Dim emTitl As String ' Subject line of email
Dim emTxt As String ' List of email addressees
Dim myOutlook As Object ' MS Outlook application
Dim mySendmail As Object ' The email to be sent
Dim pfID As String ' Platform ID
Dim r As Integer ' Row
'Set variables
Set sht1 = ActiveSheet
Set sht2 = Sheets("#")
'Cell Address
cellAddr = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address
'Column Number
aCol = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Column
'Input Date and Username
If aCol <> 1 Then _
sht1.Range(cellAddr).Offset(, 2).Value = Date
sht1.Range(cellAddr).Offset(, 1).Value = Environ("username")
' Obtain Platform details
pfID = ActiveSheet.Range("F1").Value
'Version ID
vID = sht2.Range("D1").Value
**'Input Sign Off on "#" Tab**
' Email subject line
emTitl = pfID & " - Out of Support Software Review " & vID & " Completed"
' Email body text
emBody = "<BODY style=font-size:12pt;font-family:Calibri>" & "Hi," & "<br>" & "<br>" & "Out of Support Software Review " & "<b>" & vID & "</b>" & " Completed for " & "<b>" & pfID & "</b>" & "."
Set myOutlook = CreateObject("Outlook.Application")
Set mySendmail = myOutlook.CreateItem(olMailItem)
With mySendmail
.to = ""
.Subject = emTitl
.HTMLBody = emBody
.Display
End With
' CLEAR.
Set objEmail = Nothing: Set objOutlook = Nothing
ErrHandler:
'
End Sub
Any help is appreciated, any questions let me know! Sorry if this is slightly confusing.
Related
I have a workbook which has individual sheets that house office data based on the office location (example; sheet named Chicago would have data for our Chicago office and so on and so forth). Currently on every sheet I have a button with an assigned macro that exports the sheet as a pdf and attaches it to a prefilled email that I can then send to that office's designated contact based on some code I found online that works perfectly. The email of the contact is located in the same cell in every sheet. (See code below). I only need to send this email to locations that haven't reached a certain benchmark.
Sub SendEmailBulk()
'Update 20131209
Dim Wb As Workbook
Dim ws As Worksheet
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
On Error Resume Next
Set Wb = ThisWorkbook
Set ws = Active.Sheet
FileName = Wb.FullName
xIndex = VBA.InStrRev(FileName, ".")
With ActiveSheet.PageSetup
.Orientation = xlLandscape
.FitToPagesTall = 1
.FitToPagesWide = 1
End With
If xIndex > 1 Then FileName = VBA.Left(FileName, xIndex - 1)
FileName = FileName & "_" + ActiveSheet.Name & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.SentOnBehalfOfName = "abc#xyz.com"
.To = ActiveSheet.Range("J10")
.CC = ""
.BCC = ""
.Subject = Range("C1") & " Data"
.Body = "abcxyz"
.Attachments.Add FileName
.Display
End With
Kill FileName
Set OutlookMail = Nothing
Set OutlookApp = Nothing
End Sub
What I would like to do is instead of having to check every sheet and send the emails individually to instead have some code that checks and emails only the required ones for me.
In another sheet I have a sheet called SUMMARY which contains a summary of all of our office locations in column B and a true or false counter setup that records whether they have achieved the benchmark in column C. I only need to send the above email to those locations who have not reached that benchmark (a FALSE value in column C).
I understand that I would need some code that checks the first row of the SUMMARY sheet for the first office location in Column B if it contains the FALSE value in Column C then, if so, assigns the value in Column B to a variable (lets say SheetName). Then the ActiveSheet reference would need to be replaced with WorkSheets("SheetName") to have the email code run before looping back around to check the second office location and so on until the end.
I have an idea of how this would work in theory I just don't have the exact VBA knowledge on how to write something to this effect. Any help would be greatly appreciated.
Good afternoon,
I have an Outlook .msg email saved at a local folder in my computer.
Is there any way I can replace the word "AAAA" in the body with any word I want in VBA?
Is there any way I can change the To: field?
The goal is to run an Excel table and create copies of a template message, replace the To: field and some words of the template with the info in the Excel table and save it. We will manually send latter.
I only need the .msg file modifying code (To: field and body replaces). The loop is already coded.
Thank you so much,
The Outlook object model doesn't provide anything to edit MSG files out of the box. But you can automate Outlook to create an item, edit it and then save it back as a template.
Use the Application.CreateItemFromTemplate method which creates a new Microsoft Outlook item from an Outlook template (.oft) and returns the new item. So, you can create a new item based on the template saved on the disk and then replace everything you need there. Then you could save it back as a template or send the item out. Read more about that in the How To: Create a new Outlook message based on a template article.
You can use Application.Session.OpenSharedItem to open an MSG file, modify the returned MailItem object (Subject / HTMLBody / Recipients), then call MAilItem.Save to update the MSG file.
If anyone needs, here it is the code I used. Do not focus on the for loops, but in the way the msg is loaded, edited and saved.
In this example some words in the msg file are replaced for the values in an excel table, as well as the TO: (email receiver). e.g. word AA in a msg file is changed with the value of the C7 cell.
The aim is to create a msg as a template with some key words (AA, BB, CC, etc), copy that template, replace those words with the ones in the excel table and save the new msg file.
Sub Recorrer()
Dim x As Integer
Dim fsObject As Object
Dim outApp As Object 'Outlook.Application
Dim outEmail As Object 'Outlook.MailItem
Dim outRecipient As Object 'Outlook.Recipient
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If outApp Is Nothing Then
MsgBox "Outlook is not open"
Exit Sub
End If
On Error GoTo 0
Set fsObject = CreateObject("Scripting.FileSystemObject")
' Set numcols = number of cols to be replaced.
NumCols = Range("C1", Range("C1").End(xlToRight)).Cells.Count
' Set numrows = number of rows of data.
NumRows = Range("A2", Range("A2").End(xlDown)).Rows.Count
' Select cell a1.
Range("A2").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
fsObject.CopyFile ThisWorkbook.Path & "\" & Range("B" & x + 1) & ".msg", ThisWorkbook.Path & "\Correos\" & Range("B" & x + 1) & "_" & Range("C" & x + 1) & ".msg"
Set outEmail = outApp.Session.OpenSharedItem(ThisWorkbook.Path & "\Correos\" & Range("B" & x + 1) & "_" & Range("C" & x + 1) & ".msg")
outEmail.Recipients.Add Range("A" & x + 1)
For Z = 1 To NumCols
'MsgBox Cells(x + 1, Z + 2)
outEmail.HTMLBody = Replace(outEmail.HTMLBody, Cells(1, Z + 2), Cells(x + 1, Z + 2))
Next
outEmail.Save
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next
End Sub
I have am working on a report to pull employees with end dates between two unbound text fields on a form. The report is grouped on Supervisor. My goal is to save each report grouping as unique PDFs with the PDF name as the [Supervisor] - John Smith.PDF, Jill Smith.pdf etc. This report is attached to an email, which is opened and waiting for adjustment prior to sending.
Currently, this works except for a couple issues that I am trying to solve:
I get a Parameter popup asking for StartDate and EndDate (my parameters set to the form text fields) before each report opening. I have to manually enter this date for each parameter before each report, it is not populating from the form.
I get multiple emails opened for each supervisor. Some have blank reports. It seems like I am getting one for each record of each report, with the parameter popup for each.
After I hit the button, I input the dates into the parameter popups. My reports opens, saves, closes, and an email is generated correctly. Instead of moving to the next report/email automatically, I have to manually enter the date into the parameter popups again.
My Form has two fields Text0 and Text2 and a Button that will print a report based on the query below using VBA.
Query SQL:
SELECT DISTINCT [Active and Expired Badges].Supervisor_Clean, [Active and Expired Badges].FIRSTNAME, [Active and Expired Badges].LASTNAME, [Active and Expired Badges].[Premera ID], [Active and Expired Badges].Company, [Active and Expired Badges].Title, [Active and Expired Badges].[End Date], [FIRSTNAME] & " " & [LASTNAME] AS Name
FROM [Active and Expired Badges]
WHERE ((([Active and Expired Badges].Title) Like "*" & "outsource" & "*" Or ([Active and Expired Badges].Title) Like "*" & "Contingent" & "*") AND (([Active and Expired Badges].[End Date]) Between [StartDate:] And [StopDate:]));
Button VBA:
Private Sub Command5_Click()
'split report into PDFs named after supervisor and open a separate email with each report attached
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim MyFileName As String
Dim mypath As String
Dim temp As String
Dim qry As QueryDef
Dim StartDate As DAO.Parameter
Dim StopDate As DAO.Parameter
Set db = CurrentDb()
Set qry = db.QueryDefs("30-Day query")
mypath = "C:\Users\cw52450\Desktop\Test Exports\"
qry.Parameters("StartDate").Value = [Forms]![EndDate]![Text0]
qry.Parameters("StopDate").Value = [Forms]![EndDate]![Text2]
Set rs = qry.OpenRecordset(dbOpenSnapshot)
If Not (rs.EOF And rs.BOF) Then
'populate rs
rs.MoveLast
rs.MoveFirst
'start report generation loop
Do While Not rs.EOF
temp = rs("Supervisor_Clean")
MyFileName = rs("Supervisor_Clean") & Format(Date, ", mmm yyyy") & ".PDF"
DoCmd.OpenReport "End Date Report", acViewReport, , "[Supervisor_Clean]='" & temp & "'"
DoCmd.OutputTo acOutputReport, "", acFormatPDF, mypath & MyFileName
DoCmd.Close acReport, "End Date Report"
DoEvents
'start mail section
open Outlook, attach zip folder or file, send e-mail
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
With MailOutLook
.SendUsingAccount = appOutLook.Session.Accounts.Item(2)
.BodyFormat = olFormatRichText
'.To = ""
''.cc = ""
''.bcc = ""
.Subject = "Non-Employees with Expiring Building Access"
.HTMLBody = "<html><body><p>Hello,</p><p>The attached report... </p></body></html>"
.Attachments.Add (mypath & MyFileName)
'.DeleteAfterSubmit = True 'This would let Outlook send the note without storing it in your sent bin
.Display
End With
'end mail section
rs.MoveNext
Loop
Else
MsgBox "There are no records in the recordset."
End If
MsgBox "Report generation complete."
Set rs = Nothing
Set db = Nothing
Set qry = Nothing
End Sub
The popup for parameters could be because of incorrect syntax here:
qry.Parameters("StartDate").Value = [Forms]![EndDate]![Text0]
qry.Parameters("StopDate").Value = [Forms]![EndDate]![Text2]
Try to change it to:
qry.Parameters("StartDate").Value = Me.Text0
qry.Parameters("StopDate").Value = Me.Text2
I work in bank and we have a lot of restrictions. I can't use the Developer option in Outlook. I can use Excel VBA.
I would like to automate saving a zip file, which is received everyday, in a local drive folder and automatically unzip it and replace the yesterday's file.
I would like to create a button in an Excel sheet. Once I press the button the attachment in Outlook should save in a local folder in whatever destination I want and the attachment should unzip.
I have tried some things saving attachments from Outlook by using VBA, but it doesn't help much.
I am not surprised a bank doesn’t want its emails accessed. You could change the sender, add or remove recipients or change the text. It is difficult to do any of these without leaving a trail but it is possible. You do not want to change anything; you just want to automate saving an attachment so this might be allowed by your tech people and Outlook.
Before attempting the more complicated parts of your requirement, let us check your requirement is possible. I do not know how much you know about Excel VBA. If I ask you to do something you do not understand, come back with questions.
Create a macro-enabled workbook somewhere convenient. The name of the workbook does not matter.
Open the workbook and then the VBA Editor.
Click [Tools] and then [References]. You will get a drop-down menu of all the available libraries. Scroll down until you find “Microsoft Outlook nn.0 Object Library”. “nn” identifies the version of Outlook in use which I understand will be “14” for you. Click the box to the left and a tick will appear. Click [OK]. This will give you access to Outlook from Excel.
In the Project Explorer, you will see something like:
- VBAProject (YourNameForWorkbook.xlsm)
- Microsoft Excel Objects
Sheet1 (Sheet1)
ThisWorkbook
If either of the minuses is a plus, click that plus.
Click [ThisWorkbook]. An empty code area will appear on the right of the VBA Editor window. Copy the code below to this area.
Within the code you will find lines starting ‘###. These lines tell you about changes you must make or things you must check. Make the necessary changes and then save and close the workbook. Reopen the workbook. With good fortune, the macro will run automatically and the default worksheet will report what it has done. It will probably have found the wrong email and saved the wrong attachment. This does not matter. If you can save any attachment, you can save the attachment you want.
Option Explicit
Sub Workbook_Open()
'### Replace "C:\DataArea\SO\" with the name of a disc folder on your system
' Make sure your folder name ends with \.
Const DiscFldrDest As String = "C:\DataArea\SO\"
'### The name of the default worksheet depend on the local language. Replace
' "Sheet1" is this is not the default name for you.
Const WshtOutName As String = "Sheet1"
' ### The subject of the email. Correct if I have misunderstood your comment ' ###
Const Subject As String = "ISIN List: Financial Sanctions - ISIN screening" ' ###
Dim AppOut As Outlook.Application
Dim Found As Boolean
Dim InxA As Long
Dim InxI As Long
Dim OutFldrInbox As Outlook.Folder
Dim RowNext As Long
Dim WshtOut As Worksheet
Set AppOut = CreateObject("Outlook.Application")
With AppOut
With .Session
Set OutFldrInbox = .GetDefaultFolder(olFolderInbox)
End With
End With
Set WshtOut = Worksheets(WshtOutName)
RowNext = WshtOut.Cells(Rows.Count, "A").End(xlUp).Row + 1
'### Change if you prefer different date or time formats
WshtOut.Cells(RowNext, "A").Value = "Macro activated at " & _
Format(Now(), "h:mm") & " on " & _
Format(Now(), "d mmm yy")
RowNext = RowNext + 1
'### GetDefaultFolder is not much use on my system because I have two
' email addresses, each with their own Inbox, neither of which is
' the default Inbox. Probably you only have one work email address
' which is the default for you. To check, the following statement
' outputs the name of the default Inbox's mailbox. Tell me if it is
' not the mail box you want.
WshtOut.Cells(RowNext, "A").Value = Space(6) & "Inbox accessed"
WshtOut.Cells(RowNext, "B").Value = OutFldrInbox.Parent.Name
RowNext = RowNext + 1
Found = False
With OutFldrInbox
For InxI = .Items.Count To 1 Step -1
With .Items(InxI)
If .Subject = Subject And .Attachments.Count > 0 Then '###
WshtOut.Cells(RowNext, "A").Value = Space(6) & "Attachment saved from email" '###
WshtOut.Cells(RowNext, "B").Value = "With subject"
WshtOut.Cells(RowNext, "C").Value = .Subject
RowNext = RowNext + 1
WshtOut.Cells(RowNext, "B").Value = "Received"
'WshtOut.Cells(RowNext, "C").Value = .ReceivedTime
WshtOut.Cells(RowNext, "C").Value = Format(.ReceivedTime, "\a\t h:mm \o\n d mmm yy")
'WshtOut.Cells(RowNext, "C").NumberFormat = "at h:mm on d mmm yy"
RowNext = RowNext + 1
WshtOut.Cells(RowNext, "A").Value = Space(6) & "Attachment saved" '###
For InxA = 1 To .Attachments.Count '###
If UCase(Right$(.Attachments(InxA), 4)) = ".ZIP" Then '###
WshtOut.Cells(RowNext, "B").Value = .Attachments(InxA).Filename '###
.Attachments(1).SaveAsFile DiscFldrDest & .Attachments(1).Filename '###
Found = True '###
Exit For '###
End If '###
Next '###
End If
End With
Next
With WshtOut
If Not Found Then
.Cells(RowNext, "B").Value = "No email with correct subject and a ZIP attachment found"
RowNext = RowNext + 1
End If
.Columns.AutoFit
.Cells(RowNext, "A").Select
End With
End With
End Sub
I am working on a script to automate OOO in Outlook by reading an MS Excel sheet.
The script reads start date and end date from an input spreadsheet and then sets the out of office replies in Outlook for those dates.
This script gets the current date, and if the start date read from the spreadsheet is tomorrow's date, then it will prompt the user.
The idea is to remind the user to set OOO and then automatically set it upon user's confirmation. For example, if the start date and end date from the excel sheet are 21-Oct-2016 and 24-Oct-2016 and if this script is run on 20-Oct-2016, it should be able to set the OOO starting 21-Oct-2016 till 24-Oct-2016 automatically (without having to open MS Outlook)
So far, I am able to read the spreadsheet and get the dates. However, I am not able to set OOO for a future period.
Here's the code in progress:
Sub ReadDataAndSetOOO()
Dim objExcel,ObjWorkbook,objsheet
intRow = 2
Dim startDateValue, endDateValue
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\input.xlsx")
set objsheet = objExcel.ActiveWorkbook.Worksheets(1)
DateToday = FormatDateTime(Date, 1)
DateTomorrow = formatDate(FormatDateTime(DateAdd("d", 1, DateToday), 1))
Wscript.Echo DateTomorrow
Do Until objExcel.Cells(intRow,1).Value = ""
startDateValue = formatDate(FormatDateTime(objsheet.Cells(intRow,1).value,1))
endDateValue = formatDate(FormatDateTime(objsheet.Cells(intRow,2).value))
Wscript.Echo "Start date=" & startDateValue
Wscript.Echo "End date=" & endDateValue
If DateTomorrow = startDateValue Then
'Following line to be replaced by the code to set OOO between start and end date
Wscript.Echo "I am on leave from " & startDateValue & " to " & endDateValue
End If
intRow = intRow + 1
Loop
objExcel.ActiveWorkbook.Close
objExcel.Workbooks.Close
objExcel.Application.Quit
End Sub
Function formatDate(myDate)
d = parse(Day(myDate))
m = parse(Month(myDate))
y = Year(myDate)
formatDate= d & "-" & m & "-" & y
End Function
Function parse(num)
If(Len(num)=1) Then
parse="0"&num
Else
parse=num
End If
End Function
ReadDataAndSetOOO
I referred to this link and some other links, but everywhere, OOO is set immediately and not for required start and end dates.
Any pointers are appreciated.
OOF time range can only be set through EWS, namely using the UserOofSettings verb. It cannot be set using Outlook Object Model or Extended MAPI.
If using Redemption is an option (I am its author), it exposes the RDOOutOfOfficeAssistant object. Since it performs an EWS call, it will need the credentials of the mailbox user.
set Session = CreateObject("Redemption.RDOSession")
Session.MAPIOBJECT = Application.Session.MAPIOBJECT
Session.Credentials.Add "*.myserver.com", "Domain\UserName", "MyPassword"
set OofAssistant = Session.Stores.DefaultStore.OutOfOfficeAssistant
OofAssistant.BeginUpdate
OofAssistant.StartTime = #12/21/2011#
OofAssistant.EndTime = #01/03/2012 9:00#
OofAssistant.State = 2 'rdoOofScheduled
OofAssistant.ExternalAudience = 1 'rdoOofAudienceKnown
OofAssistant.OutOfOfficeTextInternal = "<html><body>I am on vacation from 12/21/2001 until 01/03/2012. Please contact " & _
"Joe User" & _
" if you have any questions</body></html>"
OofAssistant.OutOfOfficeTextExternal = "<html><body>I am on <b>vacation</b> until next year. </body></html>"
OofAssistant.EndUpdate