Úprava kódu VBA

Programy pro práci v kanceláři (Word, Excel, Access…=>Office)

Moderátor: Mods_senior

luko02420
Level 2
Level 2
Příspěvky: 165
Registrován: únor 12
Pohlaví: Nespecifikováno

Úprava kódu VBA

Příspěvekod luko02420 » 15 bře 2020 11:50

Dobrý den potřeboval bych poradit s následujícím kódem.
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



Reklama
  • Mohlo by vás zajímat
    Odpovědi
    Zobrazení
    Poslední příspěvek
  • Úprava kódu
    od barunkabro » 12 čer 2019 09:18 » v Kancelářské balíky
    1
    796
    od Grimm
    15 čer 2019 16:28
  • Pytest konzultace kodu
    od shockwave » 03 kvě 2020 11:06 » v Programování a tvorba webu
    4
    262
    od CZechBoY
    04 kvě 2020 16:52
  • Java - Zjednodušení kódu
    od Lukkys4 » 29 kvě 2020 00:07 » v Programování a tvorba webu
    2
    187
    od Lukkys4
    29 kvě 2020 17:21
  • Problém s načítáním QR kódu v aplikaci AirMore
    od ivosisko » 17 kvě 2020 23:08 » v Komunikace na internetu
    0
    170
    od ivosisko
    17 kvě 2020 23:08
  • Stažení obrázku ve velkém rozlišení z kódu webu
    od Grander » 04 úno 2020 22:09 » v Internet a internetové prohlížeče
    4
    761
    od Grander
    05 úno 2020 00:50

Zpět na “Kancelářské balíky”

Kdo je online

Uživatelé prohlížející si toto fórum: CommonCrawl [Bot] a 2 hosti