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

Jak uložit list jako soubor PDF a poslat jej e-mailem jako přílohu prostřednictvím aplikace Outlook?

V některých případech možná budete muset odeslat list jako soubor PDF prostřednictvím Outlooku. Obvykle musíte ručně uložit list jako soubor PDF, poté vytvořit nový e-mail s tímto souborem PDF jako přílohou v aplikaci Outlook a nakonec jej odeslat. Je časově náročné dosáhnout toho ručně krok za krokem. V tomto článku vám ukážeme, jak rychle uložit list jako soubor PDF a automaticky jej odeslat jako přílohu prostřednictvím aplikace Outlook v aplikaci Excel.

Uložte list jako soubor PDF a pošlete jej e-mailem jako přílohu s kódem VBA


Uložte list jako soubor PDF a pošlete jej e-mailem jako přílohu s kódem VBA


Spuštěním níže uvedeného kódu VBA můžete automaticky uložit aktivní list jako soubor PDF a poté jej poslat e-mailem jako přílohu prostřednictvím aplikace Outlook. Postupujte prosím následovně.

1. Otevřete list, který uložíte jako PDF, odešlete a stiskněte Další + F11 současně otevřete Microsoft Visual Basic pro aplikace okno.

2. V Microsoft Visual Basic pro aplikace okno, klepněte na tlačítko Vložit > Modul. Poté zkopírujte a vložte níže uvedený kód VBA do Kód okno. Viz snímek obrazovky:

Kód VBA: Uložte list jako soubor PDF a pošlete jej e-mailem jako přílohu

Sub Saveaspdfandsend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range

Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
   xFolder = xFileDlg.SelectedItems(1)
Else
   MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
   Exit Sub
End If
xFolder = xFolder + "\" + xSht.Name + ".pdf"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "if you don't overwrite the existing PDF, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
        Exit Sub
    End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as PDF file 
    xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
    
    'Create Outlook email 
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
        .To = ""
        .CC = ""
        .Subject = xSht.Name + ".pdf"
        .Attachments.Add xFolder
        If DisplayEmail = False Then
            '.Send
        End If
    End With
Else
  MsgBox "The active worksheet cannot be blank"
  Exit Sub
End If
End Sub

3. zmáčkni F5 klíč ke spuštění kódu. V Procházet V dialogovém okně vyberte složku, do které chcete tento soubor PDF uložit, a poté klikněte na ikonu OK .

Poznámky:

1. Nyní je aktivní list uložen jako soubor PDF. A soubor PDF je pojmenován názvem listu.
2. Pokud je aktivní list prázdný, po kliknutí na se zobrazí dialogové okno, jak je uvedeno níže OK .

4. Nyní je vytvořen nový e-mail aplikace Outlook a můžete vidět, že soubor PDF je uveden jako příloha v přiloženém souboru. Viz snímek obrazovky:

5. Napište prosím tento e-mail a poté jej odešlete.
6. Tento kód je k dispozici, pouze pokud používáte Outlook jako poštovní program.

Jednoduše uložte list nebo více listů jako samostatné soubory PDF najednou:

Projekt Rozdělit sešit užitečnost Kutools pro Excel vám pomůže snadno uložit list nebo více listů jako samostatné soubory PDF najednou, jak je ukázáno níže. Stáhněte si a vyzkoušejte hned! (30denní trasa zdarma)


Související články:


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-2019 a 365. Podporuje všechny jazyky. Snadné nasazení ve vašem podniku nebo organizaci. Kompletní 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 omezuje stovky kliknutí myší každý den!
officetab dno
Komentáře (61)
Hodnocení 5 z 5 · 1 hodnocení:
Tento komentář byl moderátorem webu minimalizován
Funguje to pro mě skvěle, ale existuje způsob, jak vybrat umístění složky automaticky místo ručního výběru? Doufám, že to udělám pro 40 listů najednou.
Tento komentář byl moderátorem webu minimalizován
Také doufám, že uvidí odpověď na tento problém! Děkuji za pomoc!
Tento komentář byl moderátorem webu minimalizován
Zkoušel jsem to vložit do nového modulu a dostávám chybu kompilace: Sub or Function not define. Prosím pomozte.
Tento komentář byl moderátorem webu minimalizován
Milý Darrene,
Jakou verzi Office používáte?
Tento komentář byl moderátorem webu minimalizován
Office 360
Tento komentář byl moderátorem webu minimalizován
Stejný problém
Tento komentář byl moderátorem webu minimalizován
Jak bych upravil výše uvedený skript VBA, aby k názvu souboru přidal datum a časové razítko, aby nepřepisoval to, co je již uloženo?
Tento komentář byl moderátorem webu minimalizován
milý Michaeli,
Chcete-li problém vyřešit, spusťte níže uvedený kód VBA.

Sub Saveaspdfandsend()
Dim xSht jako pracovní list
Dim xFileDlg jako FileDialog
Dim xFolder jako řetězec
Dim xYesorNo As Integer
Dim xOutlookObj jako objekt
Dim xEmailObj jako objekt
Dim xUsedRng As Range
Dim xStr jako řetězec

Nastavit xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

Pokud xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Jiný
MsgBox "Musíte zadat složku pro uložení PDF." & vbCrLf & vbCrLf & "Stiskněte OK pro ukončení tohoto makra.", vbCritical, "Musí zadat cílovou složku"
Konec Sub
End If
xStr = Format(Now(), "yyyy-mm-dd-hh-mm-ss")
xFolder = xFolder + "\" + xSht.Name + "-" + xStr + ".pdf"

'Zkontrolujte, zda soubor již existuje
Pokud Len(Dir(xFolder)) > 0 Pak
xYesorNo = MsgBox(xFolder & "již existuje." & vbCrLf & vbCrLf & "Chcete ji přepsat?", _
vbYesNo + vbQuestion, "Soubor existuje")
On Error Resume Next
Pokud xYesorNo = vbYes Then
Zabijte xFolder
Jiný
MsgBox "pokud nepřepíšete existující PDF, nemohu pokračovat." _
& vbCrLf & vbCrLf & "Stisknutím tlačítka OK ukončíte toto makro.", vbCritical, "Ukončení makra"
Konec Sub
End If
Pokud Err.Number <> 0 Pak
MsgBox "Nelze smazat existující soubor. Ujistěte se prosím, že soubor není otevřen nebo chráněn proti zápisu." _
& vbCrLf & vbCrLf & "Stiskněte OK pro ukončení tohoto makra.", vbCritical, "Nelze smazat soubor"
Konec Sub
End If
End If

Nastavit xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Uložit jako soubor PDF
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

„Vytvořte e-mail Outlook
Set xOutlookObj = CreateObject("Outlook.Application")
Nastavit xEmailObj = xOutlookObj.CreateItem(0)
S xEmailObj
.Zobrazit
.To = ""
.CC = ""
.Subject = xSht.Name + "-" + xStr + ".pdf"
.Přílohy.Přidat xFolder
Pokud DisplayEmail = False Then
'.Poslat
End If
Konec s
Jiný
MsgBox "Aktivní list nemůže být prázdný"
Konec Sub
End If
End Sub
Tento komentář byl moderátorem webu minimalizován
Ahoj Crystal,

Je to opravdu skvělé a funguje mi to perfektně. Potřebujete další pomoc k přidání:

1. v "To" chci dát odkaz na konkrétní buňku aktivního listu jako v CC a v BCC bych chtěl přidat odkaz na aktivní list
2. v těle e-mailu potřebuji zadat nějaký standardní text.

Budu vám plně k dispozici za vaši pomoc.

Díky
parag
Tento komentář byl moderátorem webu minimalizován
Ahoj Parag Somani,
Níže uvedený kód VBA vám může pomoci. Změňte prosím pole .To, .CC, .BCC a .Body podle svých potřeb.

Sub Saveaspdfandsend()
Dim xSht jako pracovní list
Dim xFileDlg jako FileDialog
Dim xFolder jako řetězec
Dim xYesorNo As Integer
Dim xOutlookObj jako objekt
Dim xEmailObj jako objekt
Dim xUsedRng As Range
Dim xStr jako řetězec

Nastavit xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

Pokud xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Jiný
MsgBox "Musíte zadat složku pro uložení PDF." & vbCrLf & vbCrLf & "Stiskněte OK pro ukončení tohoto makra.", vbCritical, "Musí zadat cílovou složku"
Konec Sub
End If
xStr = Format(Now(), "yyyy-mm-dd-hh-mm-ss")
xFolder = xFolder + "\" + xSht.Name + "-" + xStr + ".pdf"

'Zkontrolujte, zda soubor již existuje
Pokud Len(Dir(xFolder)) > 0 Pak
xYesorNo = MsgBox(xFolder & "již existuje." & vbCrLf & vbCrLf & "Chcete ji přepsat?", _
vbYesNo + vbQuestion, "Soubor existuje")
On Error Resume Next
Pokud xYesorNo = vbYes Then
Zabijte xFolder
Jiný
MsgBox "pokud nepřepíšete existující PDF, nemohu pokračovat." _
& vbCrLf & vbCrLf & "Stisknutím tlačítka OK ukončíte toto makro.", vbCritical, "Ukončení makra"
Konec Sub
End If
Pokud Err.Number <> 0 Pak
MsgBox "Nelze smazat existující soubor. Ujistěte se prosím, že soubor není otevřen nebo chráněn proti zápisu." _
& vbCrLf & vbCrLf & "Stiskněte OK pro ukončení tohoto makra.", vbCritical, "Nelze smazat soubor"
Konec Sub
End If
End If

Nastavit xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Uložit jako soubor PDF
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

„Vytvořte e-mail Outlook
Set xOutlookObj = CreateObject("Outlook.Application")
Nastavit xEmailObj = xOutlookObj.CreateItem(0)
S xEmailObj
.Zobrazit
.To = Range("A8")
.CC = Range("A9")
.BCC = Range("A10")
.Subject = xSht.Name + "-" + xStr + ".pdf"
.Body = "Vážený" _
& vbNewLine & vbNewLine & _
"Toto je testovací e-mail" & _
"odeslání v Excelu"
.Přílohy.Přidat xFolder
Pokud DisplayEmail = False Then
'.Poslat
End If
Konec s
Jiný
MsgBox "Aktivní list nemůže být prázdný"
Konec Sub
End If
End Sub
Tento komentář byl moderátorem webu minimalizován
Zkoušel jsem použít rozsah pro "Do", "CC", prostě to nezvedne hodnoty z určené buňky. Můžete mi s tím prosím pomoci?
Díky,
Mehul
Tento komentář byl moderátorem webu minimalizován
Ahoj Crystal,

Je to opravdu skvělé a funguje mi to perfektně. Potřebujete další pomoc k přidání:

1. v "To" chci dát odkaz na konkrétní buňku aktivního listu jako v CC a v BCC bych chtěl přidat odkaz na aktivní list
2. v těle e-mailu potřebuji zadat nějaký standardní text.

Budu vám plně k dispozici za vaši pomoc.

Díky
parag
Tento komentář byl moderátorem webu minimalizován
Ahoj Crystal,

Je to opravdu skvělé a funguje mi to perfektně. Potřebujete další pomoc k přidání:

1. v "To" chci dát odkaz na konkrétní buňku aktivního listu jako v CC a v BCC bych chtěl přidat odkaz na aktivní list
2. v těle e-mailu potřebuji zadat nějaký standardní text.

Budu vám plně k dispozici za vaši pomoc.

Díky
parag
Tento komentář byl moderátorem webu minimalizován
Jak mohu přidat například list 2 ze sešitu jako pdf?
Tento komentář byl moderátorem webu minimalizován
Ahoj Armine,
Nejprve musíte otevřít List 2 v sešitu a poté spustit kód VBA s výše uvedenými kroky, abyste jej dostali dolů.
Tento komentář byl moderátorem webu minimalizován
Jak bych upravil výše uvedený skript VBA, aby se název souboru uložil jako konkrétní buňka vybraná v aktuálním listu, například buňka A1?
Tento komentář byl moderátorem webu minimalizován
Ahoj Tome.
Promiň, s tím ti nepomůžu.
Vítejte, pokud chcete na našem fóru zveřejnit jakýkoli dotaz: https://www.extendoffice.com/forum.html
Získáte další podporu Excelu od profesionálů Excelu nebo jiných fanoušků Excelu.
Tento komentář byl moderátorem webu minimalizován
Ahoj, jak mohu uložit a odeslat pdf s názvem sešitu s aktuálním kódem VBA? co mám použít místo xSht.Name
Tento komentář byl moderátorem webu minimalizován
Ahoj James,
Chcete odeslat aktivní list jako pdf a pojmenovat jej jako název sešitu?
Tento komentář byl moderátorem webu minimalizován
Díky funguje to.
Tento komentář byl moderátorem webu minimalizován
Jak mohu provést odstranění uloženého pdf poté, co jej pošle e-mailem?
Tento komentář byl moderátorem webu minimalizován
Ahoj Jason,
S tím vám bohužel zatím nemohu pomoci. Po odeslání e-mailem jej musíte ručně smazat.
Tento komentář byl moderátorem webu minimalizován
Ahoj,

Je možné najít název pro pdf z buňky? Př. Buňka H4


A v buňce H4 chci, aby se to shromáždilo ze tří různých buněk. Je to možné?
Tento komentář byl moderátorem webu minimalizován
To je možné. Vytvořte samostatné proměnné pro uchování hodnoty z buněk a poté tyto proměnné použijte při nastavování xFolder.
Použil jsem hodnotu z buňky v mém listu plus dnešní datum. Můžete však snadno vytvořit více hodnot buněk.

Toto jsem přidal:
Dim xMemberName jako řetězec
Dim xFileDate jako řetězec

xMemberName = Rozsah("H3").Hodnota
xFileDate = Format(Nyní, "mm-dd")

xFolder = xFolder + "\" xMemberName + xFileDate + ".pdf"
Tento komentář byl moderátorem webu minimalizován
Když to zkusím, dostávám chybu, kam v kódu to mám umístit?
Tento komentář byl moderátorem webu minimalizován
Ahoj Crystal,



Je to opravdu skvělé a funguje mi to perfektně. Potřebujete další pomoc k přidání:

1. v "Tělo" chci dát odkaz na konkrétní buňku aktivního listu. Dále Chtěl bych text zvýraznit tučným písmem.

Díky

Pozdravy

Kishore Kumar
Tento komentář byl moderátorem webu minimalizován
Dobrý den,

Chcete automaticky přidat hodnotu buňky do těla pošty a označit ji tučně? Předpokládejme, že do těla pošty přidáte hodnotu C4. Použijte prosím níže uvedený kód.

Sub Saveaspdfandsend()

Dim xSht jako pracovní list

Dim xFileDlg jako FileDialog

Dim xFolder jako řetězec

Dim xYesorNo As Integer

Dim xOutlookObj jako objekt

Dim xEmailObj jako objekt

Dim xUsedRng As Range



Nastavit xSht = ActiveSheet

Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)



Pokud xFileDlg.Show = True Then

xFolder = xFileDlg.SelectedItems(1)

Jiný

MsgBox "Musíte zadat složku pro uložení PDF." & vbCrLf & vbCrLf & "Stiskněte OK pro ukončení tohoto makra.", vbCritical, "Musí zadat cílovou složku"

Konec Sub

End If

xFolder = xFolder + "\" + xSht.Name + ".pdf"



'Zkontrolujte, zda soubor již existuje

Pokud Len(Dir(xFolder)) > 0 Pak

xYesorNo = MsgBox(xFolder & "již existuje." & vbCrLf & vbCrLf & "Chcete ji přepsat?", _

vbYesNo + vbQuestion, "Soubor existuje")

On Error Resume Next

Pokud xYesorNo = vbYes Then

Zabijte xFolder

Jiný

MsgBox "pokud nepřepíšete existující PDF, nemohu pokračovat." _

& vbCrLf & vbCrLf & "Stisknutím tlačítka OK ukončíte toto makro.", vbCritical, "Ukončení makra"

Konec Sub

End If

Pokud Err.Number <> 0 Pak

MsgBox "Nelze smazat existující soubor. Ujistěte se prosím, že soubor není otevřen nebo chráněn proti zápisu." _

& vbCrLf & vbCrLf & "Stiskněte OK pro ukončení tohoto makra.", vbCritical, "Nelze smazat soubor"

Konec Sub

End If

End If



Nastavit xUsedRng = xSht.UsedRange

If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then

'Uložit jako soubor PDF

xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard



„Vytvořte e-mail Outlook

Set xOutlookObj = CreateObject("Outlook.Application")

Nastavit xEmailObj = xOutlookObj.CreateItem(0)

S xEmailObj

.Zobrazit

.To = ""

.CC = ""

.Subject = xSht.Name + ".pdf"

.Přílohy.Přidat xFolder

.HTMLBody = "
" & Rozsah("C4") & .HTMLBody

Pokud DisplayEmail = False Then

'.Poslat

End If

Konec s

Jiný

MsgBox "Aktivní list nemůže být prázdný"

Konec Sub

End If

End Sub
Tento komentář byl moderátorem webu minimalizován
Pokud bych chtěl, aby se pokaždé automaticky ukládalo do konkrétní složky (vylučuje nutnost, aby si uživatel složku vybral), jak bych to udělal?
Př. C: Faktury/Severní Amerika/Klienti
Pomoc je velmi ceněn.
Tento komentář byl moderátorem webu minimalizován
Ahoj Geoff,
Máte na mysli uložit list jako soubor pdf a uložit do konkrétní složky bez odeslání?
Tento komentář byl moderátorem webu minimalizován
Myslím, že Geoff znamená možnost určit konkrétní složku v kódu, do které se pdf pokaždé uloží, místo toho, abyste museli ručně vybírat umístění. Soubor pdf je poté odeslán e-mailem z této konkrétní složky.
Tento komentář byl moderátorem webu minimalizován
Děkuji Jeremy.
Tento komentář byl moderátorem webu minimalizován
Ahoj Geoffe, pokud chcete automaticky uložit soubor PDF do konkrétní složky místo ručního výběru umístění, zkuste níže uvedený kód. Nezapomeňte změnit cestu ke složce v kódu.
Sub SaveAsPDFandSend()
Dim xSht jako pracovní list
Dim xFileDlg jako FileDialog
Dim xFolder jako řetězec
Dim xYesorNo As Integer
Dim xOutlookObj jako objekt
Dim xEmailObj jako objekt
Dim xUsedRng As Range
Dim xPath As String
Nastavit xSht = ActiveSheet
xPath = "C:\Users\Win10x64Test\Desktop\worksheet do pdf" 'zde "pracovní list do pdf" je cílová složka pro uložení souborů PDF
xFolder = xPath + "\" + xSht.Name + ".pdf"
Pokud Len(Dir(xFolder)) > 0 Pak
xYesorNo = MsgBox(xFolder & "již existuje." & vbCrLf & vbCrLf & "Chcete ji přepsat?", _
vbYesNo + vbQuestion, "Soubor existuje")
On Error Resume Next
Pokud xYesorNo = vbYes Then
Zabijte xFolder
Jiný
MsgBox "pokud nepřepíšete existující PDF, nemohu pokračovat." _
& vbCrLf & vbCrLf & "Stisknutím tlačítka OK ukončíte toto makro.", vbCritical, "Ukončení makra"
Konec Sub
End If
Pokud Err.Number <> 0 Pak
MsgBox "Nelze smazat existující soubor. Ujistěte se prosím, že soubor není otevřen nebo chráněn proti zápisu." _
& vbCrLf & vbCrLf & "Stiskněte OK pro ukončení tohoto makra.", vbCritical, "Nelze smazat soubor"
Konec Sub
End If
End If

Nastavit xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Uložit jako soubor PDF
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

„Vytvořte e-mail Outlook
Set xOutlookObj = CreateObject("Outlook.Application")
Nastavit xEmailObj = xOutlookObj.CreateItem(0)
S xEmailObj
.Zobrazit
.To = ""
.CC = ""
.Subject = xSht.Name + ".pdf"
.Přílohy.Přidat xFolder
Pokud DisplayEmail = False Then
'.Poslat
End If
Konec s
Jiný
MsgBox "Aktivní list nemůže být prázdný"
Konec Sub
End If
End Sub
Tento komentář byl moderátorem webu minimalizován
Tento kód funguje skvěle, kromě toho, že chci mít list uložený jako název listu + datum (tj. List1 1. října 2020); na ploše uživatele (toto bude používat více lidí a jejich cesty se mohou mírně lišit). Pokud je to možné, chci do těla vložit také .jpg. JPG je umístěn uvnitř listu (mimo oblast tisku) a obrázek je uložen na sdíleném serveru.. i když cesta k serveru se liší podle uživatel (pro většinu je to jednotka „T“ pro některé jednotka „U“)
dá se to udělat? prosím a děkuji milionkrát.
Tento komentář byl moderátorem webu minimalizován

Ahoj, funguje to skvěle, děkuji za sdílení, potřebuji jen jednu pomoc.
Pokud chci uložit soubor PDF s přizpůsobeným názvem (možnost zadat název souboru v dialogovém okně Uložit jako), jako uživatel použije tuto možnost v šabloně formuláře, kde se formuláře ukládají jako PDF s jedinečným názvem.
Tento komentář byl moderátorem webu minimalizován
Dobrý den, zkuste níže uvedený kód VBA. Po spuštění kódu vyberte složku pro uložení souboru PDF, poté se zobrazí dialogové okno, ve kterém zadáte název souboru. Sub Saveaspdfandsend()
'Aktualizováno Extendoffice 20210209
Dim xSht jako pracovní list
Dim xFileDlg jako FileDialog
Dim xFolder jako řetězec
Dim xYesorNo As Integer
Dim xOutlookObj jako objekt
Dim xEmailObj jako objekt
Dim xUsedRng As Range
Dim xStrName jako řetězec
Dim xV jako varianta

Nastavit xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

Pokud xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Jiný
MsgBox "Musíte zadat složku pro uložení PDF." & vbCrLf & vbCrLf & "Stiskněte OK pro ukončení tohoto makra.", vbCritical, "Musí zadat cílovou složku"
Konec Sub
End If
xStrName = ""
xV = Application.InputBox("Zadejte prosím název souboru:", "Kutools pro Excel", , , , , , 2)
Pokud xV = False Pak
Konec Sub
End If
xStrName = xV
If xStrName = "" Pak
MsgBox ("Není zadán žádný název souboru, ukončování procesu!")
Konec Sub
End If

xFolder = xFolder + "\" + xStrName + ".pdf"
'Zkontrolujte, zda soubor již existuje
Pokud Len(Dir(xFolder)) > 0 Pak
xYesorNo = MsgBox(xFolder & "již existuje." & vbCrLf & vbCrLf & "Chcete ji přepsat?", _
vbYesNo + vbQuestion, "Soubor existuje")
On Error Resume Next
Pokud xYesorNo = vbYes Then
Zabijte xFolder
Jiný
MsgBox "pokud nepřepíšete existující PDF, nemohu pokračovat." _
& vbCrLf & vbCrLf & "Stisknutím tlačítka OK ukončíte toto makro.", vbCritical, "Ukončení makra"
Konec Sub
End If
Pokud Err.Number <> 0 Pak
MsgBox "Nelze smazat existující soubor. Ujistěte se prosím, že soubor není otevřen nebo chráněn proti zápisu." _
& vbCrLf & vbCrLf & "Stiskněte OK pro ukončení tohoto makra.", vbCritical, "Nelze smazat soubor"
Konec Sub
End If
End If

Nastavit xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Uložit jako soubor PDF
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

„Vytvořte e-mail Outlook
Set xOutlookObj = CreateObject("Outlook.Application")
Nastavit xEmailObj = xOutlookObj.CreateItem(0)
S xEmailObj
.Zobrazit
.To = ""
.CC = ""
.Subject = xSht.Name + ".pdf"
.Přílohy.Přidat xFolder
Pokud DisplayEmail = False Then
'.Poslat
End If
Konec s
Jiný
MsgBox "Aktivní list nemůže být prázdný"
Konec Sub
End If
End Sub
Tento komentář byl moderátorem webu minimalizován
Dobrý den,
Pokud mám v souboru dva listy a chtěl bych spustit toto makro na jednom listu (stisknutím tlačítka), ale odeslat další, jak ho mohu získat?
Tento komentář byl moderátorem webu minimalizován
Dobrý den, chtěl bych to uložit do určitého umístění souboru s názvem podle hodnoty v buňce C30. Vyzkoušel jsem několik možností, ale stále se objevují chyby.
Tento komentář byl moderátorem webu minimalizován
Ahoj hein, níže uvedený kód může pomoci. Po spuštění kódu vyberte určitou složku pro uložení souboru PDF, poté se zobrazí dialogové okno pro zadání názvu souboru. Sub Saveaspdfandsend()
'Aktualizováno Extendoffice 20210209
Dim xSht jako pracovní list
Dim xFileDlg jako FileDialog
Dim xFolder jako řetězec
Dim xYesorNo As Integer
Dim xOutlookObj jako objekt
Dim xEmailObj jako objekt
Dim xUsedRng As Range
Dim xStrName jako řetězec
Dim xV jako varianta

Nastavit xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

Pokud xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Jiný
MsgBox "Musíte zadat složku pro uložení PDF." & vbCrLf & vbCrLf & "Stiskněte OK pro ukončení tohoto makra.", vbCritical, "Musí zadat cílovou složku"
Konec Sub
End If
xStrName = ""
xV = Application.InputBox("Zadejte prosím název souboru:", "Kutools pro Excel", , , , , , 2)
Pokud xV = False Pak
Konec Sub
End If
xStrName = xV
If xStrName = "" Pak
MsgBox ("Není zadán žádný název souboru, ukončování procesu!")
Konec Sub
End If

xFolder = xFolder + "\" + xStrName + ".pdf"
'Zkontrolujte, zda soubor již existuje
Pokud Len(Dir(xFolder)) > 0 Pak
xYesorNo = MsgBox(xFolder & "již existuje." & vbCrLf & vbCrLf & "Chcete ji přepsat?", _
vbYesNo + vbQuestion, "Soubor existuje")
On Error Resume Next
Pokud xYesorNo = vbYes Then
Zabijte xFolder
Jiný
MsgBox "pokud nepřepíšete existující PDF, nemohu pokračovat." _
& vbCrLf & vbCrLf & "Stisknutím tlačítka OK ukončíte toto makro.", vbCritical, "Ukončení makra"
Konec Sub
End If
Pokud Err.Number <> 0 Pak
MsgBox "Nelze smazat existující soubor. Ujistěte se prosím, že soubor není otevřen nebo chráněn proti zápisu." _
& vbCrLf & vbCrLf & "Stiskněte OK pro ukončení tohoto makra.", vbCritical, "Nelze smazat soubor"
Konec Sub
End If
End If

Nastavit xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Uložit jako soubor PDF
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

„Vytvořte e-mail Outlook
Set xOutlookObj = CreateObject("Outlook.Application")
Nastavit xEmailObj = xOutlookObj.CreateItem(0)
S xEmailObj
.Zobrazit
.To = ""
.CC = ""
.Subject = xSht.Name + ".pdf"
.Přílohy.Přidat xFolder
Pokud DisplayEmail = False Then
'.Poslat
End If
Konec s
Jiný
MsgBox "Aktivní list nemůže být prázdný"
Konec Sub
End If
End Sub
Tento komentář byl moderátorem webu minimalizován
Díky za to, to je skvělé, ale chci, aby byl list pojmenován podle buňky A1 na listu 1. místo pro uložení jako podle A1 na listu 2, například C:\Users\peete\Dropbox\Screenshots a odeslat e-mailem na adresu e-mailovou adresu na listu A3 2, co jsem již vypracoval.
Tento komentář byl moderátorem webu minimalizován
Díky za to, to je skvělé, ale chci, aby byl list pojmenován podle buňky A1 na listu 1. místo pro uložení jako podle A1 na listu 2, například C:\Users\peete\Dropbox\Screenshots, ale může se změnit, když pomocí souboru a e-mailem odeslat na e-mailovou adresu na list A3 2, co jsem již vypracoval.
Tento komentář byl moderátorem webu minimalizován
Hi krystal , vynikající kód díky za sdílení. Existuje způsob, jak vybrat více listů (ze stejného sešitu), uložit každý jako samostatné PDF a poté je všechny odeslat jako přílohu v jednom e-mailu?
Tento komentář byl moderátorem webu minimalizován
Ahoj, níže uvedený kód VBA vám může udělat laskavost, zkuste to prosím. Ve dvanáctém řádku kódu nahraďte názvy listů skutečnými názvy listů ve vašem případě.
Sub Saveaspdfandsend1()
Dim xSht jako pracovní list
Dim xFileDlg jako FileDialog
Dim xFolder jako řetězec
Dim xYesorNo, I, xNum As Integer
Dim xOutlookObj jako objekt
Dim xEmailObj jako objekt
Dim xUsedRng As Range
Dim xArrShetts jako varianta
Dim xPDFNameAddress jako řetězec
Dim xStr jako řetězec
xArrShetts = Array("test", "List1", "List2") 'Zadejte názvy listů, které odešlete jako soubory PDF, uzavřené v uvozovkách a oddělte je čárkou. Ujistěte se, že v názvu souboru nejsou žádné speciální znaky, například \/:"*<>|.

Pro I = 0 až UBound(xArrShetts)
On Error Resume Next
Nastavit xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Sešit nenalezen, operace ukončení:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools pro Excel"
Konec Sub
End If
další


Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Pokud xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Jiný
MsgBox "Musíte zadat složku pro uložení PDF." & vbCrLf & vbCrLf & "Stiskněte OK pro ukončení tohoto makra.", vbCritical, "Musí zadat cílovou složku"
Konec Sub
End If
'Zkontrolujte, zda soubor již existuje
xYesorNo = MsgBox("Pokud v cílové složce existují soubory se stejným názvem, bude k názvu souboru automaticky přidána číselná přípona, aby se rozlišily duplikáty" & vbCrLf & vbCrLf & "Kliknutím na Ano pokračujte, kliknutím na Ne zrušte", _
vbYesNo + vbQuestion, "Soubor existuje")
Pokud xYesorNo <> vbYes Then Exit Sub
Pro I = 0 až UBound(xArrShetts)
Nastavit xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))

xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
Zatímco ne (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
platit
Nastavit xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
xSht.ExportAsFixedFormat Typ:=xlTypePDF, Název souboru:=xStr, Kvalita:=xlQualityStandard
Jiný

End If
xArrShetts(I) = xStr
další

„Vytvořte e-mail Outlook
Set xOutlookObj = CreateObject("Outlook.Application")
Nastavit xEmailObj = xOutlookObj.CreateItem(0)
S xEmailObj
.Zobrazit
.To = ""
.CC = ""
.Předmět = "????"
Pro I = 0 až UBound(xArrShetts)
.Attachments.Add xArrShetts(I)
další
Pokud DisplayEmail = False Then
'.Poslat
End If
Konec s
End Sub
Tento komentář byl moderátorem webu minimalizován
Ahoj, jedna změna, se kterou se potýkám, je vytvořit samostatný e-mail pro každý vytvořený dokument PDF.
Tento komentář byl moderátorem webu minimalizován
Ahoj, Chcete-li vytvořit samostatný e-mail pro každý dokument PDF, můžete ručně spustit VBA uvedený v příspěvku v různých listech, abyste to udělali.
Tento komentář byl moderátorem webu minimalizován
V sešitu mám více než 100 listů, což pak znamená, že musím VBA spustit více než 100krát, což je časově náročné.  
Podařilo se mi rozdělit svůj sešit na více listů a pak jsem schopen převést každý list na samostatný dokument PDF.
Řešením, které hledám, je poslat e-mailem každý dokument PDF samostatně, zatímco výše uvedený proces běží.
Zde VBA, kterou aktuálně používám:
Sub Saveaspdfandsend1()
Dim xSht jako pracovní list
Dim xFileDlg jako FileDialog
Dim xFolder jako řetězec
Dim xYesorNo, I, xNum As Integer
Dim xOutlookObj jako objekt
Dim xEmailObj jako objekt
Dim xUsedRng As Range
Dim xArrShetts jako varianta
Dim xPDFNameAddress jako řetězec
Dim xStr jako řetězec
xArrShetts = Array("02302257", "02400438", "02401829", "02403995", "02408001", "02409208", _
"02409980", "02411881", "02424178", "02430454", "02444046", "02448950", "02450600", _
"02459861", "02461750", "02467535", "02480484", "02484749", "02502041", "02504807", _
"02511843", "02515193", "02523098", "02523244", "02524036", "02524548", "02525516", "02525703", "02525898", "02528908", "02528950", "XNUMX", "XNUMX"
"02530381", "02531018", "02531252", "02531277", "02532571", "02533053", "02533474", _
"02534176", "02534592", "02534626", "02535343", "02536386", "02536921", "02537544", _
"02537607", "02538015", "02538755", "02538836", "02538910", "02539685", "02540063", "02540139", "02540158", "02541607", "02542344", "XNUMX", "XNUMX"
"02543763", "02543985", "02544116", "02544748", "02544762", "02545026", "02545048", _
"02545080", "02545447", "02545730", "02545814", "02546477", "02547458", "02547673", _
"02547833", "02547912", "02547950", "02547991", "02548848", "02549103", "02549116", "02549125", "02549132", "02549140", "02549182", "XNUMX", "XNUMX"
"02549462", "02549499", "02549565", "02549687", "02550049", "02550437", "02550812", _
"02550982", "02551004", "02551005", "02551045", "02552099", "02552222", "02552561", _
"02552684", "02552815", "02552892", "02553031", "02553186", "02553628", "02553721", "02555186", "02556934", "02557137", "02557393", "XNUMX", "XNUMX"
"02559121", "02559392", "02559419", "02559512", "02559802", "02559868", "02560052", _
"02560612", "02560684", "02560920", "02561018", "02561061", "02561092", "02561227", _
"02561349", "02561592", "02561630", "02561673", "02561880", "02562359", "02562920", "02562934", "02563013", "02563119", "02563133", "XNUMX", "XNUMX"
"02563445", "02563737", "02563828", "02563852", "02563861", "02563971", "02564042", _
"02564315", "02564366", "02564832", "02564909", "02565059", "02565205") "Zadejte názvy listů, které odešlete jako soubory PDF, uzavřené uvozovkami a oddělte je čárkou. Ujistěte se, že v názvu souboru nejsou žádné speciální znaky, například \/:"*<>|.

Pro I = 0 až UBound(xArrShetts)
On Error Resume Next
Nastavit xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Sešit nenalezen, operace ukončení:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools pro Excel"
Konec Sub
End If
další


Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Pokud xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Jiný
MsgBox "Musíte zadat složku pro uložení PDF." & vbCrLf & vbCrLf & "Stiskněte OK pro ukončení tohoto makra.", vbCritical, "Musí zadat cílovou složku"
Konec Sub
End If
'Zkontrolujte, zda soubor již existuje
xYesorNo = MsgBox("Pokud v cílové složce existují soubory se stejným názvem, bude k názvu souboru automaticky přidána číselná přípona, aby se rozlišily duplikáty" & vbCrLf & vbCrLf & "Kliknutím na Ano pokračujte, kliknutím na Ne zrušte", _
vbYesNo + vbQuestion, "Soubor existuje")
Pokud xYesorNo <> vbYes Then Exit Sub
Pro I = 0 až UBound(xArrShetts)
Nastavit xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))

xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
Zatímco ne (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
platit
Nastavit xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
xSht.ExportAsFixedFormat Typ:=xlTypePDF, Název souboru:=xStr, Kvalita:=xlQualityStandard
Jiný

End If
xArrShetts(I) = xStr
další

„Vytvořte e-mail Outlook
Set xOutlookObj = CreateObject("Outlook.Application")
Nastavit xEmailObj = xOutlookObj.CreateItem(0)
S xEmailObj
.Zobrazit
.To = "Ctracklegal@ctrack.com"
.CC = ""
.Předmět = "????"
Pro I = 0 až UBound(xArrShetts)
On Error Resume Next
.Attachments.Add xArrShetts(I)
další
Pokud DisplayEmail = False Then
.Poslat
Konec Sub
End If
Konec s


End Sub
Tento komentář byl moderátorem webu minimalizován
Ahoj @crystal
To je skvělé – klíčovou věcí, se kterou se potýkám, je název souboru – chtěl bych, aby se název souboru vytahoval z buňky v listu místo použití názvu karty. Kód jsem již upravil, aby se automaticky uložil do určené složky, ale potýkám se s názvem souboru.
Můžete prosím nabídnout nějakou pomoc?
Tento komentář byl moderátorem webu minimalizován
Ahoj Tori, pokud chcete soubor PDF pojmenovat konkrétní hodnotou buňky, zkuste prosím následující kód. Po spuštění kódu a výběru složky pro uložení souboru se objeví další dialogové okno, vyberte buňku, kterou budete používat hodnotu jako název souboru PDF a poté klepněte na OK pro dokončení.
Sub Saveaspdfandsend2()
'Aktualizováno Extendoffice 20210521
Dim xSht jako pracovní list
Dim xFileDlg jako FileDialog
Dim xFolder jako řetězec
Dim xYesorNo As Integer
Dim xOutlookObj jako objekt
Dim xEmailObj jako objekt
Dim xUsedRng, xRgInser As Range
Dim xB jako Boolean
Nastavit xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

Pokud xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Jiný
MsgBox "Musíte zadat složku pro uložení PDF." & vbCrLf & vbCrLf & "Stiskněte OK pro ukončení tohoto makra.", vbCritical, "Musí zadat cílovou složku"
Konec Sub
End If
xB = pravda
On Error Resume Next
Zatímco xB
Nastavte xRgInser = Nic
Set xRgInser = Application.InputBox("Vyberte buňku, kterou použijete hodnotu k pojmenování souboru PDF:", "Kutools pro Excel", , , , , , 8)
Pokud xRgInser není nic, pak
MsgBox "Nebyla vybrána žádná buňka, ukončete operaci!", vbInformation, "Kutools pro Excel"
Konec Sub
End If
If xRgInser.Text = "" Pak
MsgBox " Vybraná buňka je prázdná, vyberte prosím znovu!", vbInformation, "Kutools pro Excel"
Jiný
xB = False
End If
platit

xFolder = xFolder + "\" + xRgInser.Text + ".pdf"

'Zkontrolujte, zda soubor již existuje
Pokud Len(Dir(xFolder)) > 0 Pak
xYesorNo = MsgBox(xFolder & "již existuje." & vbCrLf & vbCrLf & "Chcete ji přepsat?", _
vbYesNo + vbQuestion, "Soubor existuje")
On Error Resume Next
Pokud xYesorNo = vbYes Then
Zabijte xFolder
Jiný
MsgBox "pokud nepřepíšete existující PDF, nemohu pokračovat." _
& vbCrLf & vbCrLf & "Stisknutím tlačítka OK ukončíte toto makro.", vbCritical, "Ukončení makra"
Konec Sub
End If
Pokud Err.Number <> 0 Pak
MsgBox "Nelze smazat existující soubor. Ujistěte se prosím, že soubor není otevřen nebo chráněn proti zápisu." _
& vbCrLf & vbCrLf & "Stiskněte OK pro ukončení tohoto makra.", vbCritical, "Nelze smazat soubor"
Konec Sub
End If
End If

Nastavit xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Uložit jako soubor PDF
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

„Vytvořte e-mail Outlook
Set xOutlookObj = CreateObject("Outlook.Application")
Nastavit xEmailObj = xOutlookObj.CreateItem(0)
S xEmailObj
.Zobrazit
.To = ""
.CC = ""
.Subject = xSht.Name + ".pdf"
.Přílohy.Přidat xFolder
Pokud DisplayEmail = False Then
'.Poslat
End If
Konec s
Jiný
MsgBox "Aktivní list nemůže být prázdný"
Konec Sub
End If
End Sub
Tento komentář byl moderátorem webu minimalizován
Ahoj, potřeboval jsem něco podobného, ​​takže tady je to, co jsem dostal. Vezme aktuální datum a vytvoří novou složku s názvem data v konkrétním umístění. Umístí soubor pdf do tohoto nového umístění a připojí pdf k novému e-mailu. Funguje jako pamlsek. Jsem jen začátečník, takže mě prosím omluvte, pokud to vypadá jako nepořádek. :D
Sub PDFTOEMAIL()
Dim xSht jako pracovní list
Dim xFileDlg jako FileDialog
Dim xFolder jako řetězec
Dim xYesorNo As Integer
Dim xOutlookObj jako objekt
Dim xEmailObj jako objekt
Dim xUsedRng As Range
Dim xPath As String
Dim xOutMsg jako řetězec
Dim sFolderName jako řetězec, sFolder jako řetězec
Dim sFolderPath jako řetězec

Nastavit xSht = ActiveSheet
xFileDate = Format(Nyní, "dd-mm-yyyy")
sFolder = "C:" 'zde máte hlavní složku
sFolderName = "Week ending" + Format(Now, "dd-mm-yyyy") 'složka, která má být vytvořena v hlavní složce s názvem Konec týdne a aktuálním datem
sFolderPath = "C:" & sFolderName 'hlavní složka znovu pro vytvoření nové cesty včetně nové složky
Set oFSO = CreateObject("Scripting.FileSystemObject")
If oFSO.FolderExists(sFolderPath) Then
MsgBox "Složka již existuje!" & vbCrLf & vbCrLf & sFolderPath, vbInformation, "INFO"
Jiný
MkDir sFolderPath
MsgBox "Byla vytvořena nová složka!" & vbCrLf & vbCrLf & sFolderPath, vbInformation, "INFO"
End If
xPath = sFolderPath
xFolder = xPath + "\" + xSht.Name + "_" + xFileDate + ".pdf"
Pokud Len(Dir(xFolder)) > 0 Pak
xYesorNo = MsgBox(xFolder & "již existuje." & vbCrLf & vbCrLf & "Chcete ji přepsat?", _
vbYesNo + vbQuestion, "Soubor existuje")
On Error Resume Next
Pokud xYesorNo = vbYes Then
Zabijte xFolder
Jiný
MsgBox "pokud nepřepíšete existující PDF, nemohu pokračovat." _
& vbCrLf & vbCrLf & "Stisknutím tlačítka OK ukončíte toto makro.", vbCritical, "Ukončení makra"
Konec Sub
End If
Pokud Err.Number <> 0 Pak
MsgBox "Nelze smazat existující soubor. Ujistěte se prosím, že soubor není otevřen nebo chráněn proti zápisu." _
& vbCrLf & vbCrLf & "Stiskněte OK pro ukončení tohoto makra.", vbCritical, "Nelze smazat soubor"
Konec Sub
End If
End If

Nastavit xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
Set xOutlookObj = CreateObject("Outlook.Application")
Nastavit xEmailObj = xOutlookObj.CreateItem(0)
xOutMsg = " Naleznete v příloze Tento e-mail a příloha byly vygenerovány automaticky "
'přidává poznámku, že e-mail byl vygenerován automaticky

S xEmailObj
.Zobrazit
.To = "" 'přidejte své vlastní e-maily
.CC = ""
.Subject = xSht.Name + " PDF pro týden končící " + xFileDate + " - Location " ' předmět obsahuje název listu, pdf, datum a umístění, toto lze upravit podle potřeby
.Přílohy.Přidat xFolder
.HTMLBody = xOutMsg & .HTMLBody
Pokud DisplayEmail = False Then
'.Send <--- Zde, pokud smažete apostrof, bude e-mail odeslán automaticky, takže buďte opatrní
End If
Konec s
Jiný
MsgBox "Aktivní list nemůže být prázdný"
Konec Sub
End If
End Sub
Tento komentář byl moderátorem webu minimalizován
Jak upravím tento kód tak, aby se ukládaly pouze buňky ("a1:r99"), které se mají uložit jako PDF. Na stranách mám další věci, které v dokumentu PDF nechci.
Sub Saveaspdfandsend()
'Aktualizováno Extendoffice 20210209
Dim xSht jako pracovní list
Dim xFileDlg jako FileDialog
Dim xFolder jako řetězec
Dim xYesorNo As Integer
Dim xOutlookObj jako objekt
Dim xEmailObj jako objekt
Dim xUsedRng As Range
Dim xStrName jako řetězec
Dim xV jako varianta

Nastavit xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

Pokud xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Jiný
MsgBox "Musíte zadat složku pro uložení PDF." & vbCrLf & vbCrLf & "Stiskněte OK pro ukončení tohoto makra.", vbCritical, "Musí zadat cílovou složku"
Konec Sub
End If
xStrName = ""
xV = Application.InputBox("Zadejte prosím název souboru:", "Kutools pro Excel", , , , , , 2)
Pokud xV = False Pak
Konec Sub
End If
xStrName = xV
If xStrName = "" Pak
MsgBox ("Není zadán žádný název souboru, ukončování procesu!")
Konec Sub
End If

xFolder = xFolder + "\" + xStrName + ".pdf"
'Zkontrolujte, zda soubor již existuje
Pokud Len(Dir(xFolder)) > 0 Pak
xYesorNo = MsgBox(xFolder & "již existuje." & vbCrLf & vbCrLf & "Chcete ji přepsat?", _
vbYesNo + vbQuestion, "Soubor existuje")
On Error Resume Next
Pokud xYesorNo = vbYes Then
Zabijte xFolder
Jiný
MsgBox "pokud nepřepíšete existující PDF, nemohu pokračovat." _
& vbCrLf & vbCrLf & "Stisknutím tlačítka OK ukončíte toto makro.", vbCritical, "Ukončení makra"
Konec Sub
End If
Pokud Err.Number <> 0 Pak
MsgBox "Nelze smazat existující soubor. Ujistěte se prosím, že soubor není otevřen nebo chráněn proti zápisu." _
& vbCrLf & vbCrLf & "Stiskněte OK pro ukončení tohoto makra.", vbCritical, "Nelze smazat soubor"
Konec Sub
End If
End If

Nastavit xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Uložit jako soubor PDF
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

„Vytvořte e-mail Outlook
Set xOutlookObj = CreateObject("Outlook.Application")
Nastavit xEmailObj = xOutlookObj.CreateItem(0)
S xEmailObj
.Zobrazit
.To = ""
.CC = ""
.Subject = xSht.Name + ".pdf"
.Přílohy.Přidat xFolder
Pokud DisplayEmail = False Then
'.Poslat
End If
Konec s
Jiný
MsgBox "Aktivní list nemůže být prázdný"
Konec Sub
End If
End Sub
Tento komentář byl moderátorem webu minimalizován
Dobrý den, právě jsem vyzkoušel tento kód na jednom ze svých pracovních listů a mám nastavené oblasti tisku, takže další věci dole se v pdf neobjevily. Zkus to!
Tento komentář byl moderátorem webu minimalizován
Hi
Mnohokrát děkuji za kód, ale je možné uložit PDF automaticky do stejného umístění jako aktivní soubor Excel a se stejným názvem souboru jako aktivní soubor Excel?
Mnohokrát děkuji.
tyč
Zatím zde nejsou žádné komentáře
Načíst další
Zanechat své připomínky
Odesílání jako host
×
Ohodnoťte tento příspěvek:
0   Postavy
Doporučená umístění