Select one of Contact-Mailadesses to Export > Excel or Winword

[HDWTIGER]

Hi, i need help for an VBA-Script in Outlook 2010. I find no Contactfield in VBA Contact.Item exists to export the currentitem selected Mailadress of an Outlook Contactform to Export > WinWord or Excel. Is there any way to an Diaolog to select or pic up one of the 3 Mailadresses of an Outlookcontact befor run the Export?

Email1Address
Email2Address
Email3Address

Greetings from Germany...
Hans Dieter

 

[Diane Poremsky]

I'm not sure I understand the problem, the 3 addresses are .Email1Address, .Email2Address, .Email3Address

This is from my "super duper bulk contacts" macro - it displays the name and email addresses of each contact in the default contacts folder.

Public Sub ChangeEmailDisplayName()
    Dim objOL As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim objContact As Outlook.ContactItem
    Dim objItems As Outlook.Items
    Dim objContactsFolder As Outlook.MAPIFolder
    Dim obj As Object
    Dim strFirstName As String
    Dim strLastName As String
    Dim strFileAs As String
    On Error Resume Next
    Set objOL = CreateObject("Outlook.Application")
    Set objNS = objOL.GetNamespace("MAPI")
    Set objContactsFolder = objNS.GetDefaultFolder(olFolderContacts)
    Set objItems = objContactsFolder.Items
    For Each obj In objItems
        'Test for contact and not distribution list
        If obj.Class = olContact Then
            Set objContact = obj
          With objContact
             MsgBox .FullName & .Email1Address & .Email2Address & .Email3Address
          End With
        End If
        Err.Clear
    Next
    Set objOL = Nothing
    Set objNS = Nothing
    Set obj = Nothing
    Set objContact = Nothing
    Set objItems = Nothing
    Set objContactsFolder = Nothing
End Sub

 

[HDWTIGER]

Hi Diana, many thanks for your request an your examplecode. I send you my code maybe you have an idea of an Workaround ;-) ? The Problem is... Some of Contacts have 2 or 3 Mailadresses. In this case i am not found a field in VBA
to pic up the selected Mailadress. To fix these Problem .... Show an dialog to pic up one of thes Mailadresses an give the value Email1Address or Email2Address or Email3Address to the Codesection...

If objContact.XXXX1 = 1 Then strFields(4) = objContact.Email1Address
If objContact.XXXX2 = 2 Then strFields(4) = objContact.Email2Address
If objContact.XXXX3 = 3 Then strFields(4) = objContact.Email3Address

In hope you/one have an idea to fix my Problem...
Greetings from Germany Hans Dieter

Public Sub KontaktWord()
Dim Fehler
Dim i As Integer
Dim strFields() As String
Dim strOutput As String
Dim strOutput1 As String
Dim strOutput2 As String
Dim strOutput3 As String
Dim strOutput4 As String
Dim objApp As Application
Dim objNS As NameSpace
Dim objWord As Word.Application
Dim objWordDoc As Word.Document
Dim pfad As String
Dim objContact As ContactItem

'Wenn Outlook und Kontakt nicht geöffnet, dann geht auch nicht!
On Error GoTo Ausgang
Set objApp = Outlook.Application
Set objNS = objApp.GetNamespace("MAPI")
Set objContact = objApp.ActiveInspector.currentItem 'wichtig: das ist das gerade geöffnete ContactItem!

'Benutzerfelder vom OL-Konatkt auf die Variablen zuordnen
ReDim strFields(0 To 4)

'Die Felder kann man dann einzeln ansprechen
With objContact
strFields(0) = .User2 ' KontakAdresse komplett
strFields(1) = .User3 ' Nur Anrede
strFields(2) = .User4 ' Nur Name
' Faxnummer festlegen, je nach Inhalt
If Trim(objContact.OtherFaxNumber) <> "" Then strFields(3) = objContact.OtherFaxNumber
If Trim(strFields(3)) = "" Then strFields(3) = objContact.BusinessFaxNumber
If Trim(strFields(3)) = "" Then strFields(3) = objContact.HomeFaxNumber
' Selected Mailadresse auslesen
If objContact.XXXX1 = 1 Then strFields(4) = objContact.Email1Address
If objContact.XXXX2 = 2 Then strFields(4) = objContact.Email2Address
If objContact.XXXX3 = 3 Then strFields(4) = objContact.Email3Address
End With

'Oder sie meinetwegen auch zusammenfassen:
For i = 0 To UBound(strFields)
strOutput = strFields(0)
strOutput1 = strFields(1)
strOutput2 = strFields(2)
strOutput3 = strFields(3)
strOutput4 = strFields(4)
Next

' Aktiven Kontakt schließen
objContact.Close olPromptForSave 'und ggf. zum Speichern nachfragen
objApp.ActiveWindow.WindowState = olMinimized 'minimiert Outlook damit Word sichtbar wird

On Error Resume Next ' Fehlerroutine einschalten
Set objWordDoc = GetObject(, "Word.Application") 'Word Instanz suchen
Fehler = Err.Number
On Error GoTo 0 'Fehlerroutine wieder zurücksetzen
If Fehler = 429 Then
Set objWord = CreateObject("Word.Application") 'Word Instanz generieren
objWord.Visible = True 'Sichtbar machen
End If

Set objWord = GetObject(, "Word.Application") 'Word Instanz verbinden
objWord.Activate 'Wordinstanz sichtbar machen
objWord.Run MacroName:="Vorlagenshow" 'Vorlagenauswahl öffnen

'.WindowState = 1 'Fenster maximieren
On Error GoTo Ausgang 'Fehlerbehandlung falls Word beendet wird

' Dialog Vorlage öffnen und Vorlage auswählen lassen
'With objWord.Dialogs(wdDialogFileNew)
' .Display
' pfad = .Template
'End With

' Kontaktvariableninhalt der Textmarke zuordnen
Set objWordDoc = objWord.ActiveDocument

If objWordDoc.Bookmarks.Exists("tmUser2") Then
With objWordDoc
.Bookmarks("tmUser2").Range.Text = strOutput
.Activate
End With
Else
With objWordDoc
.Parent.Selection.Range.Text = strOutput
.Activate
End With
End If
If objWordDoc.Bookmarks.Exists("tmUser3") Then
With objWordDoc
.Bookmarks("tmUser3").Range.Text = strOutput1
.Activate
End With
End If
If objWordDoc.Bookmarks.Exists("tmUser4") Then
With objWordDoc
.Bookmarks("tmUser4").Range.Text = strOutput2
.Activate
End With
End If
If objWordDoc.Bookmarks.Exists("tmUser5") Then
With objWordDoc
.Bookmarks("tmUser5").Range.Text = strOutput4
.Activate
End With
End If
If objWordDoc.Bookmarks.Exists("tmFax") Then
With objWordDoc
.Bookmarks("tmFax").Range.Text = strOutput3
.Activate
End With
End If
If objWordDoc.Bookmarks.Exists("tmSubject") Then
With objWordDoc
'.Bookmarks("tmSubject").Range.Text = "Angebot: " 'Betreffzeile einfügen
.Bookmarks("tmSubject").Range.Select 'zur Betreffzeile springen
.Activate

End With
End If

Ausgang:
' Objektvariablen freigeben
Set objWordDoc = Nothing
Set objWord = Nothing
Set objApp = Nothing
Set objNS = Nothing
Set objContact = Nothing
End Sub