Question

我找到了这段代码来下载电子邮件并将其转换为PDF。它工作得很好，但我唯一的问题是可以删除保存通知，并在触发宏时自动保存它吗？以下是我的全部代码：

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing

Set MyOlNamespace = Application.GetNamespace("MAPI")
Set MySelectedItem = ActiveExplorer.Selection.Item(1)
Set fso = CreateObject("Scripting.FileSystemObject")
'tmpFileName = FSO.GetSpecialFolder(2)
tmpFileName = "C:\CRM\Postboek\Ongekoppeld"
strRecieved = MySelectedItem.ReceivedByName
strSender = MySelectedItem.SenderName
strDatum = MySelectedItem.ReceivedTime
strDatum = Replace(strDatum, ":", "-")
strDatum = Replace(strDatum, "/", "-")
strName = "email_temp.mht"
tmpFileName = tmpFileName & "\" & strName
MySelectedItem.SaveAs tmpFileName, 10
On Error Resume Next
'           If MySelectedItem.BodyFormat <> olFormatHTML Then
 '               strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
 '           Else
 '               strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
 ''               strFile & "'>" & strFile & "</a>"
  '          End If
  '      If MySelectedItem.BodyFormat <> olFormatHTML Then
  '          MySelectedItem.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & MySelectedItem.Body
  '      Else
  '          MySelectedItem.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & MySelectedItem.HTMLBody
  '      End If
Set wrdApp = GetObject(, "Word.Application")
If Err Then
Set wrdApp = CreateObject("Word.Application")
bStarted = True
End If
On Error GoTo 0
Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=False, Format:=7)
Set dlgSaveAs = wrdApp.FileDialog(msoFileDialogSaveAs)
Set fdfs = dlgSaveAs.Filters
i = 0
For Each fdf In fdfs
i = i + 1
If InStr(1, fdf.Extensions, "pdf", vbTextCompare) > 0 Then
Exit For
End If
Next fdf
dlgSaveAs.FilterIndex = i
Set WshShell = CreateObject("WScript.Shell")
'SpecialPath = WshShell.SpecialFolders(16)
SpecialPath = "C:\CRM\Postboek\Ongekoppeld"
msgFileName = MySelectedItem.Subject
msgFileName = Replace(msgFileName, ":", "-")
Set oRegEx = CreateObject("vbscript.regexp")
oRegEx.Global = True
oRegEx.Pattern = "[\/:*?""<>|]"
'msgFileName = Trim(oRegEx.Replace(msgFileName, ""))
'msgFileName = Trim(oRegEx.Replace(msgFileName, ""))
If Len(strRecieved) = 0 Then
    dlgSaveAs.InitialFileName = SpecialPath & "\" & msgFileName & " - " & strSender & " - " & strDatum

ElseIf Len(strRecieved) > 0 Then
    dlgSaveAs.InitialFileName = SpecialPath & "\" & msgFileName & " - " & strRecieved & " - " & strDatum
End If


'dlgSaveAs.InitialFileName = SpecialPath & "\" & msgFileName & " - " & strRecieved & " - " & strDatum
If dlgSaveAs.Show = -1 Then
    strCurrentFile = dlgSaveAs.SelectedItems(1)
    If Right(strCurrentFile, 4) <> ".pdf" Then
        Response = MsgBox("Sorry, only saving in the pdf-format is supported." & _
        vbNewLine & vbNewLine & "Save as pdf instead?", vbInformation + vbOKCancel)
        If Response = vbCancel Then
            wrdDoc.Close 0
            If bStarted Then wrdApp.Quit
            Exit Sub
        ElseIf Response = vbOK Then
            intPos = InStrRev(strCurrentFile, ".")
                If intPos > 0 Then
                strCurrentFile = Left(strCurrentFile, intPos - 1)
                End If
        strCurrentFile = strCurrentFile & ".pdf"
    End If
End If
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
strCurrentFile, _
ExportFormat:=17, _
OpenAfterExport:=False, _
OptimizeFor:=0, _
Range:=0, _
From:=0, _
To:=0, _
Item:=0, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=0, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False
End If
Set dlgSaveAs = Nothing
wrdDoc.Close
If bStarted Then wrdApp.Quit
Set MyOlNamespace = Nothing
Set MySelectedItem = Nothing
Set wrdDoc = Nothing
Set wrdApp = Nothing
Set oRegEx = Nothing


End Sub

此部分向用户发出通知，如果他们想保存它，我实际上只是想删除它：

If dlgSaveAs.Show = -1 Then
    strCurrentFile = dlgSaveAs.SelectedItems(1)
    If Right(strCurrentFile, 4) <> ".pdf" Then
        Response = MsgBox("Sorry, only saving in the pdf-format is supported." & _
        vbNewLine & vbNewLine & "Save as pdf instead?", vbInformation + vbOKCancel)
        If Response = vbCancel Then
            wrdDoc.Close 0
            If bStarted Then wrdApp.Quit
            Exit Sub
        ElseIf Response = vbOK Then
            intPos = InStrRev(strCurrentFile, ".")
                If intPos > 0 Then
                strCurrentFile = Left(strCurrentFile, intPos - 1)
                End If
        strCurrentFile = strCurrentFile & ".pdf"
    End If
End If

以下是我要删除的内容的屏幕截图： screenshot

Answer 1

删除此部分：

If Len(strRecieved) = 0 Then
    dlgSaveAs.InitialFileName = SpecialPath & "\" & msgFileName & " - " & strSender & " - " & strDatum

ElseIf Len(strRecieved) > 0 Then
    dlgSaveAs.InitialFileName = SpecialPath & "\" & msgFileName & " - " & strRecieved & " - " & strDatum
End If


'dlgSaveAs.InitialFileName = SpecialPath & "\" & msgFileName & " - " & strRecieved & " - " & strDatum
If dlgSaveAs.Show = -1 Then
    strCurrentFile = dlgSaveAs.SelectedItems(1)
    If Right(strCurrentFile, 4) <> ".pdf" Then
        Response = MsgBox("Sorry, only saving in the pdf-format is supported." & _
        vbNewLine & vbNewLine & "Save as pdf instead?", vbInformation + vbOKCancel)
        If Response = vbCancel Then
            wrdDoc.Close 0
            If bStarted Then wrdApp.Quit
            Exit Sub
        ElseIf Response = vbOK Then
            intPos = InStrRev(strCurrentFile, ".")
                If intPos > 0 Then
                strCurrentFile = Left(strCurrentFile, intPos - 1)
                End If
        strCurrentFile = strCurrentFile & ".pdf"
    End If
End If

在下面设置您想要的文件名：

wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
___PUTYOURFILENAMEHERE___, _
ExportFormat:=17, _
OpenAfterExport:=False, _
OptimizeFor:=0, _
Range:=0, _
From:=0, _
To:=0, _
Item:=0, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=0, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False

无需通知即可将电子邮件保存为pdf

1 个答案: