Kuinka muuntaa tai tallentaa sähköpostit ja liitteet yhdeksi PDF-tiedostoksi Outlookissa?
Tämä artikkeli käsittelee sähköpostiviestin ja kaikkien sen liitteiden tallentamista yhdeksi PDF-tiedostoksi Outlookissa.
Muunna tai tallenna sähköposti ja liitteet yhdeksi PDF-tiedostoksi VBA-koodilla
Muunna tai tallenna sähköposti ja liitteet yhdeksi PDF-tiedostoksi VBA-koodilla
Toimi seuraavasti tallentaaksesi sähköpostin kaikki liitteineen yhdeksi PDF-tiedostoksi Outlookissa.
1. Valitse sähköposti liitteineen, jotka tallennat yhdeksi PDF-tiedostoksi, ja paina sitten muut + F11 avaimet avaamaan Microsoft Visual Basic for Applications ikkunassa.
2. Vuonna Microsoft Visual Basic for Applications -ikkunassa liite > Moduulit. Kopioi sitten alla oleva VBA-koodi moduuliikkunaan.
VBA-koodi: Tallenna sähköposti ja liitteet yhdeksi PDF-tiedostoksi
Public Sub MergeMailAndAttachsToPDF()
'Update by Extendoffice 2018/3/5
Dim xSelMails As MailItem
Dim xFSysObj As FileSystemObject
Dim xOverwriteBln As Boolean
Dim xLooper As Integer
Dim xEntryID As String
Dim xNameSpace As Outlook.NameSpace
Dim xMail As Outlook.MailItem
Dim xExt As String
Dim xSendEmailAddr, xCompanyDomain As String
Dim xWdApp As Word.Application
Dim xDoc, xNewDoc As Word.Document
Dim I As Integer
Dim xPDFSavePath As String
Dim xPath As String
Dim xFileArr() As String
Dim xExcel As Excel.Application
Dim xWb As Workbook
Dim xWs As Worksheet
Dim xTempDoc As Word.Document
On Error Resume Next
If (Outlook.ActiveExplorer.Selection.Count > 1) Or (Outlook.ActiveExplorer.Selection.Count = 0) Then
MsgBox "Please Select a email.", vbInformation + vbOKOnly
Exit Sub
End If
Set xSelMails = Outlook.ActiveExplorer.Selection.Item(1)
xEntryID = xSelMails.EntryID
Set xNameSpace = Application.GetNamespace("MAPI")
Set xMail = xNameSpace.GetItemFromID(xEntryID)
xSendEmailAddr = xMail.SenderEmailAddress
xCompanyDomain = Right(xSendEmailAddr, Len(xSendEmailAddr) - InStr(xSendEmailAddr, "@"))
xOverwriteBln = False
Set xExcel = New Excel.Application
xExcel.Visible = False
Set xWdApp = New Word.Application
xExcel.DisplayAlerts = False
xPDFSavePath = xExcel.Application.GetSaveAsFilename(InitialFileName:="", FileFilter:="PDF Files(*.pdf),*.pdf")
If xPDFSavePath = "False" Then
xExcel.DisplayAlerts = True
xExcel.Quit
xWdApp.Quit
Exit Sub
End If
xPath = Left(xPDFSavePath, InStrRev(xPDFSavePath, "\"))
cPath = xPath & xCompanyDomain & "\"
yPath = cPath & Format(Now(), "yyyy") & "\"
mPath = yPath & Format(Now(), "MMMM") & "\"
If Dir(xPath, vbDirectory) = vbNullString Then
MkDir xPath
End If
EmailSubject = CleanFileName(xMail.Subject)
xSaveName = Format(xMail.ReceivedTime, "yyyymmdd") & "_" & EmailSubject & ".doc"
Set xFSysObj = CreateObject("Scripting.FileSystemObject")
If xOverwriteBln = False Then
xLooper = 0
Do While xFSysObj.FileExists(yPath & xSaveName)
xLooper = xLooper + 1
xSaveName = Format(xMail.ReceivedTime, "yyyymmdd") & "_" & EmailSubject & "_" & xLooper & ".doc"
Loop
Else
If xFSysObj.FileExists(yPath & xSaveName) Then
xFSysObj.DeleteFile yPath & xSaveName
End If
End If
xMail.SaveAs xPath & xSaveName, olDoc
If xMail.Attachments.Count > 0 Then
For Each atmt In xMail.Attachments
xExt = SplitPath(atmt.filename, 2)
If (xExt = ".docx") Or (xExt = ".doc") Or (xExt = ".docm") Or (xExt = ".dot") Or (xExt = ".dotm") Or (xExt = ".dotx") _
Or (xExt = ".xlsx") Or (xExt = ".xls") Or (xExt = ".xlsm") Or (xExt = ".xlt") Or (xExt = ".xltm") Or (xExt = ".xltx") Then
atmtName = CleanFileName(atmt.filename)
atmtSave = xPath & Format(xMail.ReceivedTime, "yyyymmdd") & "_" & atmtName
atmt.SaveAsFile atmtSave
End If
Next
End If
Set xNewDoc = xWdApp.Documents.Add("Normal", False, wdNewBlankDocument, False)
Set xFilesFld = xFSysObj.GetFolder(xPath)
xFileArr() = GetFiles(xPath)
For I = 0 To UBound(xFileArr()) - 1
xExt = SplitPath(xFileArr(I), 2)
If (xExt = ".xlsx") Or (xExt = ".xls") Or (xExt = ".xlsm") Or (xExt = ".xlt") Or _
(xExt = ".xltm") Or (xExt = ".xltx") Then 'conver excel to word
Set xWb = xExcel.Workbooks.Open(xPath & xFileArr(I))
Set xTempDoc = xWdApp.Documents.Add("Normal", False, wdNewBlankDocument, False)
Set xWs = xWb.ActiveSheet
xWs.UsedRange.Copy
xTempDoc.Content.PasteAndFormat wdFormatOriginalFormatting
xTempDoc.SaveAs2 xPath & xWs.Name + ".docx", wdFormatXMLDocument
xWb.Close False
Kill xPath & xFileArr(I)
xTempDoc.Close wdDoNotSaveChanges, wdOriginalDocumentFormat, False
End If
Next
xExcel.DisplayAlerts = True
xExcel.Quit
xFileArr() = GetFiles(xPath)
'Merge Documents
For I = 0 To UBound(xFileArr()) - 1
xExt = SplitPath(xFileArr(I), 2)
If (xExt = ".docx") Or (xExt = ".doc") Or (xExt = ".docm") Or (xExt = ".dot") Or _
(xExt = ".dotm") Or (xExt = ".dotx") Then
MergeDoc xWdApp, xPath & xFileArr(I), xNewDoc
Kill xPath & xFileArr(I)
End If
Next
xNewDoc.Sections.Item(1).Range.Delete wdCharacter, 1
xNewDoc.SaveAs2 xPDFSavePath, wdFormatPDF
xNewDoc.Close wdDoNotSaveChanges, wdOriginalDocumentFormat, False
xWdApp.Quit
Set xMail = Nothing
Set xNameSpace = Nothing
Set xFSysObj = Nothing
MsgBox "Merged successfully", vbInformation + vbOKOnly
End Sub
Public Function SplitPath(FullPath As String, ResultFlag As Integer) As String
Dim SplitPos As Integer, DotPos As Integer
SplitPos = InStrRev(FullPath, "/")
DotPos = InStrRev(FullPath, ".")
Select Case ResultFlag
Case 0
SplitPath = Left(FullPath, SplitPos - 1)
Case 1
If DotPos = 0 Then DotPos = Len(FullPath) + 1
SplitPath = Mid(FullPath, SplitPos + 1, DotPos - SplitPos - 1)
Case 2
If DotPos = 0 Then DotPos = Len(FullPath)
SplitPath = Mid(FullPath, DotPos)
Case Else
Err.Raise vbObjectError + 1, "SplitPath Function", "Invalid Parameter!"
End Select
End Function
Function CleanFileName(StrText As String) As String
Dim xStripChars As String
Dim xLen As Integer
Dim I As Integer
xStripChars = "/\[]:=," & Chr(34)
xLen = Len(xStripChars)
StrText = Trim(StrText)
For I = 1 To xLen
StrText = Replace(StrText, Mid(xStripChars, I, 1), "")
Next
CleanFileName = StrText
End Function
Function GetFiles(xFldPath As String) As String()
On Error Resume Next
Dim xFile As String
Dim xFileArr() As String
Dim xArr() As String
Dim I, x As Integer
x = 0
ReDim xFileArr(1)
xFileArr(1) = xFldPath '& "\"
xFile = Dir(xFileArr(1) & "*.*")
Do Until xFile = ""
x = x + 1
xFile = Dir
Loop
ReDim xArr(0 To x)
x = 0
xFile = Dir(xFileArr(1) & "*.*")
Do Until xFile = ""
xArr(x) = xFile
x = x + 1
xFile = Dir
Loop
GetFiles = xArr()
End Function
Sub MergeDoc(WdApp As Word.Application, xFileName As String, Doc As Document)
Dim xNewDoc As Document
Dim xSec As Section
Set xNewDoc = WdApp.Documents.Open(filename:=xFileName, Visible:=False)
Set xSec = Doc.Sections.Add
xNewDoc.Content.Copy
xSec.PageSetup = xNewDoc.PageSetup
xSec.Range.PasteAndFormat wdFormatOriginalFormatting
xNewDoc.Close
End Sub3. napsauttaa Työkalut > Viitteet avaa Viitteet valintaikkuna. Tarkista Microsoft Excel -objektikirjasto, Microsoft Scripting Runtime ja Microsoft Word -objektikirjasto laatikot ja napsauta sitten OK -painiketta. Katso kuvakaappaus:
4. paina F5 näppäintä tai napsauta ajaa -painiketta suorittaaksesi koodin. Sitten eräs Tallenna nimellä valintaikkuna avautuu, määritä kansio, johon tiedosto tallennetaan, anna PDF-tiedostolle nimi ja napsauta Säästä -painiketta. Katso kuvakaappaus:
5. Sitten a Microsoft Outlook valintaikkuna avautuu, napsauta OK painiketta.
Nyt valittu sähköposti kaikkine liitteineen tallennetaan yhdeksi PDF-tiedostoksi.
Huomautuksia: Tämä VBA-komentosarja toimii vain Microsoft Word- ja Excel-liitteillä.
Tallenna valitut sähköpostit helposti eri muototiedostoina Outlookissa:
Kanssa Joukkotallennus hyödyllisyys Kutools Outlookille, voit helposti tallentaa useita valittuja sähköposteja yksittäisenä HTML-muotoisena tiedostona, TXT-muotoisena tiedostona, Word-asiakirjana, CSV-tiedostona sekä PDF-tiedostona Outlookissa alla olevan kuvakaappauksen mukaisesti. Lataa Kutools for Outlookin ilmainen versio nyt!
Aiheeseen liittyviä artikkeleita:
- Kuinka käyttää komentopainiketta aktiivisen laskentataulukon tallentamiseen PDF-tiedostona Excelissä?
- Kuinka tallentaa laskentataulukko PDF-tiedostona ja lähettää sen liitetiedostona Outlookin kautta?
- Kuinka tallentaa valinnan tai koko työkirjan PDF-muodossa Exceliin?
Parhaat toimiston tuottavuustyökalut
Breaking News: Kutools for Outlook julkaisee ilmaisen version!
Koe täysin uusi Kutools for Outlook ILMAINEN versio, jossa on yli 70 uskomatonta ominaisuutta, sinun käytössäsi IKUISESTI! Lataa nyt napsauttamalla!
📧 Sähköpostiautomaatio: Automaattinen vastaus (saatavilla POP:lle ja IMAP:lle) / Ajoita sähköpostien lähettäminen / Automaattinen CC/BCC sääntöjen mukaan lähetettäessä sähköpostia / Automaattinen edelleenlähetys (lisäsäännöt) / Automaattinen tervehdys / Jaa usean vastaanottajan sähköpostit automaattisesti yksittäisiksi viesteiksi ...
📨 Sähköposti Management: Muista sähköpostit / Estä huijaussähköpostit aiheiden ja muiden taholta / Poista päällekkäiset sähköpostit / Tarkennettu Haku / Yhdistä kansiot ...
📁 Liitteet Pro: Erätallennus / Erä Irrota / Eräpakkaus / Automaattinen tallennus / Automaattinen irrotus / Automaattinen pakkaus ...
🌟 Interface Magic: 😊Lisää kauniita ja siistejä emojia / Muistuttaa sinua tärkeistä sähköpostiviesteistä / Minimoi Outlook sulkemisen sijaan ...
???? Yhden napsautuksen Wonders: Vastaa kaikkiin liitteillä / Tietojenkalastelun vastaiset sähköpostit / 🕘Näytä lähettäjän aikavyöhyke ...
👩🏼🤝👩🏻 Yhteystiedot ja kalenteri: Erä Lisää yhteystietoja valituista sähköpostiviesteistä / Jaa yhteysryhmä yksittäisiin ryhmiin / Poista syntymäpäivämuistutukset ...
