Как отправить диаграмму Excel из макроса перспективы

Я дошел до того, что запускаю макрос Outlook с правилами и предупреждениями.

Макрос ищет почтовый ящик для почты с почтового адреса, когда он его находит, он перемещает его в подпапку, затем извлекает только номер из тела письма, открывает Excel, вставляет номер и дату отправки в Excel на следующая свободная строка, обновляет Excel, сохраняет ее и закрывает.

в последний раз он перемещает почту в каталог DONE и маркирует ее как прочитанную.

В Excel есть сводная таблица, которая создает график (диаграмма 3).

Теперь я хочу отправить этот граф от получателей excel to mail, я нашел много способов отправить по электронной почте граф из Excel, но не из макроса перспективы.

вот что у меня есть до сих пор:

Sub MoveItems(Item As Outlook.MailItem)
'****************************************************************************
'* Find mail from sender and move them from the inbox to the rquests folder *
'****************************************************************************
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myItem As Object
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
Set myDestFolder = myInbox.Folders("Rquests")
Set myItem = myItems.Find("[SenderEmailAddress] = '[email protected]'")
While TypeName(myItem) <> "Nothing"
    If myItem.UnRead = True Then
        myItem.Move myDestFolder
        Set myItem = myItems.FindNext
    End If
Wend
'*********************************************************
'* run the Process that extruct the number from the mail *
'*********************************************************
ProcessRequests
End Sub
---------------------------------------------------------------------------
Sub MoveItems2()
'*******************************************************************
'* Move the processed mail from the rquests to the  RQ_Done folder *
'*******************************************************************
Dim myNameSpace As Outlook.NameSpace
Dim mySourceFolder As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myItem As Object
Set myNameSpace = Application.GetNamespace("MAPI")
Set mySourceFolder = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("Rquests")
Set myItems = mySourceFolder.Items
Set myDestFolder = mySourceFolder.Folders("RQ_Done")
Set myItem = myItems.Find("[SenderEmailAddress] = '[email protected]'")
While TypeName(myItem) <> "Nothing"
    myItem.UnRead = False
    myItem.Move myDestFolder
    Set myItem = myItems.FindNext
Wend
End Sub
---------------------------------------------------------------------------
Sub ProcessRequests()
On Error Resume Next
Set myOlApp = Outlook.Application
Set myNameSpace = myOlApp.GetNamespace("mapi")
Dim msgtext As String
Dim TimeStamp As Date
'set the outlook folder to look at
Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("Rquests")
'set excel parameters
Dim xlApp As Object
Dim xlWkb As Object
Dim xlSheet As Object
Dim rCount As Long
Set xlApp = CreateObject("excel.application.12")
xlApp.Visible = True
'Open existing excel
Set xlWkb = xlApp.Workbooks.Open("C:\pathtofile\QTYperday.xlsm")
Set xlSheet = xlWkb.Sheets("Data")
xlApp.Worksheets("Data").Activate
'Find the next empty line of the worksheet
rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
rCount = rCount + 1
'Search all mail items in current mail directory
For i = 1 To myfolder.Items.Count
    Set myItem = myfolder.Items(i)
    sender = myItem.SenderEmailAddress
    If sender = "[email protected]" Then
        msgtext = myItem.Body
        TimeStamp = myItem.SentOn        
        'send the body of the mail message to the Function "onlyDigits" that will extract the numbers from it
        Dim myStr As String
        myStr = onlyDigits(msgtext)
        If myStr = "" Then
            myStr = "0"
        End If
        'get the date from date time
        mailDateY = DatePart("yyyy", TimeStamp) ' get Year
        MailDateM = DatePart("m", TimeStamp)    ' get Month
        MailDateD = DatePart("d", TimeStamp)    ' get Day
        MailDateW = DatePart("w", TimeStamp)    ' Get day of the week
        MailDate = (mailDateY & "/" & MailDateM & "/" & MailDateD)  ' Combine it to be a date again
        'set the day of the week
        If MailDateW = 1 Then
            MailDateW = "Sun"
        ElseIf MailDateW = 2 Then
            MailDateW = "Mon"
        ElseIf MailDateW = 3 Then
            MailDateW = "Tue"
        ElseIf MailDateW = 4 Then
            MailDateW = "Wed"
        ElseIf MailDateW = 5 Then
            MailDateW = "Thu"
        End If
        MailDay = MailDateW
        'write to excel
        xlSheet.Range("A" & rCount).value = myStr
        xlSheet.Range("B" & rCount).value = MailDate
        xlSheet.Range("C" & rCount).value = MailDateW
    Else
    End If
Next
xlApp.Worksheets("Sheet2").Activate
'Rerash and Save the excel
xlWkb.RefreshAll
xlWkb.Save
'************************
'mail the chart to list *
'************************
'Here I need the code to get the graph from excel and paste it to the email
'as an excel object or picture, It does not matter
'next is sending the mail with the graph (as attachement?)
Dim objMail As Outlook.MailItem
Set objMail = Application.CreateItem(olMailItem)
With objMail
        .To = "[email protected]"
        .CC = ""
        .BCC = ""
        .Subject = "Subject Line"
        .Body = "Body of mail"
        .Attachments.Add 'What, how?
        .Send   
End With
xlWkb.Close 1
xlApp.Quit
' Mark processed mail as Read and move it to RQ_done folder
MoveItems2
End Sub
---------------------------------------------------------------------------
Function onlyDigits(s As String) As String
'************************************
'* extruct the number from the mail *
'************************************
Dim retval As String    ' This is the return string.      '
Dim i As Integer        ' Counter for character position. '
' Initialise return string to empty                       '
retval = ""
' For every character in input string, copy digits to     '
'   return string.                                        '
For i = 1 To Len(s)
    If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then
        retval = retval + Mid(s, i, 1)
        If retval = "" Then
            retval = "0"
        End If
    End If
Next
' Then return the return string.                          '
onlyDigits = retval
End Function

У меня есть этот фрагмент кода, который работает в Excel, он сохраняет диаграмму, поскольку файл gif присоединяет его и отправляет, есть ли способ скрывать его для работы с Outlook?

Sub SaveSend_Embedded_Chart()
'Working in 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Fname As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    'File path/name of the gif file
     Fname = Environ$("temp") & "\My_Sales1.gif"

    'Save Chart named "Chart 1" as gif file
    'If you hold down the CTRL key when you select the chart
    'in 2000-2013 you see the name in the Name box(formula bar)
     ActiveWorkbook.Worksheets("Sheet2").ChartObjects("Chart 3").Chart.Export _
            Filename:=Fname, FilterName:="GIF"

    On Error Resume Next
    With OutMail
        .To = "[email protected]"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = "Hi there"
        .Attachments.Add Fname
        .Send   'or use .Display
     End With
     On Error GoTo 0

    'Delete the gif file
     Kill Fname

     Set OutMail = Nothing
     Set OutApp = Nothing
End Sub
+2
источник поделиться
2 ответа

Замените объекты Outlook объектами Excel, нет необходимости создавать экземпляр приложения Outlook в макросе Outlook VBA:

пример

Option Explicit
Sub SaveSend_Embedded_Chart()
    Dim Fname As String

    Dim App As Excel.Application
    Dim xlBook As Excel.Workbook

    Dim FilePath As String

    Path = "C:\Temp\"
    FileName = "Temp.xlsx"

    On Error Resume Next
    Set App = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Application.StatusBar = "Please wait while Excel source is opened ... "
        Set App = CreateObject("Excel.Application")
        xlStarted = True
    End If
    On Error GoTo 0

    '// Open the workbook to input the data
    Set xlBook = App.Workbooks.Open(Path & FileName)

    'File path/name of the gif file
     Fname = Environ$("temp") & "\My_Sales1.gif"

    'Save Chart named "Chart 1" as gif file
    'If you hold down the CTRL key when you select the chart
    'in 2000-2013 you see the name in the Name box(formula bar)
     xlBook.Worksheets("Sheet2").ChartObjects("Chart 3").Chart.Export _
            FileName:=Fname, FilterName:="GIF"

    With OutMail
        .To = "[email protected]"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = "Hi there"
        .Attachments.Add Fname
        .Send   'or use .Display
     End With

    'Delete the gif file
     Kill Fname

    xlBook.Close SaveChanges:=True
    If xlStarted Then
        App.Quit
    End If

    Set App = Nothing
    Set xlBook = Nothing
End Sub
+1
источник

Вам просто нужно ссылаться на объекты Excel, как в Sub ProcessRequests()

Видеть:

Sub SaveSend_Embedded_Chart()
 'Working in 2000-2016
 'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
     Dim OutApp As Object
     Dim OutMail As Object
     Dim Fname As String

     Set OutApp = CreateObject("Outlook.Application")
     Set OutMail = OutApp.CreateItem(0)

     'File path/name of the gif file
     Fname = Environ$("temp") & "\My_Sales1.gif"

     Dim xlApp As Object
     Dim xlWkb As Object
     Dim xlSheet As Object

     Set xlApp = CreateObject("Excel.Application")
     xlApp.Visible = True
     'Open existing excel file
     Set xlWkb = xlApp.Workbooks.Open("C:\pathtofile\QTYperday.xlsm")
     Set xlSheet = xlWkb.Sheets("Sheet2")

     'Save Chart named "Chart 1" as gif file
     'If you hold down the CTRL key when you select the chart
     'in 2000-2013 you see the name in the Name box(formula bar)
      xlSheet.ChartObjects("Chart 3").Chart.Export _
             FileName:=Fname, FilterName:="GIF"

     On Error Resume Next
     With OutMail
         .To = "[email protected]"
         .CC = ""
         .BCC = ""
         .Subject = "This is the Subject line"
         .Body = "Hi there"
         .Attachments.Add Fname
         .Send   'or use .Display
      End With
      On Error GoTo 0

     'Delete the gif file
      Kill Fname

      Set OutMail = Nothing
      Set OutApp = Nothing
 End Sub
+1
источник

Посмотрите другие вопросы по меткам или Задайте вопрос