0

少し問題がありました。誰かが私を助けてくれることを願っています。

(アウトルック 2010 VBA)

これは私の現在のコードです。必要なのは、メールをクリックしたときです（フォルダー/同じ場所のすべてのメールではなく、クリックしたメールのみ）。メールの送信者がすでに連絡先にあるかどうかを確認する必要がありますまたはアドレス帳の「すべてのユーザー」で、まだそれらのいずれでもない場合は、[連絡先の追加] ウィンドウを開いて、彼/彼女の情報を入力します。

まだ機能しないのは次のとおりです。

  • 最も重要なのは、メールをクリックしてもスクリプトが実行されないことです
  • 連絡先が既に存在するかどうかの現在のチェックは機能せず、vbMsgBox (はいまたはいいえと応答のもの) を使用します。これは、連絡先が既に存在する場合に必要なものではありません。

十分な情報を提供してくれたことを願っています。誰かがここで私を助けてくれます:)

Sub AddAddressesToContacts(objMail As Outlook.MailItem)
Dim folContacts As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim oNS As Outlook.NameSpace

''don't want or need a vbBox/ask box, this is a part of the current contactcheck
''wich doesn't work and is totaly wrong :P
Dim response As VbMsgBoxResult

Dim bContinue As Boolean
Dim sSenderName As String

On Error Resume Next

Set oNS = Application.GetNamespace("MAPI")
Set folContacts = oNS.GetDefaultFolder(olFolderContacts)
Set colItems = folContacts.Items

''this selects the mail that is currently selected.
''what i want is that the sender of the new incoming mail gets added to contacts
''(ofcourse, if that contact doesn't exsist yet)
''so the new incoming mail gotta be selected.
For Each obj In Application.ActiveExplorer.Selection

If obj.Class = olMail Then
Set oContact = Nothing

bContinue = True
sSenderName = ""

Set oMail = obj

sSenderName = oMail.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = oMail.SenderName
End If

Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")

''this part till the --- is wrong, i need someting to check if the contact (the sender)
''already exsists. Any ideas?
If Not (oContact Is Nothing) Then
    response = vbAbort
If response = vbAbort Then
    bContinue = False
End If
End If
''---------

If bContinue Then
Set oContact = colItems.Add(olContactItem)
With oContact

.Email1Address = oMail.SenderEmailAddress
.Email1DisplayName = sSenderName
.Email1AddressType = oMail.SenderEmailType
.FullName = oMail.SenderName

'.Save

oContact.Display

End With
End If
End If
Next

Set folContacts = Nothing
Set colItems = Nothing
Set oContact = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
End Sub

ねえ、まだ最後の質問があるんだけど、

'sets the name of the contact
    Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")

    'checks if the contact exsist, if it does exit the for loop
     If Not oContact Is Nothing Then
        Exit For
     End If
End If

これは、名前がすでに連絡先にあるかどうかを確認します。メールアドレスが連絡先にあるかどうかを確認する必要があります。それを手伝ってもらえますか?

私はこのようなことを念頭に置いていました

set oSendermail = ?the e-mailaddress?

         If Not oSendermail Is Nothing Then
            Exit For
         End If
End If
4

1 に答える 1

0

ソリューション (テスト ルーチンを含む) は次のようになります: (外部 SMTP メールのみを考慮すると仮定します。連絡先フォルダーへのパスを調整し、エラー チェックを追加します!)

Option Explicit

Private Declare Function GetTickCount Lib "kernel32.dll" () As Long

Sub AutoContactMessageRule(newMail As Outlook.mailItem)
    '  "script" routine to be called for each incoming Mail message
    '  This subroutine has to be linked to this mail type using 
    '  Outlook's rule assistant
    Dim EntryID As String
    Dim StoreID As Variant
    Dim mi As Outlook.mailItem
    Dim contactFolder As Outlook.Folder
    Dim contact As Outlook.ContactItem

    On Error GoTo ErrorHandler

    '  we have to access the new mail via an application reference
    '  to avoid security warnings
    EntryID = newMail.EntryID
    StoreID = newMail.Parent.StoreID

    Set mi = Application.Session.GetItemFromID(EntryID, StoreID)

    With mi
        If .SenderEmailType = "SMTP" Then
            Set contactFolder = FindFolder("Kemper\_local\TestContacts")

            Set contact = contactFolder.items.Find("[Email1Address]=" & Chr(34) & .SenderEmailAddress & Chr(34))
            If Not TypeName(contact) <> "Nothing" Then
                Set contact = contactFolder.items.Add(olContactItem)
                contact.Email1Address = .SenderEmailAddress
                contact.Email1AddressType = .SenderEmailType
                contact.FullName = .SenderName
                contact.Save
            End If
        End If
    End With

    Exit Sub

ErrorHandler:
    MsgBox Err.Description, vbCritical, "Ooops!"
    Err.Clear
    On Error GoTo 0
End Sub


Private Function FindFolder(path As String) As Outlook.Folder
'  Locate MAPI Folder.
'  Separate sub-folder using '/' . Example: "My/2012/Letters"
    Dim fd As Outlook.Folder
    Dim subPath() As String
    Dim I As Integer
    Dim ns As NameSpace
    Dim s As String

    On Error GoTo ErrorHandler

    s = Replace(path, "\", "/")

    If InStr(s, "//") = 1 Then
        s = Mid(s, 3)
    End If

    subPath = Split(s, "/", -1, 1)
    Set ns = Application.GetNamespace("MAPI")

    For I = 0 To UBound(subPath)
      If I = 0 Then
        Set fd = ns.Folders(subPath(0))
      Else
        Set fd = fd.Folders(subPath(I))
      End If
      If fd Is Nothing Then
        Exit For
      End If
    Next

    Set FindFolder = fd
    Exit Function

ErrorHandler:
    Set FindFolder = Nothing
End Function


Public Sub TestAutoContactMessageRule()
    '  Routine to test Mail Handlers AutoContactMessageRule()'
    '  without incoming mail messages
    '  select an existing mail before executing this routine
    Dim objItem As Object
    Dim objMail As Outlook.mailItem
    Dim started As Long

    For Each objItem In Application.ActiveExplorer.Selection
        If TypeName(objItem) = "MailItem" Then
            Set objMail = objItem

            started = GetTickCount()
            AutoContactMessageRule objMail

            Debug.Print "elapsed " & (GetTickCount() - started) / 1000# & "s"
        End If
    Next
End Sub
于 2013-02-26T12:32:47.563 に答える