Email áthelyezés VBA

Email áthelyezés VBA
2020-03-09T13:08:09+01:00
2020-03-11T09:08:10+01:00
2022-10-15T21:16:39+02:00
Brandbalu
Sziasztok,

az alábbi kódom van:

Sub Move_Email() Dim SourceFolderRef As Outlook.MAPIFolder, SourceMailBoxName As String, Source_Pst_Folder_Name As String Dim olEmail As MailItem, MailsCount As Double SourceMailBoxName = "beispiel@gmx.net" Source_Pst_Folder_Name = "Beérkezett üzenetek" Set SourceFolder = Outlook.Session.Folders(SourceMailBoxName).Folders(Source_Pst_Folder_Name) If SourceFolder.Items.Restrict("[UnRead] = True").Count = 0 Then MsgBox "No Unread Email In Inbox" Exit Sub End If Set MoveToFolder = Outlook.Session.Folders(SourceMailBoxName).Folders(Source_Pst_Folder_Name).Folders("Beispiel") For Each olEmail In SourceFolder.Items.Restrict("[UnRead] = True") If olEmail.Class <> olMail Then If TypeName(olEmail) = "MailItem" Then For Each atch In olEmail.Attachments If atch.Type = olByValue Then If InStr(UCase(atch.FileName), B) > 0 Then olEmail.Move MoveToFolder End If End If Next atch End If End If Next olEmail End Sub
A kód elvileg müködik, de ha egy Email áthelyezésre kerül, akkor a következöt a For Each ciklus miatt átugorja, így nem minden Email kerül áthelyezésre.

Próbálkoztam a For i=SourceFolder.Items.Restrict("[UnRead] = True").Count To 1 Step -1 megoldással is.
Sajnos az Outlookban IMAP fiók van és nem tudtam úgy megoldani, hogy egy SET  beállítással az OLEmail-t deklarálni tudjam.

Tudna valaki egy használható megoldást mutati?

Elöre is köszi.
Üdv,
Balu
Mutasd a teljes hozzászólást!
Találtam valamit, amivel elvileg most müködik:

Sub Move_Email() Dim SourceFolderRef As Outlook.MAPIFolder, SourceMailBoxName As String, Source_Pst_Folder_Name As String Dim olEmail As MailItem, MailsCount As Double SourceMailBoxName = "beispiel@gmx.net" Source_Pst_Folder_Name = "Beérkezett üzenetek" Set SourceFolder = Outlook.Session.Folders(SourceMailBoxName).Folders(Source_Pst_Folder_Name) If SourceFolder.Items.Restrict("[UnRead] = True").Count = 0 Then MsgBox "No Unread Email In Inbox" Exit Sub End If Set MoveToFolder = Outlook.Session.Folders(SourceMailBoxName).Folders(Source_Pst_Folder_Name).Folders("Beispiel") Linie1: For Each olEmail In SourceFolder.Items.Restrict("[UnRead] = True") If olEmail.Class <> olMail Then If TypeName(olEmail) = "MailItem" Then For Each atch In olEmail.Attachments If atch.Type = olByValue Then If InStr(UCase(atch.FileName), B) > 0 Then olEmail.Move MoveToFolder GoTo Linie1 End If End If Next atch End If End If Next olEmail End Sub
Mi a véleményed erröl?
Üdv,
Balu
Mutasd a teljes hozzászólást!

  • Szia!

    A for each atch ciklus alól kimozgatod a levelet......
    Ebben az esetben egy exit for-al ki kellene lépni a kellemetlenségek elkerülése véget.
    Mutasd a teljes hozzászólást!
  • Szia István,

    köszönöm a gyors választ.
    Egy kicsit pontosíthatnád, hogy hol kell kilépnem.
    Kipróbáltam a Move után, de nem segített.

    Köszi,
    Balu
    Mutasd a teljes hozzászólást!
  • Szia!

    A move utánra gondoltam ,igen.
    Ha ez nem segít akkor a move-ot is kivinni ebből a ciklusból és csak egy flag-et billenteni az atch cikluson belül, majd egyel kintebb move-olni ha teljesül a feltétel.
    Mutasd a teljes hozzászólást!
  • Szia,

    még mindig nem akar müködni.
    Most kiszedte A For Each atch-t.
    Megpróbáltam mit csinál, ha az összes olvasatlan Emailt át akarom helyezni.
    Sajnos ebben az esetben is átugrik minden második Emailt.
    Mutasd a teljes hozzászólást!
  • Kérhetek egy próbát?

    Cseréld le egy teszt erejéig a move-ot copy-ra.
    Még arra tippelnék hogy a move után automatikusan a nextre áll és a for nextje még egyet növel, így kettőt ugrik.
    Mutasd a teljes hozzászólást!
  • Igen ezt jól látod.
    Copy-val már kipróbáltam és müködik.

    Ezért gondoltam, hogy a For Each ciklust kellene valamire kicserélnem.
    De IMAP Email fióknál semmit nem találtam, ami müködne.
    Mutasd a teljes hozzászólást!
  • Folders.GetNext  ??

    A for each és a prev nem jó mert már nincs prev se.

    A for each helyett sima for vagy while ciklusban próbáld.

    Folders.GetNext method (Outlook)
    Move után a teszted szerint nem kell next, mivel automatikusan lép.
    Mutasd a teljes hozzászólást!
  • Hát ezt a metódust még nem ismertem.
    Kapásból még nem látom, hogy tudom beilleszteni.
    Egy kis idö kell a megértéséhez. Ha müködik, jövök vissza és utalom a pontot.

    Addig is köszi
    Mutasd a teljes hozzászólást!
  • Hát ez még mindig nem megy.

    Szóval, ami a probléma:

    Az olEmail-T ezzel határozom meg:

    For Each olEmail In SourceFolder.Items.Restrict("[UnRead] = True"
    Az atch pedig ezzel:

    For Each atch In olEmail.Attachments
    Ha kihagyom a két For Each ciklust, akkor valahogy SET-el meg kellene határoznom az olvasatlan Emailek mellékletének nevét.

    Mivel, hogy a feladat az, hogy nézze át az összes olvasatlan Emailt és csak azokat helyezze át, amelyeknek van melléklete és a mellékelt fájl neve az, amit keresek.

    Ha ezt meg tudom határozni, akkor bármelyik megoldás jó lehet, akár a GetNex, akár egy While Do, vagy akár a visszafelé léptetés.

    Ha nem IMAP fiók lenne, hanem Exchange, akkor elég sok megoldás müködne. De ebben az esetben egyszerüen nem találok megfelelöt.
    Mutasd a teljes hozzászólást!
  • Konkrétan azt nem tudom, ez miért nem müködik:

    Set olEmail = SourceFolder.Items.Restrict("[UnRead] = True") Set atch = olEmail.Attachments
    Így pedig elfogadja:

    For Each olEmail In SourceFolder.Items.Restrict("[UnRead] = True") For Each atch In olEmail.Attachments
    Mutasd a teljes hozzászólást!
  • Találtam valamit, amivel elvileg most müködik:

    Sub Move_Email() Dim SourceFolderRef As Outlook.MAPIFolder, SourceMailBoxName As String, Source_Pst_Folder_Name As String Dim olEmail As MailItem, MailsCount As Double SourceMailBoxName = "beispiel@gmx.net" Source_Pst_Folder_Name = "Beérkezett üzenetek" Set SourceFolder = Outlook.Session.Folders(SourceMailBoxName).Folders(Source_Pst_Folder_Name) If SourceFolder.Items.Restrict("[UnRead] = True").Count = 0 Then MsgBox "No Unread Email In Inbox" Exit Sub End If Set MoveToFolder = Outlook.Session.Folders(SourceMailBoxName).Folders(Source_Pst_Folder_Name).Folders("Beispiel") Linie1: For Each olEmail In SourceFolder.Items.Restrict("[UnRead] = True") If olEmail.Class <> olMail Then If TypeName(olEmail) = "MailItem" Then For Each atch In olEmail.Attachments If atch.Type = olByValue Then If InStr(UCase(atch.FileName), B) > 0 Then olEmail.Move MoveToFolder GoTo Linie1 End If End If Next atch End If End If Next olEmail End Sub
    Mi a véleményed erröl?
    Üdv,
    Balu
    Mutasd a teljes hozzászólást!
  • Ez kb egy exit for és ujrakezdi a ciklust eggyel kevesebb elemmel.
    Hátránya hogy a nem olvasott leveleken amik nem tartalmaznak megfelelő levelet mindig végigmegy,
    Mutasd a teljes hozzászólást!
  • Igazad van, de legalább biztos, hogy nem marad ki egyetlen Email sem.
    Nem a legjobb megoldás, ezért még nem zártam le a témát.
    De egyenlöre müködik.
    Egyébként köszönöm a sok infót és segítséget. Nélküled nem jutotta volna el idáig.

    Ha nincs újabb ötlet, akkor a pont mindenképpen a tiéd lesz.
    Köszi
    Mutasd a teljes hozzászólást!
  • Ez esetleg:

    A szűrés után

    olEmail =SourceFolder.Items.GetFirst

    majd a ckilusban

    olEmail =SourceFolder.Items.GetNext (Vagy FindNext) 

    Ha a Getnext üres értéket ad vissza akkor nincs több email.

    Ez itt egy másik példa a használatára:

    Set myNameSpace = Application.GetNamespace("MAPI")
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set myItems = myInbox.Items
    Set myDestFolder = myInbox.Folders("Personal Mail")
    Set myItem = myItems.Find("[SenderName] = 'Dan Wilson'")
    While TypeName(myItem) <> "Nothing"
    myItem.Move myDestFolder
    Set myItem = myItems.FindNext
    Mutasd a teljes hozzászólást!
Tetszett amit olvastál? Szeretnél a jövőben is értesülni a hasonló érdekességekről?
abcd