有人能帮我把下面的代码改为不从电子邮件正文(签名、徽标等(中拍照吗？只从outlook电子邮件本身中获取附件。我使用的是Microsoft的默认"mAttachmentSaver"脚本。
Attribute VB_Name = "mAttachmentSaver"
'---------------------------------------------------------------------------------
' The sample scripts are not supported under any Microsoft standard support
' program or service. The sample scripts are provided AS IS without warranty
' of any kind. Microsoft further disclaims all implied warranties including,
' without limitation, any implied warranties of merchantability or of fitness for
' a particular purpose. The entire risk arising out of the use or performance of
' the sample scripts and documentation remains with you. In no event shall
' Microsoft, its authors, or anyone else involved in the creation, production, or
' delivery of the scripts be liable for any damages whatsoever (including,
' without limitation, damages for loss of business profits, business interruption,
' loss of business information, or other pecuniary loss) arising out of the use
' of or inability to use the sample scripts or documentation, even if Microsoft
' has been advised of the possibility of such damages.
'---------------------------------------------------------------------------------
Option Explicit
' *****************
' For Outlook 2010.
' *****************
#If VBA7 Then
' The window handle of Outlook.
Private lHwnd As LongPtr
' /* API declarations. */
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
' *****************************************
' For the previous version of Outlook 2010.
' *****************************************
#Else
' The window handle of Outlook.
Private lHwnd As Long
' /* API declarations. */
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
#End If
' The class name of Outlook window.
Private Const olAppCLSN As String = "rctrl_renwnd32"
' Windows desktop - the virtual folder that is the root of the namespace.
Private Const CSIDL_DESKTOP = &H0
' Only return file system directories. If the user selects folders that are not part of the file system, the OK button is grayed.
Private Const BIF_RETURNONLYFSDIRS = &H1
' Do not include network folders below the domain level in the dialog box's tree view control.
Private Const BIF_DONTGOBELOWDOMAIN = &H2
' The maximum length for a path is 260 characters.
Private Const MAX_PATH = 260
' ######################################################
' Returns the number of attachements in the selection.
' ######################################################
Public Function SaveAttachmentsFromSelection() As Long
Dim objFSO As Object ' Computer's file system object.
Dim objShell As Object ' Windows Shell application object.
Dim objFolder As Object ' The selected folder object from Browse for Folder dialog box.
Dim objItem As Object ' A specific member of a Collection object either by position or by key.
Dim selItems As Selection ' A collection of Outlook item objects in a folder.
Dim atmt As Attachment ' A document or link to a document contained in an Outlook item.
Dim strAtmtPath As String ' The full saving path of the attachment.
Dim strAtmtFullName As String ' The full name of an attachment.
Dim strAtmtName(1) As String ' strAtmtName(0): to save the name; strAtmtName(1): to save the file extension. They are separated by dot of an attachment file name.
Dim strAtmtNameTemp As String ' To save a temporary attachment file name.
Dim intDotPosition As Integer ' The dot position in an attachment name.
Dim atmts As Attachments ' A set of Attachment objects that represent the attachments in an Outlook item.
Dim lCountEachItem As Long ' The number of attachments in each Outlook item.
Dim lCountAllItems As Long ' The number of attachments in all Outlook items.
Dim strFolderPath As String ' The selected folder path.
Dim blnIsEnd As Boolean ' End all code execution.
Dim blnIsSave As Boolean ' Consider if it is need to save.
blnIsEnd = False
blnIsSave = False
lCountAllItems = 0
On Error Resume Next
Set selItems = ActiveExplorer.Selection
If Err.Number = 0 Then
' Get the handle of Outlook window.
lHwnd = FindWindow(olAppCLSN, vbNullString)
If lHwnd <> 0 Then
' /* Create a Shell application object to pop-up BrowseForFolder dialog box. */
Set objShell = CreateObject("Shell.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objShell.BrowseForFolder(lHwnd, "Select folder to save attachments:", _
BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, CSIDL_DESKTOP)
' /* Failed to create the Shell application. */
If Err.Number <> 0 Then
MsgBox "Run-time error '" & CStr(Err.Number) & " (0x" & CStr(Hex(Err.Number)) & ")':" & vbNewLine & _
Err.Description & ".", vbCritical, "Error from Attachment Saver"
blnIsEnd = True
GoTo PROC_EXIT
End If
If objFolder Is Nothing Then
strFolderPath = ""
blnIsEnd = True
GoTo PROC_EXIT
Else
strFolderPath = CGPath(objFolder.Self.Path)
' /* Go through each item in the selection. */
For Each objItem In selItems
lCountEachItem = objItem.Attachments.Count
' /* If the current item contains attachments. */
If lCountEachItem > 0 Then
Set atmts = objItem.Attachments
' /* Go through each attachment in the current item. */
For Each atmt In atmts
' Get the full name of the current attachment.
strAtmtFullName = atmt.FileName
' Find the dot postion in atmtFullName.
intDotPosition = InStrRev(strAtmtFullName, ".")
' Get the name.
strAtmtName(0) = Left$(strAtmtFullName, intDotPosition - 1)
' Get the file extension.
strAtmtName(1) = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
' Get the full saving path of the current attachment.
strAtmtPath = strFolderPath & atmt.FileName
' /* If the length of the saving path is not larger than 260 characters.*/
If Len(strAtmtPath) <= MAX_PATH Then
' True: This attachment can be saved.
blnIsSave = True
' /* Loop until getting the file name which does not exist in the folder. */
Do While objFSO.FileExists(strAtmtPath)
strAtmtNameTemp = strAtmtName(0) & _
Format(Now, "_mmddhhmmss") & _
Format(Timer * 1000 Mod 1000, "000")
strAtmtPath = strFolderPath & strAtmtNameTemp & "." & strAtmtName(1)
' /* If the length of the saving path is over 260 characters.*/
If Len(strAtmtPath) > MAX_PATH Then
lCountEachItem = lCountEachItem - 1
' False: This attachment cannot be saved.
blnIsSave = False
Exit Do
End If
Loop
' /* Save the current attachment if it is a valid file name. */
If blnIsSave Then
If itmOL.BodyFormat = olFormatHTML Then
'If the email is HTML type, the embeded picture need special care
Dim oPA As Outlook.PropertyAccessor
Dim PropName As String
Dim PropInfo As String
PropName = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
Set oPA = itmOL.Attachments.Item(i).PropertyAccessor
PropInfo = oPA.GetProperty(PropName)
If PropInfo = "Flase" Then atmt.SaveAsFile strAtmtPath
Else
lCountEachItem = lCountEachItem - 1
End If
Next
End If
' Count the number of attachments in all Outlook items.
lCountAllItems = lCountAllItems + lCountEachItem
Next
End If
Else
MsgBox "Failed to get the handle of Outlook window!", vbCritical, "Error from Attachment Saver"
blnIsEnd = True
GoTo PROC_EXIT
End If
' /* For run-time error:
' The Explorer has been closed and cannot be used for further operations.
' Review your code and restart Outlook. */
Else
MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver"
blnIsEnd = True
End If
PROC_EXIT:
SaveAttachmentsFromSelection = lCountAllItems
' /* Release memory. */
If Not (objFSO Is Nothing) Then Set objFSO = Nothing
If Not (objItem Is Nothing) Then Set objItem = Nothing
If Not (selItems Is Nothing) Then Set selItems = Nothing
If Not (atmt Is Nothing) Then Set atmt = Nothing
If Not (atmts Is Nothing) Then Set atmts = Nothing
' /* End all code execution if the value of blnIsEnd is True. */
If blnIsEnd Then End
End Function
' #####################
' Convert general path.
' #####################
Public Function CGPath(ByVal Path As String) As String
If Right(Path, 1) <> "" Then Path = Path & ""
CGPath = Path
End Function
' ######################################
' Run this macro for saving attachments.
' ######################################
Public Sub ExecuteSaving()
Dim lNum As Long
lNum = SaveAttachmentsFromSelection
If lNum > 0 Then
MsgBox CStr(lNum) & " attachment(s) was(were) saved successfully.", vbInformation, "Message from Attachment Saver"
Else
MsgBox "No attachment(s) in the selected Outlook items.", vbInformation, "Message from Attachment Saver"
End If
End Sub
我研究嵌入式图像已经十年了。我现在不记得细节了，但它涉及到试图区分附加的图像和嵌入的图像。当时，我收到了许多包含这两种内容的电子邮件。今天，我在收件箱中找不到一封嵌入附件图像的电子邮件；嵌入的图片、签名等都是指向外部网站的链接。
下面的宏是我用来调查我想要处理的电子邮件的两个宏之一。当我只需要有限的诊断时，我使用带有Debug.Print的版本。下面的宏输出到一个名为"InvestigateEmails.txt"的桌面文件。它同时输出文本和Html正文，但回车、换行和制表符被"｛cr｝"、"｛lf｝"one_answers"｛tb｝"替换。这使我能够全面调查电子邮件的真实情况和显示的情况。
若要使用此宏，请选择其中一封或多封电子邮件，然后运行宏InvestigateEmails1。您需要研究输出，并确定要保存的附件和不保存的附件之间的区别。一旦你知道如何识别差异，你就可以问一个特定的问题。
宏InvestigateEmails1需要引用"Microsoft Scripting Runtime"。宏PutTextFileUtf8NoBom需要引用"Microsoft ActiveX数据对象n.n库"。在我的系统上，"n.n"是"6.1"，但宏应该与早期版本一起运行。
Public Sub InvestigateEmails1()
' Outputs properties of selected emails to a file.
' ??????? No record of when originally coded
' 22Oct16 Output to desktop file rather than Immediate Window.
' Technique for locating desktop from answer by Kyle:
' http://stackoverflow.com/a/17551579/973283
' Needs reference to "Microsoft Scripting Runtime"
Dim Exp As Explorer
Dim FileBody As String
Dim fso As FileSystemObject
Dim InxA As Long
Dim ItemCrnt As MailItem
Dim Path As String
Path = CreateObject("WScript.Shell").SpecialFolders("Desktop")
Set Exp = Outlook.Application.ActiveExplorer
If Exp.Selection.Count = 0 Then
Call MsgBox("Please select one or more emails then try again", vbOKOnly)
Exit Sub
Else
FileBody = ""
For Each ItemCrnt In Exp.Selection
With ItemCrnt
FileBody = FileBody & "From (Sender): " & .Sender & vbLf
FileBody = FileBody & "From (Sender name): " & .SenderName & vbLf
FileBody = FileBody & "From (Sender email address): " & _
.SenderEmailAddress & vbLf
FileBody = FileBody & "Subject: " & CStr(.Subject) & vbLf
If .Attachments.Count = 0 Then
FileBody = FileBody & "No attachments" & vbLf
Else
FileBody = FileBody & "Attachments:" & vbLf
FileBody = FileBody & "No.|Type|Path|Filename|DisplayName|" & vbLf
For InxA = 1 To .Attachments.Count
With .Attachments(InxA)
FileBody = FileBody & InxA & "|"
Select Case .Type
Case olByValue
FileBody = FileBody & "Val"
Case olEmbeddeditem
FileBody = FileBody & "Ebd"
Case olByReference
FileBody = FileBody & "Ref"
Case olOLE
FileBody = FileBody & "OLE"
Case Else
FileBody = FileBody & "Unk"
End Select
' Not all types have all properties. This code handles
' those missing properties of which I am aware. However,
' I have never found an attachment of type Reference or OLE.
' Additional code may be required for them.
Select Case .Type
Case olEmbeddeditem
FileBody = FileBody & "|"
Case Else
FileBody = FileBody & "|" & .Pathname
End Select
FileBody = FileBody & "|" & .Filename
FileBody = FileBody & "|" & .DisplayName & "|" & vbLf
End With
Next
End If
Call OutLongText(FileBody, "Text: ", Replace(Replace(Replace(.Body, vbLf, _
"{lf}" & vbLf), vbCr, "{cr}"), vbTab, "{tb}"))
Call OutLongText(FileBody, "Html: ", Replace(Replace(Replace(.HtmlBody, vbLf, _
"{lf}" & vbLf), vbCr, "{cr}"), vbTab, "{tb}"))
FileBody = FileBody & "--------------------------" & vbLf
End With
Next
End If
Call PutTextFileUtf8NoBom(Path & "InvestigateEmails.txt", FileBody)
End Sub
Public Sub OutLongText(ByRef TextOut As String, ByVal Head As String, _
ByVal TextIn As String)
' Break TextIn into lines of not more than 100 characters
' and append to TextOut
Dim PosEnd As Long
Dim LenOut As Long
Dim PosStart As Long
If TextIn <> "" Then
PosStart = 1
Do While PosStart <= Len(TextIn)
PosEnd = InStr(PosStart, TextIn, vbLf)
If PosEnd = 0 Or PosEnd > PosStart + 100 Then
' No LF in remainder of TextIn or next 100 characters
PosEnd = PosStart + 99
LenOut = 100
Else
' Output upto LF. Restart output after LF
LenOut = PosEnd - PosStart
PosEnd = PosEnd
End If
If PosStart = 1 Then
TextOut = TextOut & Head
Else
TextOut = TextOut & Space(Len(Head))
End If
TextOut = TextOut & Mid$(TextIn, PosStart, LenOut) & vbLf
PosStart = PosEnd + 1
Loop
End If
End Sub
Public Sub PutTextFileUtf8NoBom(ByVal PathFileName As String, ByVal FileBody As String)
' Outputs FileBody as a text file named PathFileName using
' UTF-8 encoding without leading BOM
' Needs reference to "Microsoft ActiveX Data Objects n.n Library"
' Addition to original code says version 2.5. Tested with version 6.1.
' 1Nov16 Copied from http://stackoverflow.com/a/4461250/973283
' but replaced literals with parameters.
' 15Aug17 Discovered routine was adding an LF to the end of the file.
' Added code to discard that LF.
' 11Oct17 Posted to StackOverflow
' 9Aug18 Comment from rellampec suggested removal of adWriteLine from
' WriteTest statement would avoid adding LF.
' 30Sep18 Amended routine to remove adWriteLine from WriteTest statement
' and code to remove LF from file. Successfully tested new version.
' References: http://stackoverflow.com/a/4461250/973283
' https://www.w3schools.com/asp/ado_ref_stream.asp
Dim BinaryStream As Object
Dim UTFStream As Object
Set UTFStream = CreateObject("adodb.stream")
UTFStream.Type = adTypeText
UTFStream.Mode = adModeReadWrite
UTFStream.Charset = "UTF-8"
UTFStream.Open
UTFStream.WriteText FileBody
UTFStream.Position = 3 'skip BOM
Set BinaryStream = CreateObject("adodb.stream")
BinaryStream.Type = adTypeBinary
BinaryStream.Mode = adModeReadWrite
BinaryStream.Open
UTFStream.CopyTo BinaryStream
UTFStream.Flush
UTFStream.Close
Set UTFStream = Nothing
BinaryStream.SaveToFile PathFileName, adSaveCreateOverWrite
BinaryStream.Flush
BinaryStream.Close
Set BinaryStream = Nothing
End Sub
这里显示的答案的简单演示。隐藏的附件应该是图像。
使用Outlook VBA 区分可见和不可见附件
Private Sub AttachmentsHidden()
Const PR_ATTACHMENT_HIDDEN = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
Dim olObj As Object
Dim olPA As propertyAccessor
Dim olAtt As Attachment
' Open an appropriate mailitem
Set olObj = ActiveInspector.currentItem
If olObj.Class = olmail Then
Debug.Print " Subject: " & olObj.Subject
For Each olAtt In olObj.Attachments
Set olPA = olAtt.propertyAccessor
If olPA.GetProperty(PR_ATTACHMENT_HIDDEN) = False Then
Debug.Print " " & olAtt.fileName & vbCr & " not hidden"
Debug.Print " Save this?"
Else
Debug.Print " " & olAtt.fileName & vbCr & " hidden"
Debug.Print " Skip this?"
End If
Next
End If
End Sub