VBATools

Kiedy nie wyciągnięta kolumna “Firma” z “wszystkie pola kontaktów” nie wskazują reprezentacje adresata wiadomości można użyć makro, które w procesie wskazania wiadomości pobierze nazwy firm zapisane w gł. folderze kontaktów.

Najpierw należy uruchamiać procedurę, a potem wyciągnąć z magazynu “Pola zdefiniowane przez użytkownika..” pole Fima X.
Proces ten należy wykonać jednorazowo (dla każdego folderu w którym zostanie użyta procedura).

Procedurę “Dodaj_pole” można też wyciągnąć na pasek zgodnie z poradą: Uruchamianie makr przyciskiem na pasku narzędzi

Option Explicit
'MVP OShon from VBATools.pl
 Dim oApp As New Outlook.Application
 Dim oExp As Outlook.Explorer
 Dim oSel As Outlook.Selection
 Dim oItem As Object
 Dim oItems As Items
 Dim x&, pole$, max_items&, Tematy$, firma$
 Dim strMessageClass As String
 Dim oMailItem As Outlook.MailItem
 Dim oContactFolder As MAPIFolder
 Dim oContact As ContactItem
 Dim oProperty As UserProperty
 Dim oFolder As MAPIFolder

Sub Dodaj_pole()
 Set oExp = oApp.ActiveExplorer
 pole = MsgBox("Czy przetworzyć zaznaczone wiadomości? naciśnij ''TAK''" & vbCr _
 & "Czy wszystkie wiadomości z obecnego folderu? naciśnij ''NIE''" & vbCr _
 & "Aby anulować operacje naciśnij ''Anuluj''", _
 vbMsgBoxSetForeground + vbYesNoCancel + vbQuestion, "Dodawanie firm do pola kolumny")

 If pole = vbYes Then
 Set oSel = oExp.Selection
 max_items = oSel.Count
 ElseIf pole = vbNo Then
 Set oFolder = oExp.CurrentFolder
 max_items = oFolder.Items.Count
 Else
 MsgBox "Operacje anulowano",vbInformation ,"Machine by OShon": GoTo koniec
 End If

 For x = 1 To max_items
 If pole = vbYes Then Set oItem = oSel.item(x)
 If pole = vbNo Then Set oItem = oFolder.Items(x)
 Call AddNoteInfo(oItem, "Firmax")
 Next x
koniec:
 If Not oExp Is Nothing Then Set oExp = Nothing
 If Not oSel Is Nothing Then Set oSel = Nothing
 If Not oItem Is Nothing Then Set oItem = Nothing
End Sub

Private Sub AddNoteInfo(oItem As Object, Nazwa_pola As String)
 strMessageClass = oItem.MessageClass

 If (strMessageClass = "IPM.Note") Then
 Set oMailItem = oItem
 Tematy = oMailItem.Subject
 On Error Resume Next
 oProperty = oItem.UserProperties(Nazwa_pola)
 On Error GoTo 0

 If oProperty Is Nothing Then _
 oItem = oMailItem.UserProperties.Add(Nazwa_pola, olText)

 firma = FindContact_TakeFirmName(oMailItem.SenderEmailAddress)

 If Len(firma) > 0 Then
 oMailItem.UserProperties.item(Nazwa_pola).value = firma
 oItem.Save
 Else
 oMailItem.UserProperties.item(Nazwa_pola).Delete
 End If

 oMailItem.Subject = Tematy 'gubi temat wiec nadpisujemy
 oItem.Save
 If Not oMailItem Is Nothing Then Set oMailItem = Nothing
 End If
End Sub

Function FindContact_TakeFirmName(adres$) As String
 Set oContactFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
 Set oItems = oContactFolder.Items

 FindContact_TakeFirmName = ""
 adres = """" & adres & """"

 On Error GoTo dalej
 Set oContact = oItems.Find("[Email1Address] =" & adres & " or " & _
 "[Email2Address] =" & adres & " or [Email3Address] =" & adres & "")

 While Not oContact Is Nothing
 DoEvents
 FindContact_TakeFirmName = oContact.CompanyName
 GoTo dalej
 Wend
dalej:
On Error Resume Next
 If Not oContact Is Nothing Then Set oContact = Nothing
 If Not oItems Is Nothing Then Set oItems = Nothing
End Function

Aby zobaczyć, jak osadzić procedurę „Dodaj_pole” pod przyciskiem w menu MS Outlook, polecam uwadze artykuł Instalacja i uruchamianie makr.

(c) Shon Oskar – www.VBATools.pl