Používám ho na odesílání souboru excel outlookem.
A chtěl bych do mailové zprávy v která je vytvořena záznamem ve VBA,( 'text zprávy a určení buňky) do podpisu v emailu vložit obrázek(logo firmy), který bude uložen v listu sesitu.
Nemůžu na to příjít.
Děkuji všem za ochotu.
Kód: Vybrat vše
Sub Odeslani() 'Odesílá potvrzeni
Dim objNsp As Object, colSyc As Object, objSyc As Object, i As Integer, adresat As String, Soubor As String, SouborXLSM As String, Cely As Boolean, O As Object, Pripona As String
'!!!!!Před použitím je třeba v Tools / References zaškrtnout volbu Microsoft Outlook xx.0 Object Library.!!!!!
'Tools / References / Microsoft Outlook x.x Object Library
'Celý zošit = True, iba aktívny list = False
Cely = False
Sheets("Report").Select
With ActiveSheet
With .Range("C1")
.Value = Now()
.NumberFormat = "d/m/yyyy h:mm;@"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'.Range("D37:D38").ClearContents
' Uložení souboru
Pripona = .Range("M1")
Soubor = "D:\pokus email \" & .Range("L1") & " " & .Range("K1") & "." & .Range("J1") & "." & Pripona
Select Case Pripona
Case "xlsx", "xlsm": SouborXLSM = Replace(Soubor, ".xlsx", ".xlsm")
With Application: .ScreenUpdating = False: .DisplayAlerts = False: End With
Select Case Cely
Case True: ThisWorkbook.SaveCopyAs SouborXLSM
If Pripona = "xlsx" Then
With Workbooks.Open(SouborXLSM)
.SaveAs Soubor, 51
.Close
End With
Kill SouborXLSM
End If
Case False: ActiveSheet.Copy
With ActiveWorkbook
If Pripona = "xlsx" Then .SaveAs Soubor, 51 Else .SaveAs SouborXLSM, 52
.Close
End With
End Select
With Application: .ScreenUpdating = True: .DisplayAlerts = False: End With
Case "pdf": If Cely Then Set O = ThisWorkbook Else Set O = ActiveSheet
O.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Soubor, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End Select
'Soubor = "I:\\" & .Range("C35") & " " & .Range("L1") & .Range("M2")
End With
Range("A2:B20").ClearContents
Sheets("Nové karty import ").Select
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set objNsp = OutApp.Application.GetNamespace("MAPI") 'CORRECTION to Refer to the OutLook Application correctly
Set colSyc = objNsp.SyncObjects
adresat = Range("L1") ' emailová adresa příjemce
With OutMail
'adresát
.To = adresat
'kopie pro
'.CC = Range("O1")
'předmět zprávy
.Subject = "New purchased variants_Potvrzení"
'text zprávy a určení buňky
.Body = "Dobrý den, zasíláme Vám ceny poptávaných položek . Viz příloha. " & Sheets("Report").Range("L1") & Chr(13) & Chr(13) & "S pozdravem" & Chr(13) & Chr(13) & Sheets("Report").Range("H1") & Chr(13) & Chr(13) & Sheets("Report").Range("I1")
'aktivní (uložený) sešit jako příloha
.Attachments.Add Soubor
'Nastavení preferovaného účtu pro odeslání pošty - v tomto případě druhý v pořadí
'Dostupné od verze Office 2007
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
'odeslání zprávy
.Send
End With
For i = 1 To colSyc.Count
Set objSyc = colSyc.Item(i)
objSyc.Start
Next i
'Kill Soubor
'OutApp.Quit
MsgBox "Zpráva byla odeslána na adresu: " & Range("M1"), vbInformation
'uvolnění z paměti
Set OutMail = Nothing: Set objNsp = Nothing: Set colSyc = Nothing: Set objSyc = Nothing: Set OutApp = Nothing: Set O = Nothing
End Sub