Страницы: 1
RSS
Отправка снимка диапазона Excel через Outlook, макрос
 
Добрый день!
Подскажите, пожалуйста!
Каким макросом можно вставить скриншот диапазона ячеек A1:A20 в тело нового письма Outlook?
Спасибо!
 
А почему именно скриншот а не таблицу?
"Все гениальное просто, а все простое гениально!!!"
 
Цитата
Nordheim написал:
А почему именно скриншот а не таблицу?
Условное форматирование в виде значков теряется.
 
1. Как сохранить картинки из листа Excel в картинки JPG - там есть код сохранения выделенного диапазона в картинку
2. Как отправить письмо из Excel? - там есть отдельным кодом вставка картинки в тело письма

Останется чуть совместить
Изменено: Дмитрий(The_Prist) Щербаков - 14.11.2019 10:22:11
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
И такой вариант.
Код
Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Public Const VK_SNAPSHOT = &H2C
Sub PrintScreen()
    keybd_event VK_SNAPSHOT, 1, 0, 0    SendEmailUsingOutlook "Display", "", ""
    SendKeys "{TAB}", True
    SendKeys "{TAB}", True
    SendKeys "{TAB}", True
    SendKeys "^v", True
End Sub
Function SendEmailUsingOutlook(ByRef SendMode As Variant, _
                                ByVal MailText$, _
                                ByVal Email$, _
                                Optional ByVal CopyTo$, _
                                Optional oOutlook As Object, _
                                Optional ByVal Subject$ = "", _
                                Optional ByVal AttachFilename As Variant, _
                                Optional ByVal from As String, _
                                Optional ByVal flagDeleteAfterSubmit As Boolean = False) _
                                    As Boolean
    ' функция производит отправку письма с заданной темой и текстом на адрес Email
    ' с почтового ящика, настроенного в Outlook для отправки писем "по-умолчанию"
    ' Если задан параметр AttachFilename, к отправляемому письму прикрепляется файл (файлы)    Application.StatusBar = "Send mail " & Email$ & " " & Subject$    On Error Resume Next: Err.Clear
    If oOutlook Is Nothing Then Set oOutlook = GetObject(, "Outlook.Application")
    If oOutlook Is Nothing Then
        Set oOutlook = CreateObject("Outlook.Application")
''        oOutlook.Session.Logon
'        Dim olNs As Outlook.Namespace:        Set olNs = oOutlook.GetNamespace("MAPI")
'        ' Create an instance of the Inbox folder.
'        ' If Outlook is not already running, this has the side
'        ' effect of initializing MAPI.
'        Dim mailFolder As Outlook.Folder:        Set mailFolder = olNs.GetDefaultFolder(olFolderInbox)
    End If
    If oOutlook Is Nothing Then CreateObject("WScript.Shell").Popup "Не удалось запустить OUTLOOK для отправки почты", 2, "SendEmailUsingOutlook", vbCritical: Exit Function
    Err.Clear
    
'    Do
        'создаем новое сообщение
        Dim oMail As Object 'Outlook.MailItem
        Set oMail = oOutlook.CreateItem(0)
        With oMail
            .To = Email$: .Subject = Subject$: .Body = MailText$
            If from <> "" Then _
            .SentOnBehalfOfName = from
            .CC = CopyTo$
            If InStr(MailText$, "</") = 0 Then
                .Body = MailText$
            Else
                .HTMLBody = MailText$
            End If
            If VarType(AttachFilename) = vbString Then .Attachments.Add AttachFilename
            If VarType(AttachFilename) = vbObject Then    ' AttachFilename as Collection
                Dim file As Variant
                For Each file In AttachFilename.Keys: .Attachments.Add file: Next
            End If
'            Dim i As Long: For i = 100000 To 100000: DoEvents: Next    ' без паузы не отправляются письма без вложений
            Err.Clear
            
            'Удалить после отправки
            If flagDeleteAfterSubmit Then .DeleteAfterSubmit = True
            
'            .Display
            Select Case SendMode
            Case "Display":     .Display
            Case True:          .Send
            Case Else:          .Save
            End Select
            SendEmailUsingOutlook = Err = 0
        
        End With    Application.StatusBar = False
End Function
Изменено: МатросНаЗебре - 14.11.2019 10:28:45
 
Как в этом коде указать постоянный диапазон, а не тот что сейчас выделен?
Код
Sub Range_to_Picture()
    Dim sName As String, wsTmpSh As Worksheet
    If TypeName(Selection) <> "Range" Then
        MsgBox "Âûäåëåííàÿ îáëàñòü íå ÿâëÿåòñÿ äèàïàçîíîì!", vbCritical, ""
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Selection
        .CopyPicture
        Set wsTmpSh = ThisWorkbook.Sheets.Add
        sName = "SB"
        With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart
            .ChartArea.Border.LineStyle = 0
            .Parent.Select
            .Paste
            .Export Filename:=sName & ".jpg", FilterName:="jpg"
            .Parent.Delete
        End With
    End With
    wsTmpSh.Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
 
Код
Sub Range_to_Picture()
    Dim sName As String, wsTmpSh As Worksheet
    If TypeName(Selection) <> "Range" Then
        MsgBox "Auaaeaiiay iaeanou ia yaeyaony aeaiaciiii!", vbCritical, ""
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Sheets("Лист1").Range("A1:C10")
        .CopyPicture
        Set wsTmpSh = ThisWorkbook.Sheets.Add
        sName = "SB"
        With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart
            .ChartArea.Border.LineStyle = 0
            .Parent.Select
            .Paste
            .Export Filename:=sName & ".jpg", FilterName:="jpg"
            .Parent.Delete
        End With
    End With
    wsTmpSh.Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
 
Спасибо всем!  
Страницы: 1
Наверх