Отправка писем из Excel-я через Outlook - VBA
Формулировка задачи:
Всем доброго времени суток. Очень большая просьба помочь доделать. Есть макрос для отправки писем из икселя через оутлук с вложением текущего файла. Возможно ли внести исправление, чтобы не вкладывался файл, а из него в тело письма вставлялись только выделенные ячейки?
Всем заранее спасибо!
Листинг программы
- Sub Send_Mail()
- Dim objOutlookApp As Object, objMail As Object
- Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
- Dim sCc As String
- Application.ScreenUpdating = False
- On Error Resume Next
- Set objOutlookApp = CreateObject("Outlook.Application")
- objOutlookApp.Session.Logon
- Set objMail = objOutlookApp.CreateItem(0)
- If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
- sTo = "***@***.ru"
- sCc = "***@***.ru "
- sSubject = "отчет"
- sBody = "Добрый день," & "<BR>" & "Отчётные данные:"
- (вставка из таблицы)
- With objMail
- .To = sTo
- .Cc = sCc
- .Subject = sSubject
- .HTMLBody = sBody
- .Display End With
- exit_:
- Set objOutlookApp = Nothing: Set objMail = Nothing
- Application.ScreenUpdating = True
- End Sub
Решение задачи: «Отправка писем из Excel-я через Outlook»
textual
Листинг программы
- #If VBA7 Then
- #If Win64 Then
- Private Declare PtrSafe Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As LongPtr) As LongPtr
- #Else
- Private Declare Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As LongPtr) As LongPtr
- #End If
- #Else
- #If Win64 Then
- Private Declare PtrSafe Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As LongLong) As LongLong
- #Else
- Private Declare Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long
- #End If
- #End If
- Sub aaaa11111Send_Mail()
- Dim objOutlookApp As Object, objMail As Object
- Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
- Dim sCc As String
- Application.ScreenUpdating = False
- Dim wbkX As Workbook
- Dim shtX As Worksheet
- Dim rngBody As Range
- Dim rngCell As Range
- On Error Resume Next
- LoadKeyboardLayout "0000419", &H1
- Set wbkX = ActiveWorkbook
- Set shtX = wbkX.Sheets(1)
- wbkX.Activate
- Set rngBody = Selection
- Selection.Copy
- Set objOutlookApp = CreateObject("Outlook.Application")
- objOutlookApp.Session.Logon
- Set objMail = objOutlookApp.CreateItem(0)
- If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
- sTo = "***@***.ru"
- sCc = "***@***.ru"
- sSubject = "отчет"
- sBody = "Добрый день," & "<BR>" & "Отчётные данные:"
- With objMail
- .To = sTo
- .CC = sCc
- .Subject = sSubject
- .HTMLBody = sBody
- .Display
- SendKeys ("^{END}")
- SendKeys ("{ENTER}{ENTER}")
- 'SendKeys ("~ ~")
- SendKeys "^v", True
- End With
- exit_:
- Set objOutlookApp = Nothing: Set objMail = Nothing
- Application.ScreenUpdating = True
- End Sub
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д