The VBA code currently works fine, but it will run continuously within the time period assigned to the code. I wish to add some coding, so that the VBA code will stop, once it has sent the first successful mail but still restart the next day. The VBA code is running for 1 hour, and the mail could be sent whenever within this period. Currently the model is sending several mails per day. The VBA is written as per below:
Sub AutoRefresh4(when As Date)
Application.OnTime when, "VLCC_Report"
End Sub
Sub VLCC_Report()
Dim LastSavedDate As Date
LastSavedDate = Format(FileDateTime("XXX"), "dd.mm.yyyy")
Dim TodaysDate As Date
Dim TimeStart, TimeEnd
TimeStart = TimeSerial(10, 0, 0)
TimeEnd = TimeSerial(11, 0, 0)
TodaysDate = Format(Now(), "dd.mm.yyyy")
If TodaysDate = LastSavedDate Then
Application.DisplayAlerts = False
Workbooks.Open ("YYY")
Workbooks.Open ("XXX")
If Workbooks("YYY").Worksheets(2).Range("F1") = 0 Then
Workbooks("XXX").Worksheets(1).Range("A1:Q71").Copy
Workbooks("YYY").Worksheets(2).Range("A2:Q72").PasteSpecial (xlPasteValues)
Workbooks("YYY").Worksheets(2).Range("A1") = "Last Refreshed:"
Workbooks("YYY").Worksheets(2).Range("C1") = Now
End If
End If
If Workbooks("YYY").Worksheets(2).Range("F1") = 1 Then
Dim EmailApplication As Object
Dim EmailItem As Object
Dim Table As Range
Dim Pic As Picture
Dim Sheet As Worksheet
Dim WordDoc As Word.document
Dim Path As String
Dim Filename As String
Dim SHP As Object
Path = "C:\ "
Filename = "VLCC Report" & ".pdf"
Set Sheet = Workbooks("YYY").Worksheets(1)
Set Table = Sheet.Range("B3:I73")
Table.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & Filename, IgnorePrintAreas:=True
Set EmailApplication = CreateObject("Outlook.Application")
Set EmailItem = EmailApplication.CreateItem(0)
Set Sheet = Workbooks("YYY").Worksheets(1)
Set Table = Sheet.Range("B3:I73")
Sheet.Activate
Table.Copy
Set Pic = Sheet.Pictures.Paste
Pic.Cut
With EmailItem
EmailItem.To = "aaa"
EmailItem.CC = ""
EmailItem.Bcc = ""
EmailItem.Importance = 2
EmailItem.Subject = "VLCC Report " & Format(Date, "DD.MM.YYYY")
EmailItem.Attachments.Add ("C:\")
EmailItem.Display
Set WordDoc = EmailItem.GetInspector.WordEditor
With WordDoc.Range
.PasteAndFormat wdChartPicture
.Application.Selection.Paragraphs.Alignment = wdAlignParagraphCenter
With WordDoc.InlineShapes(1)
.ScaleHeight = 110
End With
End With
EmailItem.HTMLBody = "<Body style = font-size:11pt; font-family:Calibri>" & "Hi, <p>Please see table below: <p>" & .HTMLBody
End With
EmailItem.Send
Set EmailItem = Nothing
Set EmailApplication = Nothing
End If
If Workbooks("YYY ").Worksheets(1).Range("F1") = 1 Then
Dim EmailApplication2 As Object
Dim EmailItem2 As Object
Set EmailApplication2 = CreateObject("Outlook.Application")
Set EmailItem2 = EmailApplication.CreateItem(0)
EmailItem.To = "aaa"
EmailItem.CC = ""
EmailItem.Bcc = ""
EmailItem.Importance = 2
EmailItem.Subject = "ERROR: VLCC Report"
EmailItem.Body = "Hi," & Chr(10) & Chr(10) & "Please check VLCC report" & Chr(10) & Chr(10) & "Best regards" & Chr(10) & "André Blokhus"
EmailItem.Send
Set EmailItem = Nothing
Set EmailApplication = Nothing
End If
Application.CutCopyMode = False
Workbooks("XXX").Save
Workbooks("XXX").Close SaveChanges:=False
Workbooks("YYY ").Save
Workbooks("YYY").SaveAs ("YYY, "DD.MM.YY") & ".xlsx?web=1")
Workbooks("YYY - " & Format(Now(), "DD.MM.YY") & ".xlsx").Save
Workbooks("YYY - " & Format(Now(), "DD.MM.YY") & ".xlsx").Close
Application.DisplayAlerts = True
If Time > TimeStart And Time < TimeEnd Then
AutoRefresh4 Now + TimeSerial(0, 15, 0)
Else
If Time < TimeStart Then AutoRefresh4 Date + TimeStart
If Time > TimeStart Then AutoRefresh4 (Date + 1) + TimeStart
End If
End Sub
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 set up my Excel workbook to generate Outlook emails with either a Word or pdf attachment from data entered into a table using VBA.
When I enter the criteria to generate the email with attachment, the attachment name puts "John%20Doe" instead of "John Doe".
How can I get rid of the %20 and have the space between first and last name instead?
Sub CreateWordDocuments()
'CREATE A WORD DOCUMENT TO TRANSFER INFORMATION FROM FILTERED DATA INTO A WORD
TEMPLATE
Dim VSCRow, VSCCol, LastRow, TemplRow, MonthNumber, FromMonth, ToMonth, DaysOfMonth,
FromDays, ToDays As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim CurDt, LastAppDt As Date
Dim WordDoc, WordApp, OutApp, OutMail As Object
Dim WordContent As Word.Range
With Sheet5
If .Range("B3").Value = Empty Then
MsgBox "Please select the correct template from the drop down list"
.Range("F4").Select
Exit Sub
End If
TemplRow = .Range("B3").Value ' Set the Template Value
TemplName = .Range("F4").Value ' Set Template Name
MonthNumber = .Range("V4").Value 'Set the Month Number
FromMonth = .Range("W4").Value
ToMonth = .Range("Y4").Value
DaysOfMonth = .Range("AA4").Value
FromDays = .Range("AC4").Value
ToDays = .Range("AF4").Value
DocLoc = Sheet10.Range("F" & TemplRow).Value ' Word Document Filename
'Open Word Template
On Error Resume Next 'If Word is already open
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
' Launch a new instance of Word
Err.Clear
'On Error GoTo Error_Handler
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Make the application visible to the user
End If
LastRow = .Range("E99999").End(xlUp).Row 'Determine the last Row
For VSCRow = 8 To LastRow
MonthNumber = .Range("X" & VSCRow).Value
DaysOfMonth = .Range("AF" & VSCRow).Value
If TemplName <> .Range("Z" & VSCRow).Value And MonthNumber >= FromMonth And
MonthNumber <= ToMonth And DaysOfMonth >= FromDays And DaysOfMonth <= ToDays Then
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) ' Open
Template
For VSCCol = 5 To 42 'Move through the colunms for information
TagName = .Cells(7, VSCCol).Value 'Tag Name
TagValue = .Cells(VSCRow, VSCCol).Value 'Tag Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Forward:True, Wrap:=wdFindContinue
End With
Next VSCCol
If .Range("H4").Value = "PDF" Then
FileName = ThisWorkbook.Path & "\" & .Range("E" & VSCRow).Value & ".pdf" '
Create full filename and path with current workbook
WordDoc.ExportAsFixedFormat OutputFileName:=FileName,
ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else:
FileName = ThisWorkbook.Path & "\" & .Range("E" & VSCRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
.Range("Z" & VSCRow).Value = TemplName 'Template Name to use
.Range("AA" & VSCRow).Value = Now
If .Range("S4").Value = "Email" Then
Set OutApp = CreateObject("Outlook.Application") 'Create Outlook Application
Set OutMail = OutApp.CreateItem(0) 'Create The Email
With OutMail
.To = Sheet5.Range("Y" & VSCRow).Value
.Subject = "Performance Metrics Verification, " & Sheet5.Range("R" & VSCRow).Value & "
- " & Sheet5.Range("S" & VSCRow).Value & ", " & Sheet5.Range("T" & VSCRow).Value
.Body = "Good afternoon, " & Sheet5.Range("E" & VSCRow).Value & ", here are your " &
Sheet5.Range("R" & VSCRow).Value & " - " & Sheet5.Range("S" & VSCRow).Value & ", " &
Sheet5.Range("T" & VSCRow).Value & " performance metrics as captured by the WFW database
systems. Please review and sign. Comments may be included in the email body. Please
return to me by COB " & Sheet5.Range("AG" & VSCRow).Value & ", If this date falls on a
holiday, return on the next business day following the holiday."
.Attachments.Add FileName
.Display 'To send without displaying .Display to .Send
End With
Else
WordDoc.PrintOut
WordDoc.Close
End If
Kill (FileName) 'Deletes the PDF or Word that was just created
End If '3 conditions are met
Next VSCRow
WordApp.Quit
End With
End Sub
I believe in early 2020 outlook had an update that caused inserted HTML images to not be visible to external parties.
At my old company we had a developer who was able to write something that allowed the image to be visible. I wasn't, and am still not, well versed in coding and have been piecing together stuff, but I can't figure this one out. Not even sure where to start. Any ideas?
If any of the vba below can be cleaned up, please let me know.
Sub Email()
'Create and assign email variables
Dim OutApp As Object
Dim OutMail As Object
'Create and assign JPEF variable
Dim MakeJPG As String
'create and assign workbook variable
Dim wb As Workbook
'create and assign File path variable
Dim Filepath As String
'Create and assign File name variable
Dim Filename As String
'Create and assign File date variable
Dim Filedate As String
'Create and assign Folder Year variable
Dim folderyear As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Filepath = Format(Range("filepath"))
Filename = Format(Range("filename"))
Filedate = Format(Range("trade_date"), "ddmmmyyyy")
folderyear = Format(Range("trade_date"), "yyyy")
'========================================================================
'Copy range you want to paste on new worksheet
Worksheets("Sheet1").Range("A1:Q31").Copy
'Open new workbook
Set wb = Workbooks.Add
Application.DisplayAlerts = False
'paste copied range
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False
ActiveSheet.Paste
'Adjust Window Zoom
ActiveWindow.Zoom = 80
'Adjust Gridlines
ActiveWindow.DisplayGridlines = False
'Adjust Header Row Height
Rows("2:5").Select
Selection.RowHeight = 25.5
Rows("6").Select
Selection.RowHeight = 21
'Adjust DA Sales Column Width
Columns("A").ColumnWidth = 6
Columns("B").ColumnWidth = 12
Columns("C").ColumnWidth = 14
Columns("D:E").ColumnWidth = 10
Columns("F").ColumnWidth = 39
Columns("G").ColumnWidth = 10
Columns("H").ColumnWidth = 16
'Adjust RT Sales Column Width
Columns("I").ColumnWidth = 4
Columns("J").ColumnWidth = 12
Columns("K").ColumnWidth = 14
Columns("L:M").ColumnWidth = 10
Columns("N").ColumnWidth = 39
Columns("O").ColumnWidth = 10
Columns("P").ColumnWidth = 16
Columns("Q").ColumnWidth = 6
'Rename worksheet
ActiveSheet.Name = "Sheet1"
'Save new worksheet with pasted range
wb.SaveAs Filename:=Filepath & Filename & " " & Filedate & ".xlsx"
Application.DisplayAlerts = True
'Close active workbook
ActiveWorkbook.Close True
'========================================================================
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'========================================================================
'Create JPG file of the range
'Only enter the Sheet name and the range address
MakeJPG = CopyRangeToJPG("Sheet1", "A1:Q31")
If MakeJPG = "" Then
MsgBox "Something went wrong, can't create email"
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Exit Sub
End If
On Error Resume Next
'========================================================================
With OutMail
.SentOnBehalfOfName = "My Company"
.BodyFormat = olFormatHTML
.Display
End With
Signature = OutMail.HTMLBody
'========================================================================
'Define & Assign To email list using a named range
Set emailRng = Worksheets("Sheet1").Range("to_email")
For Each cl In emailRng
sTo = sTo & ";" & cl.Value
Next
sTo = Mid(sTo, 2)
'Define & Assign CC email list
Set emailRng2 = Worksheets("Sheet1").Range("cc_email")
For Each cl2 In emailRng2
sCc = sCc & ";" & cl2.Value
Next
sCc = Mid(sCc, 2)
'========================================================================
With OutMail
.To = sTo '"Manually enter email address here"
.cc = sCc '"Manually enter email address here"
.BCC = ""
.Subject = Filename & " " & Range("trade_date")
.Attachments.Add MakeJPG, 1, 0
'Note: Change the width and height as needed
.HTMLBody = "<html><p>" & strbody & "</p><img src=""cid:NamePicture.jpg"" width=1150 height=600></html>" & "<br><br>" & Signature & "<br><br>"
.Attachments.Add Filepath & Filename & " " & Filedate & ".xlsx"
.Display 'or use .Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
'========================================================================
Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
Dim PictureRange As Range
With ActiveWorkbook
On Error Resume Next
.Worksheets(NameWorksheet).Activate
Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
If PictureRange Is Nothing Then
MsgBox "Sorry this is not a correct range"
On Error GoTo 0
Exit Function
End If
PictureRange.CopyPicture
With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
End With
.Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
End With
CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
Set PictureRange = Nothing
End Function
Create an HTML table from the range rather than an image attachment.
Option Explicit
Sub Email()
Const RNG_EMAIL = "A1:Q31"
Dim wb As Workbook, ws As Worksheet
Dim filepath As String, filename As String
Dim filedate As String, FolderYear As String
Dim rng As Range, msg As String
Set ws = ThisWorkbook.Sheets("Sheet1")
filepath = Range("filepath")
filename = Range("filename")
filedate = Format(Range("trade_date"), "ddmmmyyyy")
FolderYear = Format(Range("trade_date"), "yyyy")
'Copy range you want to paste on new worksheet
Set rng = ws.Range(RNG_EMAIL)
rng.Copy
Set wb = Workbooks.Add(xlWBATWorksheet) ' one sheet
wb.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
Operation:=xlNone, SkipBlanks:=False
FormatSheet wb.Sheets(1)
With ActiveWindow
.Zoom = 80
.DisplayGridlines = False
End With
'Save new worksheet with pasted range and close
Application.DisplayAlerts = False
wb.SaveAs filename:=filepath & filename & " " & filedate & ".xlsx"
Application.DisplayAlerts = True
wb.Close False
' prepare and send email
msg = SendEmail(ws, rng)
MsgBox msg, vbInformation
End Sub
Function SendEmail(ws As Worksheet, rng As Range) As String
Const CSS = "body{font:12px Verdana};p{font:14px Verdana Bold};"
Dim OutApp As Object, OutMail As Object, cell As Range
Dim sTo As String, sCc As String
Dim signature As String, strbody As String
' some message text
strbody = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, " & _
"sed do eiusmod tempor incididunt ut labore et dolore magna aliqua"
'Define & Assign To email list using a named range
For Each cell In ws.Range("to_email")
sTo = sTo & ";" & cell.Value
Next
sTo = Mid(sTo, 2)
'Define & Assign CC email list
For Each cell In ws.Range("cc_email")
sCc = sCc & ";" & cell.Value
Next
sCc = Mid(sCc, 2)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SentOnBehalfOfName = "My Company"
.BodyFormat = olFormatHTML
.To = sTo
.cc = sCc
.BCC = ""
.Subject = Range("filename") & " " & Range("trade_date")
signature = .HTMLBody
.HTMLBody = "<html><style>" & CSS & "</style><p>" & strbody & "</p>" & _
RngToHtml(rng) & "<br><br>" & signature & "</html>"
.Display 'or use .Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
SendEmail = "Email sent to " & sTo
End Function
Function RngToHtml(rng As Range)
Dim t As String, r As Long, c As Long
For r = 1 To rng.Rows.Count
t = t & "<tr>"
For c = 1 To rng.Columns.Count
t = t & "<td>" & rng.Cells(r, c) & "</td>"
Next
t = t & "</tr>" & vbCrLf
Next
RngToHtml = "<table width=""1150"">" & t & "</table>"
End Function
Sub FormatSheet(ws As Worksheet)
Dim colWidth, c As Integer
'DA and RT Sales Column Width A-Q
colWidth = Array(6, 12, 14, 10, 10, 39, 10, 16, _
4, 12, 14, 10, 10, 39, 10, 16, 6)
With ws
.Rows("2:5").RowHeight = 25.5
.Rows("6").RowHeight = 21
For c = 0 To UBound(colWidth)
.Columns(c + 1).ColumnWidth = colWidth(c)
Next
End With
End Sub
I wrote code to send automated birthday emails using Outlook and PPT. My code was working fine for a while and was getting the result as expected. All of the sudden, I started getting error 91 and debugging tool points to the line, where the PPT closes.
myDOBPPT.Close
I have declared the PPT and assigned a destination path for my template.
Any clues or solution on why this is occurring all of a sudden?
Option Explicit
Private Sub Btn_SendEmail_Click()
'Declaring Outlook
Dim OutlookApp As Outlook.Application
Dim OutlookMail As Outlook.MailItem
'Declaring Sender Outlook
Dim SenderOutlookApp As Outlook.Application
Dim SenderOutlookMail As Outlook.MailItem
'Declaring PPT
Dim objPPT As PowerPoint.Application
Dim myDOBPPT As PowerPoint.Presentation
Dim DestinationPPT As String
'Assigning Path of files
DestinationPPT = "C:\Users\charles.hill\Desktop\BirthdayAutomation\Birthday_Automation.pptx"
'Declaring and assigning values for varibales
Dim i As Long
i = 2
Dim randomslidenumber As Integer
Dim FirstSlide As Double
Dim LastSlide As Double
Dim Mydate As Date
Mydate = Date
'Declaring the Logo Image
Dim LogoImage As String
'Assigning Path of files
LogoImage = "C:\Users\charles.hill\Pictures\Saved Pictures\TIGA Logo.jpg"
'Worksheets("Emp_Details").Range("A2:A" & Range("A2").End(xlDown).Row).ClearContents
Application.ScreenUpdating = False
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
Set myDOBPPT = objPPT.Presentations.Open(DestinationPPT) 'PPT with birthday images opens
If Mydate = DateSerial(Year(Date), Month(Cells(i, 4).Value), Day(Cells(i, 4).Value)) Then
'Jump to Random Slide
With myDOBPPT
FirstSlide = 1
LastSlide = myDOBPPT.Slides.Count
Randomize
randomslidenumber = Int(((LastSlide - FirstSlide) * Rnd() + FirstSlide))
End With
With myDOBPPT.Slides(randomslidenumber)
.Shapes("NameOval").TextEffect.Text = WorksheetFunction.Proper(Sheet1.Cells(i, "B").Value) 'Employee's Name
.Shapes("DOB").TextEffect.Text = VBA.Format(Sheet1.Cells(i, "D").Value, "DD Mmm") 'Employee's DOB
.Export (ActiveWorkbook.Path & "\slide") & ".gif", "gif"
End With
Set OutlookApp = New Outlook.Application
Set OutlookMail = OutlookApp.CreateItem(olMailItem)
OutlookMail.To = Cells(i, 5).Value
OutlookMail.CC = Cells(i, 6).Value
OutlookMail.BCC = ""
OutlookMail.Subject = "Happy Birthday " & Cells(i, 2).Value & "!!"
OutlookMail.Attachments.Add (ActiveWorkbook.Path & "\slide.gif")
OutlookMail.HTMLBody = "Good Morning All" & "<br> <br>" & _
"Please join TIGA in wishing " & Cells(i, 2).Value & " " & Cells(i, 3).Value & " a Happy Birthday! Hope you have a fantastic day" & "<br> <br>" & _
"<center><img src='cid:slide.gif' height='576' width='768'/></center>" & "<br> <br>" & _
"Best Wishes and Regards," & "<br>" & "HR Team" & "<br> <br>" & _
"<img src='C:\Users\charles.hill\Pictures\Saved Pictures\TIGA Logo.jpg'/>"
OutlookMail.Display
OutlookMail.Send
'Updates Email Sent column to Yes
With Worksheets("Emp_Details").Cells(i, 7)
.Value = "Yes"
End With
End If
Next i
myDOBPPT.Close
Set myDOBPPT = Nothing
objPPT.Quit
Set objPPT = Nothing
Set OutlookMail = Nothing
Set OutlookApp = Nothing
On Error Resume Next
VBA.Kill (ActiveWorkbook.Path & "\slide.gif")
ActiveWorkbook.Save
MsgBox "Processing Done", vbInformation
MsgBox "Records Updated and Workbook saved", vbInformation
'Declaring variables for updating Email sent column and send birthday wishes log.
Dim RowNum As Integer
RowNum = 2
Dim CurrentDate As Date
CurrentDate = Date
Dim Last_Row
Dim xInspect As Object
Dim PageEditor As Object
Const wdFormatPlainText = 0
'Worksheets("Sheet1").Range("G2:G500").ClearContents
'For RowNum = 2 To Cells(Rows.Count, 1).End(xlUp).Row
' If Worksheets("Sheet1").Cells(RowNum, 4).Value = CurrentDate Then
' Worksheets("Sheet1").Cells(RowNum, 7).Value = "Yes"
'End If
'Next RowNum
'ActiveWorkbook.Save
'MsgBox "Records Updated and Workbook saved", vbInformation
Set SenderOutlookApp = New Outlook.Application
Set SenderOutlookMail = SenderOutlookApp.CreateItem(olMailItem)
Set xInspect = SenderOutlookMail.GetInspector
Set PageEditor = xInspect.WordEditor
Last_Row = Worksheets("Emp_Details").Range("A" & Rows.Count).End(xlUp).Row
Worksheets("Log").Range("A2:I500").ClearContents
For RowNum = 2 To Last_Row
If Worksheets("Emp_Details").Cells(RowNum, "G").Value = "Yes" Then
Worksheets("Emp_Details").Rows(RowNum).Copy Destination:=Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
Next RowNum
Worksheets("Log").UsedRange.Copy
With SenderOutlookMail
.To = "sreenandini.jayaram#tiga.us"
.CC = ""
.BCC = ""
.Subject = "Birthday Wishes Log" & " " & Date
.Body = "Birthday wishes were sent out to the following Employees" & vbCrLf
.Display
PageEditor.Application.Selection.Start = Len(.Body)
PageEditor.Application.Selection.End = PageEditor.Application.Selection.Start
PageEditor.Application.Selection.PasteAndFormat Type:=wdFormatPlainText
.Display
.Send
Set PageEditor = Nothing
Set xInspect = Nothing
End With
Set SenderOutlookMail = Nothing
Set SenderOutlookApp = Nothing
Application.ScreenUpdating = True
End Sub 'Ending Button Click Sub-routine
You are getting that error because you are initializing the object inside the loop and trying to close it outside the loop. If the code doesn't enter the loop then myDOBPPT will be Nothing
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
'
'
'
Set myDOBPPT = objPPT.Presentations.Open(DestinationPPT)
'
'
'
Next i
myDOBPPT.Close
You can also test it by changing myDOBPPT.Close to the below.
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
'
'
'
Set myDOBPPT = objPPT.Presentations.Open(DestinationPPT)
'
'
'
Next i
If myDOBPPT Is Nothing Then
MsgBox "myDOBPPT is nothing"
End If
Move it inside the loop
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
'
'
'
Set myDOBPPT = objPPT.Presentations.Open(DestinationPPT)
'
'
'
myDOBPPT.Close
Next i
I know there's additional stuff in the Declarations, it's for other macros I've written.
I've several calendars. I've a spreadsheet where I paste information about a site, and I've buttons that generate appointments and emails.
I've code to set an appointment, however it goes to my main calendar. I'm trying to get the appointment onto my other calendars. I've read about MAPI functions, but can't get it to work. The location is \myemail#me.com\Calendar. Name of the calendar is SVN Calendar.
Dim olApp As Outlook.Application9
Dim olEmail As Outlook.MailItem
Dim olCal As Outlook.AppointmentItem
Dim olFolder As Outlook.Folder
Dim RequiredAttendee, OptionalAttendee, ResourceAttendee As Outlook.Recipient
Dim rtf() As Byte
Dim rngTo As Range
Dim rngCC As Range
Dim rngSUB As Range
Dim rngCALloc As Range
Dim rngCALstart As Range
Dim rngCALend As Range
Dim rngBody As Range
Dim myItem As Object
Sub newTestCreateCalendarUSA1()
'Testing calendar to other calendar than main.
' i.e. SVN Calendar. can't identify the actual calendar.
Set olApp = New Outlook.Application
Set m = olApp.CreateItem(olMailItem)
Set appt = olApp.CreateItem(olAppointmentItem)
With ActiveSheet
Set rngCC = .Range("I34")
Set rngCALloc = .Range("I5")
Set rngCALstart = .Range("I11")
Set rngCALend = .Range("I12")
Set rngSUB = .Range("I33")
Set rngSite = .Range("C2")
Set rngLoc = .Range("C4")
Set rngTYPE = .Range("B23")
Set rngGON = .Range("C23")
Set rngPurpose = .Range("C21")
Set rngGoals = .Range("C22")
Set rngDate = .Range("I1")
Set rngDateStart = .Range("I8")
Set rngDateEnd = .Range("I9")
Set rngTime = .Range("I10")
Set rngCAS = .Range("C26")
End With
MsgBox "Ensure all attendees are correct prior to sending invite."
appt.MeetingStatus = olMeeting
appt.RequiredAttendees = rngCC.Value
appt.Subject = rngSUB.Value
appt.Location = rngCALloc.Value
appt.Start = rngCALstart.Value
appt.End = rngCALend.Value
appt.AllDayEvent = True
m.BodyFormat = olFormatHTML
m.HTMLBody = Range("I31").Value
m.GetInspector().WordEditor.Range.FormattedText.Copy
appt.GetInspector().WordEditor.Range.FormattedText.Paste
appt.Display
m.Close False
End Sub
Edit: Thanks for directing me to follow the folder tree. I tried understanding the GetNameSpace thing, but couldn't get it to work.
I did find a different code and got it to make an appointment on the correct calendar.
Sub SVN_Calendar_Invite()
'trial run of SVN Calendar with other code
Dim oApp As Object
Dim oNameSpace As Namespace
Dim oFolder As Object
Set oApp = New Outlook.Application
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetFolderFromID("0000000098F32312526B334EAEC97D94705E33FB0100C964D8D325E3554DA24A72FB876E3F600001912394000000")
With ActiveSheet
Set rngCC = .Range("I34")
Set rngCALloc = .Range("I5")
Set rngCALstart = .Range("I11")
Set rngCALend = .Range("I12")
Set rngSUB = .Range("I33")
Set rngSite = .Range("C2")
Set rngLoc = .Range("C4")
Set rngTYPE = .Range("B23")
Set rngGON = .Range("C23")
Set rngPurpose = .Range("C21")
Set rngGoals = .Range("C22")
Set rngDate = .Range("I1")
Set rngDateStart = .Range("I8")
Set rngDateEnd = .Range("I9")
Set rngTime = .Range("I10")
Set rngCAS = .Range("C26")
End With
With oFolder
Set olApt = oApp.CreateItem(olAppointmentItem)
With olApt
.AllDayEvent = True
.RequiredAttendees = rngCC.Value
.Start = rngDateStart.Value
.End = rngDateEnd.Value
.Subject = rngSUB.Value
.Location = rngLoc.Value
.Body = "The body of your appointment note"
.BusyStatus = olFree
.Save
.Move oFolder
End With
Set olNS = Nothing
Set olApp = Nothing
Set olApt = Nothing
End With
End Sub
I've these problems now.
1- if I use .Display to bring up the calendar item to review it, it doesn't display.
2- even though it's an all day event, and the cells are 3 days apart, it subtracts the end date by 1 day.
3- I have to manually invite the attendees, which defeats the purpose of doing this invite.
ok so im about two years late. found this thread while i was facing the same problem. manage to solve with some trial and error so, this works for me.
so you might give it a try for future pple who are googling for the same ans...
a lil more info is i did not set reference to Outlook under tools cos i have many user files.
'start
'break down here retype cos stackoverflow format xxx
Sub Add_Appt_to_Main_Sub_Calendar()
Dim BOOK2 As Workbook
Workbooks.Open Filename:= _
"Name of your file.csv"
'csv is readable by outlook but not excel, u need to change the file type first
'start pulling data from your csv file here
'if you are not setting reference to outlook under tools, please define all your outlook names as Object
Dim olAppts As Object
Dim Calfolder As Object
'this to define the main calendar folder
Dim Subfolder As Object
'this to define the sub calendar folder
Set olApp = CreateObject("Outlook.Application")
Set olNamespace = olApp.GetNamespace("MAPI")
Dim filter As Variant
'cos we dont want to keep import duplicate appt into outlook calendar so we need to create and define a filter
Dim olfolder As Object
'the folder picker by user
Dim strolFolder As String
' we want to get the name of the folder picker by user
Set olfolder = olApp.GetNamespace("MAPI").Pickfolder
'olfolder.Display
'how to find the name of the folder selected
On Error Resume Next
If olfolder = "" Then
MsgBox "No calendar selected."
Workbooks("Name of your file.csv").Close savechanges:=True
'close the csv file if no calendar selected by user
Exit Sub
Else
strolFolder = olfolder
'name of the file pick by user
Set Calfolder = olNamespace.GetDefaultFolder(9)
'defaultfolder(9) is the main calendar by default tagged to user outlook acc
strCalfolder = Calfolder
'name of the sub folder
MsgBox strolFolder
MsgBox strCalfolder
MsgBox (olfolder.folderpath)
MsgBox (Calfolder.folderpath)
'keep for debugging
If olfolder.folderpath <> Calfolder.folderpath Then
'this is the line that add appointment into sub calendar
Set olAppts = olNamespace.GetDefaultFolder(9).Folders(strolFolder)
'eg. Set olAppts = olNamespace.GetDefaultFolder(9).Folders("name of subfolder")
'this is the main folder
Set Calfolder = olNamespace.GetDefaultFolder(9)
'MsgBox Calfolder
'this is the sub folder i want to add in
Set Subfolder = Calfolder.Folders(strolFolder)
'MsgBox Subfolder
'add appt to subfolder
Set olAppt = Subfolder.items.Add
'MsgBox (olfolder.EntryID)
'MsgBox (olfolder)
'MsgBox (olfolder.FolderPath)
'keep for debugging
r = 2
Do Until Trim(Cells(r, 1).Value) = ""
'filter by subject, start date and location
'filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
'filter = "[Subject] = '" & Replace(Cells(r, 2).Value, "'", "''") & "' and [Start] = '" & Format(Cells(r, 7).Value, "dddd Hn:Hn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
'On Error Resume Next 'enable error-handling machine
filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
'Set olAppt = olAppts.items.Find(filter)
'currently this does a check in your main calendar
'if existing appointment based on subject, start date and location is not found, add appointment
' i need to do a search in the subcalendar instead of main calendar
Set olAppt = olAppts.items.Find(filter)
If TypeName(olAppt) = "Nothing" Then
Set myAppt = Subfolder.items.Add
'Set myAppt = olApp.CreateItem(1)
'if using main use create, if use subfolder add
myAppt.Subject = Cells(r, 2).Value
myAppt.Location = Cells(r, 8).Value
myAppt.Start = Cells(r, 7).Value
myAppt.Categories = Cells(r, 3).Value
myAppt.Duration = 120
myAppt.BusyStatus = 2
myAppt.ReminderSet = True
myAppt.Body = Cells(r, 11).Value
myAppt.Save
End If
r = r + 1
Loop
MsgBox "TCU added to sub calendar."
'if picked folder is sub calendar
Else
Set olApp = CreateObject("Outlook.Application")
strCalfolder = olNamespace.GetDefaultFolder(9)
Set olNamespace = olApp.GetNamespace("MAPI")
Set olAppts = olNamespace.GetDefaultFolder(9)
r = 2
Do Until Trim(Cells(r, 1).Value) = ""
'filter by subject, start date and location
'filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
'filter = "[Subject] = '" & Replace(Cells(r, 2).Value, "'", "''") & "' and [Start] = '" & Format(Cells(r, 7).Value, "dddd Hn:Hn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
On Error Resume Next 'enable error-handling machine
filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
Set olAppt = olAppts.items.Find(filter)
'if existing appointment not found, add appointment
If TypeName(olAppt) = "Nothing" Then
Set myAppt = olApp.CreateItem(1)
myAppt.Subject = Cells(r, 2).Value
myAppt.Location = Cells(r, 8).Value
myAppt.Start = Cells(r, 7).Value
myAppt.Categories = Cells(r, 3).Value
myAppt.Duration = 120
myAppt.BusyStatus = 2
myAppt.ReminderSet = True
myAppt.Body = Cells(r, 11).Value
myAppt.Save
End If
r = r + 1
Loop
MsgBox "TCU added to main calendar."
End If
End If
'end add appt
'close ur csv file
Workbooks("Name of your file.csv").Close savechanges:=True
End Sub