Question

电子邮件每天从abc@xyz.com收到一次，主题为＆＃34;电子邮件＆＃34;附件是电子邮件（最多20个附件，每个15kb）。

我正在尝试将这些附件移动到名为＆＃34; Extra＆＃34;的子文件夹中。在我的Outlook收件箱中。

我在修改旧代码时遇到了问题。我想它是从这里来的。 // Second time (back from CAS) there is a ticket= to validate // CAS 3 doesn't list attributes through /serviceValidate, so lets build a SAML request and use that instead. string SAMLstr = "<?xml version='1.0'?><SOAP-ENV:Envelope xmlns:SOAP-ENV=\"http://schemas.xmlsoap.org/soap/envelope/\">" + "<SOAP-ENV:Header/><SOAP-ENV:Body><samlp:Request xmlns:samlp=\"urn:oasis:names:tc:SAML:1.0:protocol\" " + "MajorVersion=\"1\" MinorVersion=\"1\" RequestID=\"_" + Request.ServerVariables["REMOTE_HOST"] + "." + DateTime.Now.Ticks + "\"" + "IssueInstant=\"" + DateTime.Now + "\"><samlp:AssertionArtifact>" + tkt + "</samlp:AssertionArtifact>" + "</samlp:Request></SOAP-ENV:Body></SOAP-ENV:Envelope>"; string validateurl = CASHOST + "samlValidate?TARGET=" + service + "&ticket=" + tkt; // Set up an xml document to catch the SAML responce and then parse it. XmlDocument xmlDoc = new XmlDocument(); xmlDoc.LoadXml(new WebClient().UploadString(validateurl, SAMLstr)); // The response uses multiple namespaces, whee! var nsmgr = new XmlNamespaceManager(xmlDoc.NameTable); nsmgr.AddNamespace("s", "http://schemas.xmlsoap.org/soap/envelope/"); nsmgr.AddNamespace("nsR", "urn:oasis:names:tc:SAML:1.0:protocol"); nsmgr.AddNamespace("nsA", "urn:oasis:names:tc:SAML:1.0:assertion"); // Let's see if they authed successfully: if (xmlDoc.SelectSingleNode("/s:Envelope/s:Body/nsR:Response/nsR:Status/nsR:StatusCode", nsmgr).Attributes["Value"].Value == ("samlp:Success")) { // They authenticated successfully; populate their id and roles. string netid = xmlDoc.SelectSingleNode("/s:Envelope/s:Body/nsR:Response/nsA:Assertion/nsA:AuthenticationStatement/nsA:Subject/nsA:NameIdentifier", nsmgr).InnerText; // Grab the "memberOf" attriubute - it contains a child node for each group distinguished name. XmlNode memberOf = xmlDoc.SelectSingleNode("/s:Envelope/s:Body/nsR:Response/nsA:Assertion/nsA:AttributeStatement/nsA:Attribute[@AttributeName='memberOf']", nsmgr); // I don't want to iterate through that, so I'll just grab all the text and split it with a regex to split up the OUs and DCs. string[] groups = Regex.Split(memberOf.InnerText.ToLower().Substring(3), "cn=(.*?),ou="); HttpContext.Current.User = new GenericPrincipal(new GenericIdentity(netid),new string[] {"staff", "union", "UTech"}); // Splicing together the groups names but droping the OUs (every other entry) string roles=groups[1]; for (int x=3;x<groups.Length;x+=2) roles+="|"+groups[x]; // Let's bake cookies with the netid, roles, and persistence. 1: Make the ticket. FormsAuthenticationTicket ticket = new FormsAuthenticationTicket(1, netid, DateTime.Now, DateTime.Now.AddMinutes(2880), isPersistent, roles, FormsAuthentication.FormsCookiePath); // 2. Encrypt the ticket. string hash = FormsAuthentication.Encrypt(ticket); // 3. Turn the encrypted ticket into a cookie! HttpCookie cookie = new HttpCookie(FormsAuthentication.FormsCookieName, hash); // 4. Set expiration on the cookie to match the ticket. if (ticket.IsPersistent) cookie.Expires = ticket.Expiration; // 5. Put the cookie in the jar. Response.Cookies.Add(cookie); // We're done! Send them home. // [TEMP, next 3 lines are debug] Response.Redirect(service + Session["backto"], true); Label1.Text = "Welcome, "+netid+"!"; Label2.Text = roles; Label3.Text = (User.IsInRole("staff"))?"True":"False";。

Const attPath As String = "Mailbox/Extra"

Answer 1

您似乎无法将附件移动到Outlook中的其他文件夹，而无需事先将其保存在本地。

以下代码应该对您有用......

在ThisOutlookSession中：

Private WithEvents InboxItems As Outlook.Items

Private Sub Application_Startup()
    On Error Resume Next
    Set InboxItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub InboxItems_ItemAdd(ByVal Item As Object)
    On Error Resume Next
    If TypeName(Item) = "MailItem" Then Call MoveAttachments(Item)
End Sub

在一个模块中：

Function MoveAttachments(ByVal Item As Object)

    Const AttachmentFolder As String = "Extra"

    Dim ThisNameSpace As Outlook.NameSpace: Set ThisNameSpace = Application.GetNamespace("MAPI")
    Dim Inbox As Outlook.MAPIFolder: Set Inbox = ThisNameSpace.GetDefaultFolder(olFolderInbox)

    On Error Resume Next
        Dim AttFolder As Outlook.Folder: Set AttFolder = Inbox.Folders(AttachmentFolder)
        If AttFolder Is Nothing Then Set AttFolder = Inbox.Parent.Folders(AttachmentFolder)
        If AttFolder Is Nothing Then Exit Function
    On Error GoTo ExitSub

    With Item   'From specified user with specified subject
        If .SenderName = "teresa" And .Subject = "emails" And .Attachments.Count >= 1 Then
            Call MoveAttachedMessages(Item, AttFolder, False)
        End If
    End With

ExitSub:
End Function

Function MoveAttachedMessages(ByVal Item As Object, _
    AttachmentFolder As Outlook.Folder, _
    Optional DeleteMoved As Boolean)

    If IsMissing(DeleteMoved) Then DeleteMoved = False

    Dim TempPath As String: TempPath = Environ("temp") & "\OLAtt-" & Format(Now(), "yyyy-mm-dd") & "\"
    If Dir(TempPath, vbDirectory) = "" Then MkDir TempPath

    Dim ThisNameSpace As Outlook.NameSpace: Set ThisNameSpace = Application.GetNamespace("MAPI")
    Dim AttItems As Outlook.Attachments, AttItem As Outlook.Attachment
    Dim msgItem As Outlook.MailItem

    ' Save attachments
    On Error Resume Next

    Set AttItems = Item.Attachments
    For Each AttItem In AttItems
        If LCase(Right(AttItem.FileName, 4)) = ".msg" Then
            AttItem.SaveAsFile TempPath & AttItem.FileName
            Set msgItem = ThisNameSpace.OpenSharedItem(TempPath & AttItem.FileName)
            'Set msgItem = Outlook.CreateItemFromTemplate(TempPath & AttItem.FileName)
            If Not msgItem Is Nothing Then
                msgItem.Save
                msgItem.Move AttachmentFolder
                If msgItem.Saved = True And DeleteMoved = True Then
                    AttItem.Delete
                    Item.Save
                End If
                msgItem.UnRead = True
            End If
        End If
    Next AttItem

    If Err.Number = 0 Then Item.UnRead = False ' Mark as Read

    If Dir(TempPath, vbDirectory) <> "" Then
        Kill TempPath & "\" & "*.*"
        RmDir TempPath
    End If

End Function

注意：不确定原因，但使用此代码时，复制的附件无法标记为未读。我已经离开了代码，也许其他人可以确定问题。

Answer 2

这是我的文件夹代码

-Inbox
--Folder1
---SubFolder1
---SubFolder2
--Folder2

.. 在Folder1中搜索带有附件的电子邮件，然后移至特定的SubFolder

Sub MoveAttachmentToFolder(Item As Outlook.MailItem)

'Dichiarazione
Dim OutApp As Outlook.Application
Dim Namespace As Outlook.Namespace
Dim Mfolder As Outlook.MAPIFolder
Dim Folder As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim UserFolder As Outlook.MAPIFolder
Dim UserUserFolder As Outlook.MAPIFolder
Dim olkAtt As Outlook.Attachment

Set OutApp = New Outlook.Application
Set Namespace = OutApp.GetNamespace("MAPI")
Set Root = Namespace.Folders("root")
Set Folder = Root.Folders("Inbox")
Set SubFolder = Folder.Folders("Folder1")
Set UserFolder = SubFolder.Folders("SubFolder1")
Debug.Print UserFolder.Name

    'Check each attachment
    For Each olkAtt In Item.Attachments
        'If the attachment's file name with 202627
         If InStr(LCase(olkAtt), "202627") > 0 Then
            'Move the message to SubFolder "DL IT CG SKY-DE PRJ"
            Item.Move SubFolder.Folders("SubFolder1")
            'No need to check any of this message's remaining attachments
            Exit For
        End If
    Next
    Set olkAtt = Nothing
End Sub

将电子邮件附件移动到Outlook中的子文件夹

2 个答案: