MioZo
18-08-2011, 15:53
Нашел элегантное решение отправки сообщения в контексте профиля Outlook. По определенным причинам применение сторонних утилит и работа напрямую с почтовым сервером недопустима.
1. В Outlook 2007/2010 создаем макрос с текстом (авторство не моё):
Function GetAttach()
Dim strPath
Dim arrFiles
strPath = "C:\test"
Set arrFiles = CreateObject("Shell.Application").NameSpace(strPath).Items
arrFiles.Filter 64, "*.txt"
Select Case arrFiles.Count
Case 0
MsgBox "Отчет для отправки не найден.", 48, "Отправка файла"
WScript.Quit 1
Case 1
GetAttach = arrFiles.Item(0).Path
Case Else
MsgBox "Найдено несколько файлов.", 48, "Отправка файла"
WScript.Quit 1
End Select
End Function
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Sub Mail_Outlook_With_Signature_Html()
' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2010
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim SigString As String
Dim Signature As String
Set OutApp = CreateObject("Outlook.Application")
If TypeName(Application.ActiveWindow) = "Inspector" Then
Application.ActiveWindow.WindowState = 1
End If
Set OutMail = OutApp.CreateItem(0)
strbody = "<H3><B>Dear Customer</B></H3>" & _
"Please visit this website to download the new version.<br>" & _
"Let me know if you have problems.<br>" & _
"<A HREF=""http://www.rondebruin.nl/tips.htm"">Ron's Excel Page</A>" & _
"<br><br><B>Thank you</B>"
'Use the second SigString if you use Vista or win 7 as operating system
SigString = "C:\Documents and Settings\" & Environ("username") & _
"\Application Data\Microsoft\Signatures\Valeev.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
'Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.To = "ron@debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = strbody & "<br><br>" & Signature
'You can add files also like this
.Attachments.Add GetAttach
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
2. Сохраняем макрос.
3. Создаем командный файл с текстом "C:\Program Files\Microsoft Office\Office14\OUTLOOK.EXE" /autorun Mail_Outlook_With_Signature_Html
4. Создаем задачу с расписанием.
5. В результате никогда не забудем отправить суточный отчет ).
---
Хорошие ссылки:
http://msdn.microsoft.com/ru-ru/library/microsoft.office.interop.outlook.mailitem_members.aspx
http://office.microsoft.com/ru-ru/outlook-help/HP001003110.aspx
1. В Outlook 2007/2010 создаем макрос с текстом (авторство не моё):
Function GetAttach()
Dim strPath
Dim arrFiles
strPath = "C:\test"
Set arrFiles = CreateObject("Shell.Application").NameSpace(strPath).Items
arrFiles.Filter 64, "*.txt"
Select Case arrFiles.Count
Case 0
MsgBox "Отчет для отправки не найден.", 48, "Отправка файла"
WScript.Quit 1
Case 1
GetAttach = arrFiles.Item(0).Path
Case Else
MsgBox "Найдено несколько файлов.", 48, "Отправка файла"
WScript.Quit 1
End Select
End Function
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Sub Mail_Outlook_With_Signature_Html()
' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2010
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim SigString As String
Dim Signature As String
Set OutApp = CreateObject("Outlook.Application")
If TypeName(Application.ActiveWindow) = "Inspector" Then
Application.ActiveWindow.WindowState = 1
End If
Set OutMail = OutApp.CreateItem(0)
strbody = "<H3><B>Dear Customer</B></H3>" & _
"Please visit this website to download the new version.<br>" & _
"Let me know if you have problems.<br>" & _
"<A HREF=""http://www.rondebruin.nl/tips.htm"">Ron's Excel Page</A>" & _
"<br><br><B>Thank you</B>"
'Use the second SigString if you use Vista or win 7 as operating system
SigString = "C:\Documents and Settings\" & Environ("username") & _
"\Application Data\Microsoft\Signatures\Valeev.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
'Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.To = "ron@debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = strbody & "<br><br>" & Signature
'You can add files also like this
.Attachments.Add GetAttach
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
2. Сохраняем макрос.
3. Создаем командный файл с текстом "C:\Program Files\Microsoft Office\Office14\OUTLOOK.EXE" /autorun Mail_Outlook_With_Signature_Html
4. Создаем задачу с расписанием.
5. В результате никогда не забудем отправить суточный отчет ).
---
Хорошие ссылки:
http://msdn.microsoft.com/ru-ru/library/microsoft.office.interop.outlook.mailitem_members.aspx
http://office.microsoft.com/ru-ru/outlook-help/HP001003110.aspx