Witzker
Senior Member
- OS Version(s)
- iOS
- Outlook version
- Outlook 2019 32-bit
- Email Account
- Exchange Server 2007
Hi, troubles to get the template path into a function
I have a Macro that should send an email template to the already opened contact Fill in Email and name open it for editing and send it
without the new function, it worx like this:
needed functions working:
so far so gud
now I want to replace as much as possible in an additional function that the macro is as small as possible, and I can copy it and use it to send other template emails.
Here is the edited macro with the added function that does not work:
when I call the macro, I get:
the path is correct
BUT THAN
The template must be accessible because it worx with the first macro above.
Hope everything is clear?!
PLS. Help to get this working.
Many THX
I have a Macro that should send an email template to the already opened contact Fill in Email and name open it for editing and send it
without the new function, it worx like this:
Code:
Sub TESTplate_0() 'Makro name wichtig zum aufrufen Der Name des Makros muss der Syntax von Makronamen entsprechen, es wird dann auch so in dropdown angezeigt
'Betreff und eventuelle Anlagen werden in der Vorlage definiert und sind dann mit der Vorlage gespeichert
'Variablen dimm
Dim textInFormular
Dim VorlagenPfad
Dim VorlageDateiname
Dim VorlagenDatei
Dim Nachricht
Dim Adresse As String
Dim Text
Dim Format As String
Set item = ActiveInspector.CurrentItem
'Text der in Kontaktformular geschrieben wird in die variable eingegeben und an die Funktion addTextToBody übergeben
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
addTextToBody "VERSCHICKT: TEXT " '<---------
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'Pfad zur Vorlage Eingeben !! ist bei uns auf allen Rechnern gleich, sonst anpassen
VorlagenPfad = "C:\Users\Public\- Cloud\- Outlook Vorlagen\" '--> Vorlage Dateinamen Eingeben !! am besten Namen mit .oft von Vorlage aus explorer kopieren
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
VorlageDateiname = "TESTplate.oft" '<---------
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
VorlagenDatei = VorlagenPfad & VorlageDateiname
Dim objMailItem As Object
Dim objMailOLApp As Object
Set objMailOLApp = GetObject(, "Outlook.Application")
Set objMailItem = objMailOLApp.CreateItemFromTemplate(VorlagenDatei)
'---Empfänger Email aus Kontakt lesen ----------------------------------------------------------------------------
With objMailItem
.To = item.Email1Address 'Empfänger der Mail aus Kontakt lesen
.Categories = "Geschäftlich"
.Importance = olImportanceNormal
.BodyFormat = olFormatHTML
End With
'---Empfänger Anrede und Namen aus Konakt lesen und einfügen ----------------------------------------------------
Adresse = ReadName()
objMailItem.HTMLBody = Adresse + objMailItem.HTMLBody
objMailItem.Display
End Sub
needed functions working:
Code:
Function ReadName() As String
Dim item As Object
Set item = ActiveInspector.CurrentItem
If item.title = "" Then
ReadName = "<HTML><BODY><FONT size=2 face=" & "'" & "Arial" & "'" & ">" & _
"Sehr geehrte Damen und Herren" & "," & "</FONT></BODY></HTML>"
ElseIf InStr(1, item.title, "Herr") > 0 Then
ReadName = "<HTML><BODY><FONT size=2 face=" & "'" & "Arial" & "'" & ">" & _
"Sehr geehrter" + " " + item.title + " " + item.lastName + "," & "</FONT></BODY></HTML>"
ElseIf InStr(1, item.title, "Frau") > 0 Then
ReadName = "<HTML><BODY><FONT size=2 face=" & "'" & "Arial" & "'" & ">" & _
"Sehr geehrte" + " " + item.title + " " + item.lastName + "," & "</FONT></BODY></HTML>"
Else
ReadName = "<HTML><BODY><FONT size=2 face=" & "'" & "Arial" & "'" & ">" & _
"Sehr geehrte(r)" + " " + item.title + " " + item.lastName + "," & "</FONT></BODY></HTML>"
End If
End Function
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:mm") & ": "
objWordApp.Selection.TypeText Text:=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
now I want to replace as much as possible in an additional function that the macro is as small as possible, and I can copy it and use it to send other template emails.
Here is the edited macro with the added function that does not work:
Code:
Sub TESTplate_1()
'Variablen dimm
Dim textInFormular
Dim VorlagenPfad As String
Dim VorlageDateiname As String
Dim Nachricht
Dim Adresse As String
Dim Text
Dim Format As String
Set item = ActiveInspector.CurrentItem
'Text der in Kontaktformular geschrieben wird in die variable eingegeben und an die Funktion addTextToBody übergeben
addTextToBody "VERSCHICKT: TEXT " '<---------
'Pfad zur Vorlage Eingeben !! ist bei uns auf allen Rechnern gleich, sonst anpassen
VorlagenPfad = "C:\Users\Public\Cloud\Outlook Vorlagen"
'Vorlage Dateinamen Eingeben !! am besten Namen mit .oft von Vorlage aus explorer kopieren
VorlageDateiname = "TESTplate.oft"
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
VorlagenDatei = fso.BuildPath(VorlagenPfad, VorlageDateiname)
Dim objMailItem As Object
Set objMailItem = CreateEmailFromTemplate(VorlagenPfad, VorlageDateiname)
'Empfänger Anrede und Namen aus Konakt lesen und einfügen
Adresse = ReadName()
objMailItem.HTMLBody = Adresse + objMailItem.HTMLBody
objMailItem.Display
End Sub
Function CreateEmailFromTemplate(VorlagenPfad As String, VorlageDateiname As String) As Object
Dim objMailItem As Object
Dim objMailOLApp As Object
Dim VorlagenDatei As String
VorlagenDatei = VorlagenPfad & "\" & VorlageDateiname
'Debug.Print VorlagenDatei
MsgBox VorlagenDatei
Set objMailOLApp = GetObject(, "Outlook.Application")
Set objMailItem = objMailOLApp.CreateItemFromTemplate(VorlagenDatei)
With objMailItem
.To = item.Email1Address
.Categories = "Geschäftlich"
.Importance = olImportanceNormal
.BodyFormat = olFormatHTML
End With
Set CreateEmailFromTemplate = objMailItem
End Function
when I call the macro, I get:
the path is correct
BUT THAN
The template must be accessible because it worx with the first macro above.
Hope everything is clear?!
PLS. Help to get this working.
Many THX