I have two pieces of code that work independently.
I would like to add a button to my sheet to do both. In other words to create the email with the screenshot generated by ScreenShotResults4() and attach the pdf generated by PrintPIP_To_PDF().
I tried combining but got syntax errors. I cobble code together with the help of sites like this.
Public Sub ScreenShotResults4()
Dim rng As Range
Dim olApp As Object
Dim Email As Object
Dim Sht As Excel.Worksheet
Dim wdDoc As Word.Document
Set rng = Sheets("Summary").Range("B21:N37")
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set olApp = CreateObject("Outlook.Application")
Set Email = olApp.CreateItem(0)
Set wdDoc = Email.GetInspector.WordEditor
'strbody = "See production data for most recent 3 months. "
With Email
.To = Worksheets("Summary").Range("B21").Value
.Subject = "12 Month LO Production Lookback for " & Worksheets("Summary").Range("B21").Value & " (" & Worksheets("Summary").Range("B23").Value & "- " & Worksheets("Summary").Range("B35").Value & ")"
'.HTMLBody = "<BODY style=font-size:12.5pt;font-family:Calibri>" & "</p>" & strbody & RangetoHTML(rng) & Signature
.Display
wdDoc.Range.PasteAndFormat Type:=wdChartPicture
'if need setup inlineshapes hight & width
With wdDoc.Content
'--- paste the range image first, because it overwrites
' everything in the document
.PasteAndFormat Type:=wdChartPicture
'--- now add our greeting at the start of the email
.InsertBefore "See 12 month production data. " & vbCr & vbCr
'--- finally add our sign off after the image
.InsertAfter vbCr & _
"Thank you" & vbCr & vbCr
End With
.Display
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set Email = Nothing
Set olApp = Nothing
End Sub
Sub PrintPIP_To_PDF()
Application.EnableEvents = True
ActiveSheet.Unprotect Password:="Mortgage1"
Dim PrintRng As Range
Dim pdfile As String
'Setting range to be printed
Set PrintRng = Worksheets("PIP").Range("B3:M27")
'Range("B25:C25").Font.Color = RGB(255, 255, 255)
sPath = Environ("USERPROFILE") & "\Desktop\"
pdfile = Application.GetSaveAsFilename _
(InitialFileName:=sPath & "PIP" & " " & Worksheets("Summary").Range("B21").Value, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
Filename = pdfile
If Filename = False Then
Exit Sub
Else
PrintRng.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=pdfile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Call MsgBox(pdfile & " file has been saved!")
ActiveSheet.Protect Password:="Mortgage1"
End If
End Sub
pls try this.
after displaying draft email .Display
use .Attachment.Add "C:\Test.pdf"
also if u wish to, u can save a copy of draft email (before sending) using
.SaveAs "C:\OutLookDrafts\Draft1.msg"
Related
I have a sheet "Graphs" that basically contains all the information I need to send via Outlook email.
I managed to shovel together a macro that will extract the graphs, convert them as images and paste it to Outlook body email, along with some other information from the sheet.
My issue is, that sometimes there is less or more graphs being added to this sheet, and I am not sure how to loop that in the html section of the macro, so it will automatically adjust how many picture to declare and paste to the email body.
Section Private Sub export_chart() set up to extract all graphs as .jpg files.
But on the Private Sub Send_Automate_Mail() I have to declare them one by one:
.Attachments.Add file_path & "Chart_1.jpg"
.Attachments.Add file_path & "Chart_2.jpg"
And add them one by one on the html section:
"<img src='cid:Chart_1.jpg'" & "width='1000' height='460'>" & "<br>" & "<p>" & _
"<img src='cid:Chart_2.jpg'" & "width='450' height='265'>" & _
But because the number of charts are changing, I wonder if there is a way to do this part as a loop as long as there are Chart_1.jpg, Chart_2.jpg... files are present.
I am only a beginner of that kind of coding, could someone help me out please?
My current code below. I am happy for any suggestions or a completely new code if there is an easier method out there, I'm kind of lost at this point!
I know there is an easy way to just send the whole sheet as is, but I cannot do that because recipients are having problem viewing (big gaps in-between graphs; email loading slowly). So I have to convert the graphs to pictures.
Thank you in advance!
Option Explicit
Dim folder_path As String
Dim chart_no As Integer
Dim file_path As String
Sub mail_2_IBUhead()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim rng As Range
Dim x As Integer, y As Integer
Dim total_Resource As Integer
Application.ScreenUpdating = False
Sheets("Graphs").Select
Call export_chart
Call Send_Automate_Mail
'Delete the htm file we used in this function
Kill file_path & "Chart_1.jpg"
Kill file_path & "Chart_2.jpg"
Kill file_path & "Chart_3.jpg"
Kill file_path & "Chart_4.jpg"
Kill file_path & "Chart_5.jpg"
Kill file_path & "Chart_6.jpg"
Kill file_path & "Chart_7.jpg"
Kill file_path & "Chart_8.jpg"
Kill file_path & "Chart_9.jpg"
Kill file_path & "Chart_10.jpg"
MsgBox "Draft Mails have been generated", vbDefaultButton1, "Mail Drafted!"
End Sub
Private Sub Send_Automate_Mail()
' This macro would only send the mail
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim strbody_1 As String, strbody_2 As String, strbody_3 As String
' Dim Start_row As Integer, Start_column As Integer, End_row As Integer, End_Column As Integer
' selecting the entire table range in the sheet
Sheets("Graphs").Select
Range("A:P").Select
Set rng = Selection.SpecialCells(xlCellTypeVisible)
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody_1 = "<BODY style=font-size:11pt;font-family:Calibri>Good morning all,<p>" & _
" Please see MTO update for today, <br> </BODY> "
strbody_2 = "<BODY style=font-size:11pt;font-family:Calibri>" & _
" "
strbody_3 = "<BODY style=font-size:11pt;font-family:Calibri> " & _
" </BODY> "
file_path = folder_path & "\"
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "BE. RawData"
.Attachments.Add file_path & "Chart_1.jpg"
.Attachments.Add file_path & "Chart_2.jpg"
.Attachments.Add file_path & "Chart_3.jpg"
.Attachments.Add file_path & "Chart_4.jpg"
.Attachments.Add file_path & "Chart_5.jpg"
.Attachments.Add file_path & "Chart_6.jpg"
.Attachments.Add file_path & "Chart_7.jpg"
.Attachments.Add file_path & "Chart_8.jpg"
.Attachments.Add file_path & "Chart_9.jpg"
.Attachments.Add file_path & "Chart_10.jpg"
.htmlbody = strbody_1 & "<p>" & "<p>" & _
"<img src='cid:Chart_1.jpg'" & "width='1000' height='460'>" & "<br>" & "<p>" & _
"<img src='cid:Chart_2.jpg'" & "width='450' height='265'>" & _
"<img src='cid:Chart_3.jpg'" & "width='450' height='265'>" & _
"<img src='cid:Chart_4.jpg'" & "width='450' height='265'>" & "<br>" & "<p>" & _
"<img src='cid:Chart_5.jpg'" & "width='650' height='300'>" & _
"<img src='cid:Chart_6.jpg'" & "width='650' height='300'>" & "<br>" & "<p>" & _
"<img src='cid:Chart_7.jpg'" & "width='650' height='300'>" & "<br>" & "<p>" & _
"<img src='cid:Chart_8.jpg'" & "width='450' height='265'>" & _
"<img src='cid:Chart_9.jpg'" & "width='450' height='265'>" & "<br>" & "<p>" & _
"<img src='cid:Chart_10.jpg'" & "width='1000' height='460'>" & "<br>" & "<p>" & _
RangetoHTML(rng) & "<br>" & _
strbody_3
.Importance = 2
' display the e-mail message, change it to ".send" to send the mail on running the macro
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' this function is used in code "Send_Automate_Mail"
' do not change the code if you are new to coding :)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
TempWB.Close savechanges:=False
'Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Private Sub export_chart()
' this code will export all the graphs present in the sheet
Dim objCht As ChartObject
Dim myPic As Shape
Dim tempChartObj As ChartObject
Dim x As Integer
folder_path = Application.ActiveWorkbook.Path
' for each graph present in the sheet, it will get exported
Sheets("Graphs").Select
x = 1
For Each objCht In ActiveSheet.ChartObjects
objCht.Chart.Export folder_path & "\Chart_" & x & ".jpg", "JPG"
x = x + 1
Next objCht
End Sub
I create a picture of a range and paste it into Outlook. The code works but I added a checkbox that is located in the range that I do NOT want to paste into Outlook.
I used ActiveSheet.CheckBoxes("Branch_ChkBox").Visible = False. It works sometimes and other times it doesn't. When I step through the code I get the same inconsistent results.
Public Sub ScreenShotResults4_with_Current()
Dim rng As Range
Dim olApp As Object
Dim Email As Object
Dim Sht As Excel.Worksheet
Dim wdDoc As Word.Document
Set rng = Sheets("Summary").Range("B9:N37")
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
'Sheets("Summary").Branch_ChkBox.Visible = False
ActiveSheet.CheckBoxes("Branch_ChkBox").Visible = False
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set olApp = CreateObject("Outlook.Application")
Set Email = olApp.CreateItem(0)
Set wdDoc = Email.GetInspector.WordEditor
'strbody = "See production data for most recent 3 months. "
With Email
.To = Worksheets("Summary").Range("B21").Value
.Subject = "12 Month LO Production Lookback for " & Worksheets("Summary").Range("B21").Value & " (" & Worksheets("Summary").Range("B23").Value & "- " & Worksheets("Summary").Range("B35").Value & ")"
'.HTMLBody = "<BODY style=font-size:12.5pt;font-family:Calibri>" & "</p>" & strbody & RangetoHTML(rng) & Signature
.Display
wdDoc.Range.PasteAndFormat Type:=wdChartPicture
ActiveSheet.CheckBoxes("Branch_ChkBox").Visible = False
'if need setup inlineshapes hight & width
With wdDoc.Content
'--- paste the range image first, because it overwrites
' everything in the document
ActiveSheet.CheckBoxes("Branch_ChkBox").Visible = False
.PasteAndFormat Type:=wdChartPicture
.InlineShapes(1).Height = 350
'--- now add our greeting at the start of the email
.InsertBefore "See 12 month production data and current pipeline. " & vbCr & vbCr
'--- finally add our sign off after the image
.InsertAfter vbCr & _
"Thank you" & vbCr & vbCr
End With
.Display
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set Email = Nothing
Set olApp = Nothing
ActiveSheet.CheckBoxes("Branch_ChkBox").Visible = True
End Sub
I was able to resolve by putting the same part of the code buy at the top right under the declarations
ActiveSheet.CheckBoxes("Branch_ChkBox").Visible = False
I used the code below to copy a range from a file and paste it as a picture on emails, but there's a catch: if you don´t use .display before .send, the picture will not be displayed to the receiver.
Does anyone know a way around this? Just to avoid the outlook window flashing on the screen.
Sub sendMail()
Dim olApp As Object
Dim NewMail As Object
Dim ChartName As String
Dim imgPath As String
Set olApp = CreateObject("Outlook.Application")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
tmpImageName = VBA.Environ$("temp") & "\tempo.jpg"
Workbooks.Open "C:\FilePath\File.xlsm"
Set RangeToSend = Workbooks("File.xlsm").Sheets(Name).Range(" ")
RangeToSend.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set sht = Sheets.Add
sht.Shapes.AddChart
sht.Shapes.Item(1).Select
Set objChart = ActiveChart
With objChart
.ChartArea.Height = RangeToSend.Height
.ChartArea.Width = RangeToSend.Width
.ChartArea.Fill.Visible = msoFalse
.ChartArea.Border.LineStyle = xlLineStyleNone
.Paste
.Export Filename:=tmpImageName, FilterName:="JPG"
End With
sht.Delete
Workbooks("File.xlsm").Close
Set NewMail = olApp.CreateItem(0)
With NewMail
.Subject = "Latest performance report" ' Replace this with your Subject
.To = "email#email.com" ' Replace it with your actual email
.HTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "Hello, this is the data range that you want:<br> " _
& "<br>" _
& "<img src=" & "'" & tmpImageName & "'/>" _
& "<br>" _
& "<img src=" & "'" & tmpImageName2 & "'/>" _
& "<br>" _
& "<br>Best Regards!</font></span>"
.Display
.Send
Set olApp = Nothing
Set NewMail = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End With
End Sub
Looks like you are saving the picture captured in Excel to a disk. And then you are referring to the image in a newly created item body. But the image source still points to the file on your disk. So, the recipient will never get it shown correctly.
Instead, you need to attach a file and then add a reference in the message body.
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
Const PR_ATTACHMENT_HIDDEN = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
...
Set colAttach = mail.Attachments
Set l_Attach = colAttach.Add(path_to_the_file)
Set oPA = l_Attach.PropertyAccessor
oPA.SetProperty PR_ATTACH_CONTENT_ID, "itemID"
oPA.SetProperty PR_ATTACHMENT_HIDDEN, True
Then you can modify the message body in the following way:
.HTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "Hello, this is the data range that you want:<br> " _
& "<br>" _
& "<img src='cid:itemID'/>" _
& "<br>" _
& "<br>Best Regards!</font></span>"
.Send
might be you are able to help me with VBA code.
I got a code that send as PDF part of excel sheet.
Problem is that email is used by many people and sometimes text is confidential. Is there an option to delete email (sent items and deleted items) after email is sent?
Using office 2000
Here is my existing code.
Sub SendDDocs()
Dim IsCreated As Boolean
Dim PdfFile As String, Title As String
Dim OutlApp As Object
Dim rng As Range
Set rng = Range("A1:J103")
Title = Range("o1")
Title = Range("o1").Value & " Confidetial"
PdfFile = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & 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 = "email#email.com"
.CC = "email#email.com"
.Body = "" & vbLf & vbLf _
& "a" & vbLf & vbLf _
& "" & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add PdfFile
Application.Visible = True
.Display
End With
Kill PdfFile
If IsCreated Then OutlApp.Quit
Set OutlApp = Nothing
End Sub
Instead of .Display use
.DeleteAfterSubmit = True
.Send
to not save a copy in sent items.
See MailItem.DeleteAfterSubmit Property (Outlook).
I am currently using the following VBA code in Excel for MAC 2016:
Sub MailWorkSheet()
Dim SourceWb As Workbook, DestWb As Workbook, sh As Worksheet
Dim strbody As String, TempFileName As String
If Val(Application.Version) < 15 Then Exit Sub
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
'Check if the Script File is in the correct location
If CheckScript(ScriptFileName:="ExcelOutlook.scpt") = False Then
MsgBox "Sorry the ExcelOutlook.scpt file is not in the correct
location, " & _
"Email File Manually."
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Set reference to the source workbook
Set SourceWb = ActiveWorkbook
'Create the body text in the strbody string
strbody = "<FONT size=""3"" face=""Calibri"">"
strbody = strbody & "Hello:" & "<br>" & "<br>" & _
"XXXXXXX." & "<br>" & _
" " & "<br>" & _
"XXXXXXX." & "<br>" & _
" " & "<br>" & _
"XXXXXXX!!"
strbody = strbody & "</FONT>"
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
Set DestWb = ActiveWorkbook
'Delete the button on the one sheet workbook
On Error Resume Next
DestWb.Sheets(1).DrawingObjects.Visible = True
DestWb.Sheets(1).DrawingObjects.Delete
On Error GoTo 0
'Enter the name of the file just created
TempFileName = "Long Lane Merit Sheet" & " " _
& Range("A2") & " " & Format(Now, "mmm-dd-yy")
'Call the MailWithMac function to save the new file and create the
mail
MailWithMac _
subject:="XXXXXXX", _
mailbody:=strbody, _
toaddress:=Range("A3"), _
ccaddress:="", _
bccaddress:="", _
displaymail:=True, _
accounttype:="", _
accountname:="", _
attachment:=TempFileName, _
FileFormat:=SourceWb.FileFormat
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'Turn on Automatic Calculation
Application.Calculation = xlCalculationAutomatic
'Turn Alert Messages On
Application.DisplayAlerts = True
End Sub
It works great to email the current sheet through Outlook.
The problem I am having is that I want the focus to return to the Excel sheet. What is happening now is that the Outlook screen along with a new email pops up. After hitting send, the new email screen goes away, but the main Outlook window remains.
How do I set focus back to Excel?
I have found that the solution is to use Applescript to achieve the desired effect. Here is the whole script:
ption Explicit
Sub MailWorkSheet()
'Only working in Excel 2016 for the Mac with Outlook 2016
Dim SourceWb As Workbook, DestWb As Workbook, sh As Worksheet
Dim strbody As String, TempFileName As String
Dim RunMyScript As String
'Exit the sub if it is Mac Excel 2011 or lower
If Val(Application.Version) < 15 Then Exit Sub
'Turn off Automatic Calculation
Application.Calculation = xlCalculationManual
'Turn off Alerts
Application.DisplayAlerts = False
'Check if the Script File is in the correct location
If CheckScript(ScriptFileName:="ExcelOutlook.scpt") = False Then
MsgBox "Sorry the ExcelOutlook.scpt file is not in the correct location, " & _
"Email File Manually."
Exit Sub
End If
With Application
'.ScreenUpdating = False
.EnableEvents = False
End With
'Set reference to the source workbook
Set SourceWb = ActiveWorkbook
'Create the body text in the strbody string
strbody = "<FONT size=""3"" face=""Calibri"">"
strbody = strbody & "Hello:" & "<br>" & "<br>" & _
"XXXXXXX" & "<br>" & _
" " & "<br>" & _
"XXXXXXX" & "<br>" & _
" " & "<br>" & _
"XXXXXXX"
strbody = strbody & "</FONT>"
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
Set DestWb = ActiveWorkbook
'Delete the button on the one sheet workbook
On Error Resume Next
DestWb.Sheets(1).DrawingObjects.Visible = True
DestWb.Sheets(1).DrawingObjects.Delete
On Error GoTo 0
'Enter the name of the file just created
TempFileName = "XXXXXXX" & " " _
& Range("A2") & " " & Format(Now, "mmm-dd-yy")
'Call the MailWithMac function to save the new file and create the mail
MailWithMac _
subject:="XXXXXXX", _
mailbody:=strbody, _
toaddress:=Range("A3"), _
ccaddress:="", _
bccaddress:="", _
displaymail:=True, _
accounttype:="", _
accountname:="", _
attachment:=TempFileName, _
FileFormat:=SourceWb.FileFormat
With Application
'.ScreenUpdating = True
.EnableEvents = True
End With
'Minimize Outlook
RunMyScript = AppleScriptTask("ExcelOutlook.scpt", "Mini", _
"/Library/Application Scripts/com.microsoft.Excel/ExcelOutlook.scpt")
'Turn on Automatic Calculation
Application.Calculation = xlCalculationAutomatic
'Turn Alert Messages On
Application.DisplayAlerts = True
End Sub
Function MailWithMac(subject As String, mailbody As String, _
toaddress As String, ccaddress As String, _
bccaddress As String, displaymail As Boolean, _
accounttype As String, accountname As String, _
attachment As String, FileFormat As Long)
'Function to create a mail with the activesheet
Dim FileExtStr As String, FileFormatNum As Long
Dim TempFilePath As String, fileattachment As String
Dim ScriptStr As String, RunMyScript As String
Select Case FileFormat
Case 52: FileExtStr = ".xlsx": FileFormatNum = 52
Case 53:
If ActiveWorkbook.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 53
Else
FileExtStr = ".xlsx": FileFormatNum = 52
End If
Case 57: FileExtStr = ".xls": FileFormatNum = 57
Case Else: FileExtStr = ".xlsb": FileFormatNum = 51
End Select
'Save the new temporary workbook and close it
TempFilePath = _
MacScript("return POSIX path of (path to home folder) as string")
With ActiveWorkbook
.SaveAs TempFilePath & attachment & FileExtStr, FileFormat:=FileFormatNum
.Close SaveChanges:=False
End With
'Build the AppleScriptTask parameter string
fileattachment = TempFilePath & attachment & FileExtStr
ScriptStr = subject & ";" & mailbody & ";" & toaddress & ";" & ccaddress & ";" & _
bccaddress & ";" & displaymail & ";" & accounttype & ";" & _
accountname & ";" & fileattachment
'Call the ExcelOutlook Script with the AppleScriptTask Function
RunMyScript = AppleScriptTask("ExcelOutlook.scpt", "CreateMailinOutlook", CStr(ScriptStr))
'Delete the file we just mailed
KillFile fileattachment
End Function
Function CheckScript(ScriptFileName As String) As Boolean
'Function to Check if the AppleScriptTask script file exists
Dim AppleScriptTaskFolder As String
Dim TestStr As String
AppleScriptTaskFolder = MacScript("return POSIX path of (path to desktop folder) as string")
AppleScriptTaskFolder = Replace(AppleScriptTaskFolder, "/Desktop", "") & _
"Library/Application Scripts/com.microsoft.Excel/"
On Error Resume Next
TestStr = Dir(AppleScriptTaskFolder & ScriptFileName, vbDirectory)
On Error GoTo 0
If TestStr = vbNullString Then
CheckScript = False
Else
CheckScript = True
End If
End Function
Function KillFile(Filestr As String)
'Function to Kill File
Dim ScriptToKillFile As String
Dim Fstr As String
'Delete files from a Mac using Applescript to avoid probelsm with long file names
If Val(Application.Version) < 15 Then
ScriptToKillFile = "tell applicatoin " & Chr(34) & _
"Finder" & Chr(34) & Chr(13)
ScriptToKillFile = ScriptToKillFile & _
"do shell script ""rm"" & quoted form of posix path of " & _
Chr(34) & Filestr & Chr(34) & Chr(13)
ScriptToKillFile = ScriptToKillFile & "end tell"
On Error Resume Next
MacScript (ScriptToKillFile)
On Error GoTo 0
Else
Fstr = MacScript("return POSIX path of (" & _
Chr(34) & Filestr & Chr(34) & ")")
On Error Resume Next
Kill Fstr
End If
End Function
Applescript:
on CreateMailInOutlook(paramString)
set {fieldValue1, fieldValue2, fieldValue3, fieldValue4, fieldValue5, fieldValue6, fieldValue7, fieldValue8, fieldValue9} to SplitString(paramString, ";")
tell application "Microsoft Outlook"
if fieldValue7 = "pop" then
set theAccount to the first pop account whose name is fieldValue8
set NewMail to (make new outgoing message with properties {subject:fieldValue1, content:fieldValue2, account:theAccount})
else if fieldValue7 = "imap" then
set theAccount to the first imap account whose name is fieldValue8
set NewMail to (make new outgoing message with properties {subject:fieldValue1, content:fieldValue2, account:theAccount})
else
set NewMail to (make new outgoing message with properties {subject:fieldValue1, content:fieldValue2})
end if
tell NewMail
repeat with toRecipient in my SplitString(fieldValue3, ",")
make new to recipient at end of to recipients with properties {email address:{address:contents of toRecipient}}
end repeat
repeat with toRecipient in my SplitString(fieldValue4, ",")
make new to recipient at end of cc recipients with properties {email address:{address:contents of toRecipient}}
end repeat
repeat with toRecipient in my SplitString(fieldValue5, ",")
make new to recipient at end of bcc recipients with properties {email address:{address:contents of toRecipient}}
end repeat
make new attachment with properties {file:POSIX file fieldValue9 as alias}
if fieldValue6 as boolean = true then
open NewMail
activate NewMail
else
send NewMail
end if
end tell
end tell
end CreateMailInOutlook
on SplitString(TheBigString, fieldSeparator)
tell AppleScript
set oldTID to text item delimiters
set text item delimiters to fieldSeparator
set theItems to text items of TheBigString
set text item delimiters to oldTID
end tell
return theItems
end SplitString
on Mini()
tell application "Microsoft Outlook"
tell (windows whose id is not (get id of front window) and visible is true)
set miniaturized to true
end tell
end tell
end Mini