Note: The other languages of the website are Google-translated. Back to English

Jak vložit podpis aplikace Outlook při odesílání e-mailů v aplikaci Excel?

Předpokládejme, že chcete odeslat e-mail přímo v aplikaci Excel, jak můžete do e-mailu přidat výchozí podpis aplikace Outlook? Tento článek poskytuje dvě metody, které vám pomohou přidat podpis aplikace Outlook při odesílání e-mailu v aplikaci Excel.

Při odesílání pomocí aplikace Excel VBA vložte podpis do e-mailu aplikace Outlook
Jednoduše vložte podpis aplikace Outlook při odesílání e-mailů v aplikaci Excel pomocí úžasného nástroje

Další výukové programy pro odesílání e-mailů v aplikaci Excel ...


Při odesílání pomocí aplikace Excel VBA vložte podpis do e-mailu aplikace Outlook

V listu je například seznam e-mailových adres, na které lze odesílat e-maily v aplikaci Excel na všechny tyto adresy a do e-mailů přidat výchozí podpis aplikace Outlook. Abyste toho dosáhli, použijte níže uvedený kód VBA.

1. Otevřete list obsahující seznam e-mailových adres, na který chcete poslat e-mail, a poté stiskněte Další + F11 klíče.

2. V otvoru Microsoft Visual Basic pro aplikace okno, klepněte na tlačítko Vložit > Modul, a poté zkopírujte níže VBA 2 do okna kódu modulu.

3. Nyní musíte vyměnit .Tělo řadit VBA 2 s kódem v VBA 1. Poté posuňte čáru .Zobrazit pod čarou S xMailOut.

VBA 1: Šablona pro odesílání e-mailů s výchozím podpisem aplikace Outlook v aplikaci Excel

.HTMLBody = "This is a test email sending in Excel" & "<br>" & .HTMLBody

VBA 2: Odesílání e-mailů na e-mailové adresy uvedené v buňkách v aplikaci Excel

Sub SendEmailToAddressInCells()
    Dim xRg As Range
    Dim xRgEach As Range
    Dim xRgVal As String
    Dim xAddress As String
    Dim xOutApp As Outlook.Application
    Dim xMailOut As Outlook.MailItem
    On Error Resume Next
    xAddress = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Please select email address range", "KuTools For Excel", xAddress, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Set xOutApp = CreateObject("Outlook.Application")
    Set xRg = xRg.SpecialCells(xlCellTypeConstants, xlTextValues)
    For Each xRgEach In xRg
        xRgVal = xRgEach.Value
        If xRgVal Like "?*@?*.?*" Then
            Set xMailOut = xOutApp.CreateItem(olMailItem)
            With xMailOut
                .To = xRgVal
                .Subject = "Test"
                .Body = "Dear " _
                      & vbNewLine & vbNewLine & _
                        "This is a test email " & _
                        "sending in Excel"
                .Display
                '.Send
            End With
        End If
    Next
    Set xMailOut = Nothing
    Set xOutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Následující snímek obrazovky vám pomůže snadno najít rozdíly po změně kódu VBA.

4. zmáčkni F5 klíč ke spuštění kódu. Pak Kutools pro Excel Zobrazí se pole pro výběr, vyberte prosím e-mailové adresy, na které budete posílat e-maily, a klikněte na OK.

Poté se vytvoří e-maily. Můžete vidět, že na konec těla e-mailu je přidán výchozí podpis aplikace Outlook.

Tip:

  • 1. Tělo e-mailu můžete změnit v kódu VBA 1 podle svých potřeb.
  • 2. Pokud se po spuštění kódu objeví chybové dialogové okno s varováním, že není definován uživatelem definovaný typ, zavřete toto dialogové okno a poté klikněte na Tools > Reference v Microsoft Visual Basic pro aplikace okno. V otvoru Reference - VBAProject okno, zkontrolujte Objektová knihovna Microsoft Outlook a klepněte na tlačítko OK. A pak spusťte kód znovu.

Jednoduše vložte podpis aplikace Outlook při odesílání e-mailů v aplikaci Excel pomocí úžasného nástroje

Pokud jste nováčkem ve VBA, zde velmi doporučujeme Odeslat e-maily užitečnost Kutools pro Excel pro tebe. Díky této funkci můžete snadno odesílat e-maily na základě určitých polí v aplikaci Excel a přidávat k nim podpis aplikace Outlook. Postupujte prosím následovně.

Před aplikací Kutools pro Excel, Prosím nejprve si jej stáhněte a nainstalujte.

Nejprve musíte vytvořit seznam adresátů s různými poli, podle kterých budete odesílat e-maily.

Podle potřeby můžete ručně vytvořit seznam adresátů nebo použít funkci Vytvořit seznam adres, abyste jej mohli rychle dokončit.

1. cvaknutí Kutools Plus > Vytvořte seznam adresátů.

2. V Vytvořte seznam adresátů V dialogovém okně zadejte požadovaná pole, vyberte, kam má být seznam vypsán, a klepněte na OK .

3. Nyní je vytvořen vzorek seznamu adresátů. Jelikož se jedná o ukázkový seznam, musíte změnit pole na určitý potřebný obsah. (povoleno více řádků)

4. Poté vyberte celý seznam (včetně hlaviček) a klepněte na Kutools Plus > Odeslat e-maily.

5. V Odeslat e-maily dialogové okno:

  • 5.1) Položky ve vybraném seznamu adresátů jsou automaticky umístěny do příslušných polí;
  • 5.2) Dokončete tělo e-mailu;
  • 5.3) Zkontrolujte obě Odesílejte e-maily prostřednictvím aplikace Outlook a Použijte nastavení podpisu Outlooku krabice;
  • 5.4) Klikněte na Poslat knoflík. Viz screenshot:

Nyní jsou odesílány e-maily. A výchozí podpis aplikace Outlook je přidán na konec těla e-mailu.

  Pokud chcete mít bezplatnou zkušební verzi (30-den) této utility, kliknutím jej stáhněte, a poté přejděte k použití operace podle výše uvedených kroků.


Související články:

Odesílejte e-maily na e-mailové adresy uvedené v buňkách v aplikaci Excel
Předpokládejme, že máte seznam e-mailových adres a chcete na tyto e-mailové adresy hromadně odesílat e-mailové zprávy přímo v aplikaci Excel. Jak toho dosáhnout? Tento článek vám ukáže způsoby odesílání e-mailů na více e-mailových adres, které jsou uvedeny v buňkách v aplikaci Excel.

Odesílejte e-maily s kopírováním a vkládáním zadaného rozsahu do těla e-mailu v aplikaci Excel
V mnoha případech může být při e-mailové komunikaci užitečný zadaný rozsah obsahu v listu aplikace Excel. V tomto článku představíme způsob odesílání e-mailu se zadaným rozsahem vkládání do těla e-mailu přímo v aplikaci Excel.

Odesílejte e-maily s více přílohami připojenými v aplikaci Excel
Tento článek hovoří o odesílání e-mailů prostřednictvím aplikace Outlook s více přílohami připojenými v aplikaci Excel.

Pokud byl v aplikaci Excel splněn termín splatnosti, odešlete e-mail
Pokud je například termín splatnosti ve sloupci C menší nebo roven 7 dnům (aktuální datum je 2017/9/13), pošlete e-mailovou upomínku určenému příjemci ve sloupci A se specifikovaným obsahem ve sloupci B. Jak dosáhnout toho? Tento článek poskytne metodu VBA k podrobnému řešení.

Automaticky odesílat e-maily na základě hodnoty buňky v aplikaci Excel
Předpokládejme, že chcete odeslat e-mail prostřednictvím aplikace Outlook určitému příjemci na základě zadané hodnoty buňky v aplikaci Excel. Například když je hodnota buňky D7 v listu větší než 200, automaticky se vytvoří e-mail. Tento článek představuje metodu VBA pro rychlé vyřešení tohoto problému.

Další výukové programy pro odesílání e-mailů v aplikaci Excel ...


Nejlepší kancelářské nástroje produktivity

Kutools pro Excel řeší většinu vašich problémů a zvyšuje vaši produktivitu o 80%

  • Opakované použití: Rychle vložte složité vzorce, grafy a cokoli, co jste dříve používali; Šifrovat buňky s heslem; Vytvořte seznam adresátů a posílat e-maily ...
  • Super Formula Bar (snadno upravit více řádků textu a vzorce); Rozložení pro čtení (snadno číst a upravovat velké množství buněk); Vložit do filtrovaného rozsahu...
  • Sloučit buňky / řádky / sloupce bez ztráty dat; Rozdělit obsah buněk; Zkombinujte duplicitní řádky / sloupce... Zabraňte duplicitním buňkám; Porovnat rozsahy...
  • Vyberte možnost Duplikovat nebo Jedinečný Řádky; Vyberte prázdné řádky (všechny buňky jsou prázdné); Super hledání a fuzzy hledání v mnoha sešitech; Náhodný výběr ...
  • Přesná kopie Více buněk beze změny odkazu na vzorec; Automaticky vytvářet reference do více listů; Vložte odrážky, Zaškrtávací políčka a další ...
  • Extrahujte text, Přidat text, Odebrat podle pozice, Odebrat mezeru; Vytváření a tisk mezisoučtů stránkování; Převod mezi obsahem buněk a komentáři...
  • Super filtr (uložit a použít schémata filtrů na jiné listy); Rozšířené řazení podle měsíce / týdne / dne, frekvence a dalších; Speciální filtr tučnou kurzívou ...
  • Kombinujte sešity a pracovní listy; Sloučit tabulky na základě klíčových sloupců; Rozdělte data do více listů; Dávkový převod xls, xlsx a PDF...
  • Více než 300 výkonných funkcí. Podporuje Office / Excel 2007-2021 a 365. Podporuje všechny jazyky. Snadné nasazení ve vašem podniku nebo organizaci. Plné funkce 30denní bezplatná zkušební verze. 60denní záruka vrácení peněz.
karta kte 201905

Office Tab přináší do Office rozhraní s kartami a usnadňuje vám práci

  • Povolte úpravy a čtení na kartách ve Wordu, Excelu, PowerPointu, Publisher, Access, Visio a Project.
  • Otevřete a vytvořte více dokumentů na nových kartách ve stejném okně, nikoli v nových oknech.
  • Zvyšuje vaši produktivitu o 50%a snižuje stovky kliknutí myší každý den!
officetab dno
Komentáře (27)
Zatím žádné hodnocení. Buďte první, kdo ohodnotí!
Tento komentář byl moderátorem webu minimalizován
děkuji moc, zachránila jste mi život s touto šablonou :D
Tento komentář byl moderátorem webu minimalizován
Milý Favio,
Rád jsem pomohl.
Tento komentář byl moderátorem webu minimalizován
nefunguje s přílohami v Office 2016
Tento komentář byl moderátorem webu minimalizován
Drahý Chrisi,
Níže uvedený kód VBA vám může pomoci. Po spuštění kódu vyberte buňky obsahující e-mailové adresy, na které budete posílat e-maily, a poté, když se objeví druhé dialogové okno, vyberte soubory, které potřebujete k e-mailu připojit jako přílohy. A výchozí podpis Outlooku se zobrazí také v těle e-mailu. Děkuji za váš komentář.

Sub SendEmailToAddressInCells()
Dim xRg jako rozsah
Dim xRgEach As Range
Dim xRgVal As String
Ztlumit xAddress jako řetězec
Dim xOutApp jako Outlook.Application
Dim xMailOut jako Outlook.MailItem
On Error Resume Next
xAddress = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Vyberte rozsah e-mailových adres", "KuTools For Excel", xAddress, , , , , 8)
Pokud xRg není nic, pak Exit Sub
Application.ScreenUpdating = False
Set xOutApp = CreateObject("Outlook.Application")
Nastavit xRg = xRg.SpecialCells(xlCellTypeConstants, xlTextValues)
Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
Pokud xFileDlg.Show = -1 Pak
Pro každý xRgKaždý v xRg
xRgVal = xRgEach.Value
If xRgVal Like "?*@?*.?*" Pak
Nastavit xMailOut = xOutApp.CreateItem(olMailItem)
S xMailOut
.Zobrazit
.To = xRgVal
.Předmět = "Test"
.HTMLBody = "Toto je zkušební odeslání e-mailu v Excelu" & "
" & .HTMLBody
Pro každý xFileDlgItem v xFileDlg.SelectedItems
.Přílohy.Přidat xFileDlgItem
Další xFileDlgItem
'.Poslat
Konec s
End If
další
Nastavte xMailOut = nic
Nastavte xOutApp = Nic
Application.ScreenUpdating = True
End If
End Sub
Tento komentář byl moderátorem webu minimalizován
Snažím se přidat podpis aplikace Outlook s názvem „výchozí“, ale zdá se, že to funguje.
můžete prosím pomoci? Věřím, že moje "xMailout" logika je špatná. toto je moje podezření na vadnou oblast.

Private Sub CommandButton1_Click ()

Dim xOutApp jako objekt
Dim xOutMail jako objekt
Dim xMailBody jako řetězec
Dim xMailOut jako Outlook.MailItem
On Error Resume Next
Set xOutApp = CreateObject("Outlook.Application")
Nastavit xOutMail = xOutApp.CreateItem(0)
xMailBody = "Pozdravy:" & vbNewLine & vbNewLine & _
"Toto je řádek 1" & vbNewLine & _
"Toto je řádek 2" & vbNewLine & _
"Toto je řádek 3" & vbNewLine & _
"Toto je řádek 4"
On Error Resume Next
S xOutMail
.To = "Email.here.com"
.CC = "Email.here.com"
.Subject = "Název e-mailu zde - " & Rozsah("Cell#").hodnota
.Tělo = xMailBody
. Attachments.Add ActiveWorkbook.FullName
Nastavit xMailOut = xOutApp.CreateItem(olMailItem)
S xMailOut
.Zobrazit
Konec s
ActiveWorkbook.Save
Při chybě GoTo 0
Nastavte xOutMail = nic
Nastavte xOutApp = Nic
End Sub
Tento komentář byl moderátorem webu minimalizován
Dobrý den,
Váš skript byl upraven, zkuste to prosím. Děkuji.

Private Sub CommandButton1_Click ()
Dim xOutApp jako objekt
Dim xOutMail jako objekt
Dim xMailBody jako řetězec
Dim xMailOut jako Outlook.MailItem
On Error Resume Next
Set xOutApp = CreateObject("Outlook.Application")
Nastavit xOutMail = xOutApp.CreateItem(0)
xMailBody = "Pozdravy:" & vbNewLine & vbNewLine & _
"Toto je řádek 1" & vbNewLine & _
"Toto je řádek 2" & vbNewLine & _
"Toto je řádek 3" & vbNewLine & _
"Toto je řádek 4"
On Error Resume Next
S xOutMail
.To = "Email.here.com"
.CC = "Email.here.com"
.Subject = "Název e-mailu zde - " & Rozsah("Cell#").Hodnota
.Tělo = xMailBody
.Attachments.Add ActiveWorkbook.FullName
Nastavit xMailOut = xOutApp.CreateItem(olMailItem)
S xMailOut
.Zobrazit
Konec s
Konec s
ActiveWorkbook.Save
Při chybě GoTo 0
Nastavte xOutMail = nic
Nastavte xOutApp = Nic
End Sub
Tento komentář byl moderátorem webu minimalizován
jak přidat podpis, pokud makro používá více uživatelů.
např. moje makro budou provozovat také 3 další osoby. Jak tedy může makro použít podpis uživatele, který makro spouští.
díky předem
Tento komentář byl moderátorem webu minimalizován
Dobrý den,
Kód VBA dokáže automaticky rozpoznat výchozí podpis v Outlooku odesílatele a odeslat e-mail s jeho vlastním podpisem přes Outlook.
Tento komentář byl moderátorem webu minimalizován
Pokud je můj hlavní text propojen s vytažením z polí aplikace Excel, použití & .HTMLBody na konci řetězce vymaže veškerý hlavní text a ponechá pouze podpis.
Tento komentář byl moderátorem webu minimalizován
Mám potíže se spuštěním v aplikaci Excel 2016. Zobrazuje se mi zpráva „Chyba kompilace: Uživatelsky definovaný typ není definován“. Prosím pomozte!
Tento komentář byl moderátorem webu minimalizován
Nádherný!!!!
Tento komentář byl moderátorem webu minimalizován
Díky moc ...
Tento komentář byl moderátorem webu minimalizován
Ahoj, potřeboval bych pomoct s mým makrem, potřebuji vložit pod tabulku Outlook podpis, mohli byste mi s tím pomoci?

Private Sub CommandButton1_Click ()


Tlumený výhled jako objekt
Ztlumit nový e-mail jako objekt
Dim xInspect As Object
Ztlumit editor stránek jako objekt

Nastavit výhled = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)

S novým e-mailem
.To = List5.Range("F1")
.CC = ""
.BCC = ""
.Subject = List5.Range("B5")
.Body = List5.Range("B41")
.Zobrazit

Nastavit xInspect = newEmail.GetInspector
Nastavit pageEditor = xInspect.WordEditor

List5.Rozsah("B6:I7").Kopírovat

pageEditor.Application.Selection.Start = Délka(.Body)
pageEditor.Application.Selection.End = pageEditor.Application.Selection.Start
pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)

.Zobrazit
Nastavit pageEditor = Nic
Nastavit xInspect = nic
Konec s

Nastavit nový e-mail = nic
Nastavit výhled = nic

End Sub
Tento komentář byl moderátorem webu minimalizován
ahoj Bára,
S tím vám bohužel nepomůžu. Děkuji za Váš komentář.
Tento komentář byl moderátorem webu minimalizován
Milý,
Může mi někdo pomoci s mým VBA,
Potřebuji podpis ve vytvořeném e-mailu:
Tento komentář byl moderátorem webu minimalizován
Díky vám mohu nyní přidat podpis, ale pak to odstraní mezery mezi odstavci textu. Prosím, můžete mi pomoci?


Sub helloworld()
Ztlumit OutApp jako objekt
Dim OutMail As Object
Ztlumit buňku jako rozsah
Ztlumit cestu jako řetězec
Cesta = Application.ActiveWorkbook.Path
Set OutApp = CreateObject("Outlook.Application")

Pro každou buňku v rozsahu("C4:C6")
Nastavit OutMail = OutApp.CreateItem(0)
S OutMail
.Zobrazit
.Do = buňka.Hodnota
.Předmět = Buňky(buňka.Řádek, "D").Hodnota
.HTMLBody = "Vážený" & Cells(cell.Row, "B").Value & "," _
& vbNewLine & vbNewLine & _
"Vřelé pozdravy" _
& vbNewLine & vbNewLine & _
"My, JK Overseas, bychom rádi využili příležitosti a představili naši společnost JK Overseas, která se zabývá solným byznysem poslední 3 roky. V současnosti jsme silní v tuzemsku a expandujeme do zámoří. Jsme dodavatelem Jedlé soli, Sůl na změkčování vody, rozmrazovací sůl, průmyslová sůl" & "." _
& vbNewLine & vbNewLine & _
"Máme spojení s velkými výrobci v Indii a zajišťujeme od nich kvalitní sůl a exportujeme. Takže hledáme spolehlivého odborníka na dovozce a distributora, abychom mohli dlouhodobě obchodovat se vzájemným prospěchem" & " ." _
& vbNewLine & vbNewLine & _
"Prosím, kontaktujte nás se svým požadavkem nebo s jakýmikoli jinými dotazy, které můžete mít. Poskytujeme spolehlivou logistiku a včasné dodání. Jsme přesvědčeni, že naše ceny, které jsou nejvíce konkurenceschopné, budou odpovídat vašim očekáváním" & "." _
& vbNewLine & vbNewLine & _
.HTMLBody

'.Poslat
Konec s
Další buňka
End Sub
Tento komentář byl moderátorem webu minimalizován
Snažím se integrovat tento kód do aktuálního formátu, který v současné době mám, čímž jsem schopen automatizovat e-maily v Excelu na základě nastaveného rozsahu hodnot. Jakákoli pomoc ohledně toho, kam přidat kód „podpis“ v rámci toho, co v současné době mám, by byla velmi oceněna.

Public Sub CheckAndSendMail()

'Aktualizováno Extendoffice 2018 / 11 / 22

Dim xRgDate jako rozsah

Dim xRgSend As Range

Dim xRgText jako rozsah

Dim xRgDone As Range

Dim xOutApp jako objekt

Dim xMailItem jako objekt

Dim xLastRow As Long

Dim vbCrLf jako řetězec

Dim xMailBody jako řetězec

Dim xRgDateVal jako řetězec

Dim xRgSendVal jako řetězec

Dim xMailSubject jako řetězec

Dim I As Long

On Error Resume Next

'Upřesněte prosím období splatnosti

xStrRang = "D2:D110"

Nastavit xRgDate = rozsah (xStrRang)

'Upřesněte prosím rozsah e-mailových adres příjemců

xStrRang = "C2:C110"

Nastavit xRgSend = Rozsah (xStrRang)

xStrRang = "A2:A110"

Nastavit xRgName = Range(xStrRang)

'Upřesněte rozsah s připomenutým obsahem ve svém e-mailu

xStrRang = "Z2:Z110"

Nastavit xRgText = Range(xStrRang)

xLastRow = xRgDate.Rows.Count

Nastavit xRgDate = xRgDate(1)

Nastavit xRgSend = xRgSend(1)

Nastavit xRgName = xRgName(1)

Nastavit xRgText = xRgText(1)

Set xOutApp = CreateObject("Outlook.Application")

Pro I = 1 To xLastRow

xRgDateVal = ""

xRgDateVal = xRgDate.Offset(I - 1).Hodnota

If xRgDateVal <> "" Pak

If CDate(xRgDateVal) - Date <= 30 And CDate(xRgDateVal) - Date > 0 Then

xRgSendVal = xRgSend.Offset(I - 1).Hodnota

xMailSubject = " Smlouva o poskytování služeb JBC vyprší dne " & xRgDateVal

vbCrLf = "

"

xMailBody = ""

xMailBody = xMailBody & "Dear" & xRgName.Offset(I - 1).Value & vbCrLf

xMailBody = xMailBody & " " & xRgText.Offset(I - 1).Value & vbCrLf

xMailBody = xMailBody & ""

Nastavit xMailItem = xOutApp.CreateItem(0)

S xMailItem

.Předmět = xMailSubject

.To = xRgSendVal

.CC = "mailcc@justbettercare.com"

.HTMLBody = xMailBody

.Zobrazit

'.Poslat

Konec s

Nastavit xMailItem = nic

End If

End If

další

Nastavte xOutApp = Nic

End Sub
Tento komentář byl moderátorem webu minimalizován
Je to opravdu užitečný kód
Potřebuji změnit formát textu zprava doleva v řádku xOutMsg
pomoc prosím .
Tento komentář byl moderátorem webu minimalizován
Snažím se odesílat jednotlivé listy z excelu na různé e-maily, ale připojí pouze samotný sešit. Také musím být schopen přidat můj podpisový řádek. Nějaká pomoc?Sub AST_Email_From_Excel()

Dim emailApplication as Object
Dim emailItem as Object

Set emailApplication = CreateObject("Outlook.Application")
Set emailItem = emailApplication.CreateItem(0)

Nyní vytváříme e-mail.

emailItem.to = Rozsah("e2").Hodnota

emailItem.CC = Rozsah("g2").Hodnota

emailItem.Subject = "Nevrácené technické vybavení"

emailItem.Body = "Nevrácené položky ve vaší oblasti naleznete v přiložené tabulce"

'Přiložte aktuální sešit
emailItem.Attachments.Add ActiveWorkbook.FullName

'Přiložte jakýkoli soubor z vašeho počítače.
'emailItem.Attachments.Add ("C:\...)"

'Pošlete e-mail
'emailItem.send

'Zobrazte e-mail, aby jej uživatel mohl před odesláním změnit podle potřeby
emailItem.Display

Nastavit emailItem = nic
Nastavit emailApplication = Nic

End Sub
Tento komentář byl moderátorem webu minimalizován
Ahoj Chrisi, zadaný kód byl změněn. Podpis aplikace Outlook lze nyní vložit do těla zprávy. Zkuste to prosím. Děkuji. Sub AST_Email_From_Excel()
'Aktualizováno Extendoffice 20220211
Dim emailApplication as Object
Dim emailItem as Object
Set emailApplication = CreateObject("Outlook.Application")
Set emailItem = emailApplication.CreateItem(0)

Nyní vytváříme e-mail.
emailItem.Display 'Zobrazí e-mail, aby jej uživatel mohl před odesláním změnit podle potřeby
emailItem.to = Rozsah("e2").Hodnota
emailItem.CC = Rozsah("g2").Hodnota
emailItem.Subject = "Nevrácené technické vybavení"
emailItem.HTMLBody = "Nevrácené položky ve vaší oblasti naleznete v přiložené tabulce" & " " & emailItem.HTMLBody

'Přiložte aktuální sešit
emailItem.Attachments.Add ActiveWorkbook.FullName

Nastavit emailItem = nic
Nastavit emailApplication = Nic

End Sub
Tento komentář byl moderátorem webu minimalizován
Ahoj Crystal, děkuji, že jsi ho přiměla přidat podpis, ale nezdá se, že by se mu sekce HTMLBody zamlouvala. Když makro spustím, ladí se na emailItem.HTMLBody = "Nevrácené položky ve vaší oblasti naleznete v přiložené tabulce" & " " & emailItem.HTMLBodyand zbytek nedokončí.  
Tento komentář byl moderátorem webu minimalizován
Dobrý den,
Jakou verzi Excelu používáte? Pomoci může i následující kód VBA. Zkuste to prosím. Děkujeme za vaši odezvu. Dílčí SendWorkSheet()
'Aktualizovat od Extendoffice 20220218
Dim xFile As String
Dim xFormat As Long
Dim Wb jako sešit
Dim Wb2 jako sešit
Dim FilePath jako řetězec
Dim název_souboru jako řetězec
Ztlumit aplikaci OutlookApp jako objekt
Ztlumit OutlookMail jako objekt
On Error Resume Next
Application.ScreenUpdating = False
Nastavte Wb = Application.ActiveWorkbook
ActiveSheet.Copy
Nastavte Wb2 = Application.ActiveWorkbook
Vyberte Case Wb.FileFormat
Pouzdro xlOpenXMLWorkbook:
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
Case xlOpenXMLWorkbookMacroEnabled:
Pokud Wb2.HasVBProject Then
xFile = ".xlsm"
xFormat = xlOpenXMLWorkbookMacroEnabled
Jiný
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
End If
Případ Excel8:
xFile = ".xls"
xFormat = Excel8
Případ xlExcel12:
xFile = ".xlsb"
xFormat = xlExcel12
Konec Vybrat
FilePath = Environ$("temp") & "\"
FileName = Wb.Name & Format(Nyní, "dd-mmm-yy h-mm-ss")
Nastavit OutlookApp = CreateObject("Outlook.Application")
Nastavit OutlookMail = OutlookApp.CreateItem(0)
Wb2.SaveAs FilePath & FileName & xFile, FileFormat:=xFormat
'xstr = Range("e2") & " ; " & Range("g2")
S OutlookMailem
.Zobrazit
.To = Range("e2")
.CC = Range("g2")
.BCC = ""
.Subject = "Nevrácené technické vybavení"
.HTMLBody = "Nevrácené položky ve vaší oblasti naleznete v přiložené tabulce" & " " & .HTMLBody
.Přílohy.Přidat Wb2.FullName
'.Poslat
Konec s
Wb2.Zavřít
Zabijte FilePath & FileName & xFile
Nastavit OutlookMail = nic
Nastavit OutlookApp = nic
Application.ScreenUpdating = True
End Sub
Tento komentář byl moderátorem webu minimalizován
Vypadá to na Excel 2016 a VBA 7.1
Tento komentář byl moderátorem webu minimalizován
Oi Cristal, minha makro pro konfiguraci e-mailu, obrázků a originálního formátu. Como consigo resolver?

Sub Geraremail()

Dim OLapp jako Outlook.Application
Dim Janela Jako Outlook.MailItem

Nastavit OLapp = New Outlook.Application
Nastavit janela = OLapp.CreateItem(olMailItem)

Arquivo01 = "Mapa AN"
Anexo01 = ThisWorkbook.Path & "\" & Arquivo01 & ".xlsm"


S Janelou
ActiveWorkbook.Save
.Zobrazit
.Do = Listy("Základ").Rozsah("A2").Hodnota
.CC = Listy("Základ").Rozsah("A5").Hodnota
.Subject = "Mapa - Acrilo " & Format(Date, "dd.mm.yy")
assinatura = .Tělo
.Body = "Prezados/as," & Chr(10) & Chr(10) & "Segue anexo o mapa de Acrilonitrila uvažuje jako vendas previstas no S&OP." & Chr(10) & Chr(10) & assinatura
.Přílohy.Přidat Anexo01
Konec s

End Sub
Tento komentář byl moderátorem webu minimalizován
Com a mudança abaixo, consegui ajustar. Porém a letra do corpo da mensagem fica em Times New Roman. Gostaria de usar Calibri, co je možné změnit nebo kód?

Sub Geraremail()

Dim OLapp jako Outlook.Application
Dim Janela Jako Outlook.MailItem

Nastavit OLapp = New Outlook.Application
Nastavit janela = OLapp.CreateItem(olMailItem)

Arquivo01 = "Mapa AN"
Anexo01 = ThisWorkbook.Path & "\" & Arquivo01 & ".xlsm"


S Janelou
ActiveWorkbook.Save
.Zobrazit
.Do = Listy("Základ").Rozsah("A2").Hodnota
.CC = Listy("Základ").Rozsah("A5").Hodnota
.Subject = "Mapa - Acrilo " & Format(Date, "dd.mm.yy")
assinatura = .Tělo
.HTMLBody = "Prezados/as," & Chr(10) & Chr(10) & "Segue anexo o map de Acrilonitrila reflectando as vendas previstas no S&OP." & " " & .HTMLBody
.Přílohy.Přidat Anexo01
Konec s

End Sub
Tento komentář byl moderátorem webu minimalizován
Ahoj Milla,
Následující kód VBA vám může pomoci změnit písmo těla e-mailu na Calibri, zkuste to prosím. Děkuji.
Před spuštěním kódu musíte kliknout Tools > Odkaz v Microsoft Visual Basic pro aplikace okno a poté zkontrolujte Objektová knihovna Microsoft Word zaškrtávací políčko Reference - VBAProject dialogové okno jako na snímku obrazovky níže.
[img]I:\工作\周雪明\2022年工作\6月份\文章评论截图\3.png[/img]
Sub Geraremail()
Dim OLapp As Outlook.Application
Dim janela As Outlook.MailItem
Dim xDoc As Document 'Click Tools > Reference to enable the Microsoft Word Object Library
On Error Resume Next
Set OLapp = New Outlook.Application
Set janela = OLapp.CreateItem(olMailItem)
Arquivo01 = "Mapa AN"
Anexo01 = ThisWorkbook.Path & "\" & Arquivo01 & ".xlsm"
With janela
  ActiveWorkbook.Save
  .Display
  .To = Sheets("Base").Range("A2").Value
  .CC = Sheets("Base").Range("A5").Value
  .Subject = "Mapa - Acrilo " & Format(Date, "dd.mm.yy")
   assinatura = .Body
  .HTMLBody = "Prezados/as," & Chr(10) & Chr(10) & "Segue anexo o mapa de Acrilonitrila considerando as vendas previstas no S&OP." & "<br>" & .HTMLBody
  .Attachments.Add Anexo01
End With
Set xDoc = janela.GetInspector.WordEditor
xDoc.Content.Font.Name = "Calibri"
End Sub
Tento komentář byl moderátorem webu minimalizován
Ahoj Milla,
Následující kód VBA vám může pomoci změnit písmo těla e-mailu na Calibri, zkuste to prosím. Děkuji.
Před spuštěním kódu musíte kliknout Tools > Odkaz v Microsoft Visual Basic pro aplikace okno a poté zkontrolujte Objektová knihovna Microsoft Word zaškrtávací políčko Reference - VBAProject dialogové okno jako níže uvedený přiložený soubor.
Sub Geraremail()
Dim OLapp As Outlook.Application
Dim janela As Outlook.MailItem
Dim xDoc As Document 'Click Tools > Reference to enable the Microsoft Word Object Library
On Error Resume Next
Set OLapp = New Outlook.Application
Set janela = OLapp.CreateItem(olMailItem)
Arquivo01 = "Mapa AN"
Anexo01 = ThisWorkbook.Path & "\" & Arquivo01 & ".xlsm"
With janela
  ActiveWorkbook.Save
  .Display
  .To = Sheets("Base").Range("A2").Value
  .CC = Sheets("Base").Range("A5").Value
  .Subject = "Mapa - Acrilo " & Format(Date, "dd.mm.yy")
   assinatura = .Body
  .HTMLBody = "Prezados/as," & Chr(10) & Chr(10) & "Segue anexo o mapa de Acrilonitrila considerando as vendas previstas no S&OP." & "<br>" & .HTMLBody
  .Attachments.Add Anexo01
End With
Set xDoc = janela.GetInspector.WordEditor
xDoc.Content.Font.Name = "Calibri"
End Sub
Zatím zde nejsou žádné komentáře
Zanechat své připomínky
Odesílání jako host
×
Ohodnoťte tento příspěvek:
0   Postavy
Doporučená umístění

Sociální sítě

Copyright © 2009 - www.extendoffice.com. | Všechna práva vyhrazena. Poháněno ExtendOffice. | |. | Sitemap
Microsoft a logo Office jsou ochranné známky nebo registrované ochranné známky společnosti Microsoft Corporation ve Spojených státech a / nebo jiných zemích.
Chráněno Sectigo SSL