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