Witzker
Senior Member
- OS Version(s)
- iOS
- Outlook version
- Outlook 2019 32-bit
- Email Account
- Exchange Server 2007
Hi,
I have put together this macro
That sends an email template to the email address 1 inserts contact name and formats the title from an opened user defined contact form and put some text at the end of the form body in green:
Do you have some improvements to the code?
I have put together this macro
That sends an email template to the email address 1 inserts contact name and formats the title from an opened user defined contact form and put some text at the end of the form body in green:
Code:
Sub TestPlate() 'MAKRONAME eingeben
Dim textInFormular, VorlagenPfad, VorlageDateiname, VorlagenDatei, Nachricht, Adresse As String, Text, Format As String: Set item = ActiveInspector.CurrentItem
'Text der ins Formular geschrieben wird
'===================================================================================================== -> Function addTextToBody
addTextToBody "VERSCHICKT: TEXT Testplate" '<-HIER DEN Text in "TEXT..." eingeben der ins Formular geschrieben wird
'=====================================================================================================
'Name der Vorlagen DATEI xxxx.oft
'=====================================================================================================
VorlageDateiname = "TESTplate.oft" 'HIER DEN VORLAGEN NAMEN EINGEBEN am besten aus Explorer den Namen kopieren!
'=====================================================================================================
VorlagenPfad = "C:\Users\Public\- Cloud\- Outlook Vorlagen\" 'Pfad zum Vorlagen Ordner = FIX
VorlagenDatei = VorlagenPfad & VorlageDateiname
CreateEmail objMailItem, VorlagenDatei, item ' Function CreateEmail(objMailItem, VorlagenDatei, item) -> Create email and set recipient, categories, importance level
objMailItem.HTMLBody = GetRecipientName(item) + objMailItem.HTMLBody ' Function GetRecipientName(item) As String
objMailItem.Display
End Sub
Function addTextToBody(textInFormular As String)
Dim objItem As Object
Set objItem = Outlook.Application.ActiveInspector.CurrentItem
Dim objWordDoc As Word.Document
Set objWordDoc = objItem.GetInspector.WordEditor
Dim objWordApp As Word.Application
Set objWordApp = objWordDoc.Application
objWordApp.Selection.EndKey wdStory, wdMove
objWordApp.Selection.TypeText Text:=vbCrLf
objWordApp.Selection.Font.Color = RGB(0, 0, 255)
objWordApp.Selection.TypeText Text:=Format(Now, "dd.mm.yyyy hh:nn") & " " & textInFormular
objWordApp.Selection.TypeParagraph
objWordApp.Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
objWordApp.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
objWordApp.Selection.Font.Reset
End Function
Function CreateEmail(objMailItem, VorlagenDatei, item)
Dim objMailOLApp As Object
Set objMailOLApp = GetObject(, "Outlook.Application")
Set objMailItem = objMailOLApp.CreateItemFromTemplate(VorlagenDatei)
With objMailItem
.To = item.Email1Address 'Empfänger der Mail aus Kontakt lesen
.Categories = "Geschäftlich"
.Importance = olImportanceNormal
.BodyFormat = olFormatHTML
End With
End Function
Function GetRecipientName(item) As String
If item.Title = "" Then
GetRecipientName = "<HTML><BODY><FONT size=2 face=" & "'" & "Arial" & "'" & ">" & _
"Sehr geehrte Damen und Herren" & "," & "</FONT></BODY></HTML>"
ElseIf InStr(1, item.Title, "Herr") > 0 Then
GetRecipientName = "<HTML><BODY><FONT size=2 face=" & "'" & "Arial" & "'" & ">" & _
"Sehr geehrter" + " " + item.Title + " " + item.LastName + "," & "</FONT></BODY></HTML>"
ElseIf InStr(1, item.Title, "Frau") > 0 Then
GetRecipientName = "<HTML><BODY><FONT size=2 face=" & "'" & "Arial" & "'" & ">" & _
"Sehr geehrte" + " " + item.Title + " " + item.LastName + "," & "</FONT></BODY></HTML>"
Else
GetRecipientName = "<HTML><BODY><FONT size=2 face=" & "'" & "Arial" & "'" & ">" & _
"Sehr geehrte(r)" + " " + item.Title + " " + item.LastName + "," & "</FONT></BODY></HTML>"
End If
End FunctionDo you have some improvements to the code?
