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@
arçelik.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@VESTEL.com.tr---------->"VESTEL"
kisi.adi@SAMSUNG.com.tr
---------->"SAMSUNG"
Bu taşıma işlemi için
Vba yazılabilir mi?
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