Skip to main content

AccessTr.neT


Outlook Vba Yazma

conquerora
conquerora
1
155

Outlook Vba Yazma

Rainbow #1
Merhaba 

konuyu buraya açarak doğrumu yaptım bilmiyorum ama admin ilgili alana taşıyabilir.
Outlook 2016 kullanıyorum.
Gelen kutusunda maillerimi düzenlemek için belirli klasörlere outlook kuralları ile taşıma yapıyorum.
Ama kuralların da bir sınırı varmış. Kullar çalışmıyor.
 
Yapmak istediğim şu;

gönderenin mail adresinde kisi.adi@arcelik.com.tr yer alan "@" sonra ki alan adına göre ilgili klasöre "ARÇELİK" taşımasını istiyorum.
kisi.adi@arcelik.com.tr---------->"ARÇELİK"
kisi.adi@[b]VESTEL.com.tr[b]---------->"[b][b]VESTEL[/b][/b][/b][/b][b][b]"[/b][/b]
kisi.adi@[b][b][b][b]SAMSUNG[/b][/b][/b][/b][b].com.tr[b]---------->"SAMSUNG"[/b][/b]

Bu taşıma işlemi için Vba yazılabilir mi?
07-08-2009 tarihinden beri AccessTr.neT üyesidir.
Son Düzenleme: 30/06/2020, 08:53, Düzenleyen: conquerora.
Cevapla
#2
merhaba

E-posta taşıma ile alakalı bir kod buldum.
Bu kod yığını sadece belirti tarihe kadar belirli klasöre taşıma yapıyor.
Yapmak istediğim gelen kutusundaki maillerin ilgili gelen kutusu alt klasörlerine taşınması.

2.2. E-postayı belirtilen klasöre taşımak için makro
E-postamı uzun zaman önce elle sıralamaktan vazgeçtim. Şimdi tüm e-postalarımı üç aylık bir klasöre taşıyorum. Arama postaları bir masaüstü arama motoru aracılığıyla yapılır, örneğin Google masaüstü araması.
Aşağıdaki makro, seçilen bir veya daha fazla e-postayı belirtilen bir klasöre taşıyacaktır. Bu klasör mevcut olmalıdır.

Kod:
Sub MoveSelectedMessagesToToDo()

On Error Resume Next
    Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder

    Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem

    Set objNS = Application.GetNamespace("MAPI")

    Set objInbox = objNS.GetDefaultFolder(olFolderInbox)

   ' MUST CHANGE THE OUTPUT FOLDER
   ' Assume this is a mail folder
    Set objFolder = GetFolder("10_Offline\_00_to_do")
    ' In case you would like to move to a subfolder in the inbox
    'Set objFolder = objInbox.Folders.Item("Done")


    If objFolder Is Nothing Then
        MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, "INVALID FOLDER"
    End If

    If Application.ActiveExplorer.Selection.Count = 0 Then
        'Require that this procedure be called only when a message is selected
        Exit Sub
    End If


    For Each objItem In Application.ActiveExplorer.Selection
        If objFolder.DefaultItemType = olMailItem Then
            If objItem.Class = olMail Then
                objItem.Move objFolder
            End If
        End If
    Next

    Set objItem = Nothing
    Set objFolder = Nothing
    Set objInbox = Nothing
    Set objNS = Nothing

End Sub



Sub MoveSelectedMessagesToFolder()

On Error Resume Next
    Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder

    Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem

    Set objNS = Application.GetNamespace("MAPI")

    Set objInbox = objNS.GetDefaultFolder(olFolderInbox)

   ' MUST CHANGE THE OUTPUT FOLDER
   ' Assume this is a mail folder
    Set objFolder = GetFolder("2009\Q4")



    If objFolder Is Nothing Then
        MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, "INVALID FOLDER"
    End If

    If Application.ActiveExplorer.Selection.Count = 0 Then
         MsgBox "Nothing selected", vbOKOnly + vbExclamation, "No message selected"
        Exit Sub
    End If


    For Each objItem In Application.ActiveExplorer.Selection
        If objFolder.DefaultItemType = olMailItem Then
            If objItem.Class = olMail Then
                objItem.Move objFolder
            End If
        End If
    Next

    Set objItem = Nothing
    Set objFolder = Nothing
    Set objInbox = Nothing
    Set objNS = Nothing

End Sub


Public Function GetFolder(strFolderPath As String) As MAPIFolder
  ' folder path needs to be something like
  '   "Public Folders\All Public Folders\Company\Sales"
  Dim objApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim colFolders As Outlook.Folders
  Dim objFolder As Outlook.MAPIFolder
  Dim arrFolders() As String
  Dim I As Long
  On Error Resume Next

  strFolderPath = Replace(strFolderPath, "/", "\")
  arrFolders() = Split(strFolderPath, "\")
  Set objApp = CreateObject("Outlook.Application")
  Set objNS = objApp.GetNamespace("MAPI")
  Set objFolder = objNS.Folders.Item(arrFolders(0))
  If Not objFolder Is Nothing Then
    For I = 1 To UBound(arrFolders)
      Set colFolders = objFolder.Folders
      Set objFolder = Nothing
      Set objFolder = colFolders.Item(arrFolders(I))
      If objFolder Is Nothing Then
        Exit For
      End If
    Next
  End If

  Set GetFolder = objFolder
  Set colFolders = Nothing
  Set objNS = Nothing
  Set objApp = Nothing
End Function

07-08-2009 tarihinden beri AccessTr.neT üyesidir.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da