Set MyOutApp = CreateObject("Outlook.Application")
Public Sub Mail_Outlook_With_Signature_Html_9()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(1)
With OutMail
.Display
.Subject = "Jahr_Monat_Tag_Kick-off_8Dxx-x - Kennwort/ Land - LIPROGIS XXXX Circuit - _
Einladung"
.Body = "Guten Tag,
" & _
"ich möchte Sie zum Eng. Handshake zu folgendem Projekt einladen." & _
RangeToHtml("Einladung_Kick-Off", "A1:I62") & .Body
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Public Sub Mail_Outlook_With_Signature_Html_9()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(1)
With OutMail
.Display
.Subject = "Jahr_Monat_Tag_Kick-off_8Dxx-x - Kennwort/ Land - LIPROGIS XXXX Circuit - _
Einladung"
.HTMLBody = "Guten Tag, mein Name ist Heidi Martin und ich weiß nix mehr!
" & _
"ich möchte Sie zum Eng. Handshake zu folgendem Projekt einladen." & _
RangeToHtml("Einladung_Kick-Off", "A1:I62") & .HTMLBody
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Private Function RangeToHtml( _
ByVal pvstrWorksheetName As String, _
ByVal pvstrRangeAddress As String) As String
Dim objFilesytem As Object, objTextstream As Object
Dim objPublishObject As PublishObject
Dim strFilename As String, strTempText As String
strFilename = Environ$("temp") & "\" & _
Format(Now, "dd-mm-yy_hh-mm-ss") & ".htm"
Set objPublishObject = ThisWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=strFilename, _
Sheet:=pvstrWorksheetName, _
Source:=pvstrRangeAddress, _
HtmlType:=xlHtmlStatic)
Call objPublishObject.Publish(Create:=True)
Set objFilesytem = CreateObject("Scripting.FileSystemObject")
Set objTextstream = objFilesytem.GetFile(strFilename).OpenAsTextStream(1, -2)
strTempText = objTextstream.ReadAll
Call objTextstream.Close
RangeToHtml = Replace(strTempText, "align=center x:publishsource=", _
"align=left x:publishsource=")
Set objPublishObject = Nothing
Set objTextstream = Nothing
Set objFilesytem = Nothing
Call Kill(PathName:=strFilename)
End Function
Public Sub Mail_Outlook_With_Signature_Html_9()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(1)
With OutMail
.Display
.Location = "wird noch bekannt gegeben"
.Subject = "Jahr_Monat_Tag_Kick-off_8Dxx-x - Kennwort/ Land - LIPROGIS XXXX Circuit - _
Einladung"
.Body = "Guten Tag, mein Name ist Hase ich weiß Bescheid!
" & _
"ich möchte Sie zum Eng. Handshake zu folgendem Projekt einladen." & _
RangeToHtml("Einladung_Kick-Off", "A1:I62") & .Body
.Recipients.Add("max.mustermann@xxx.xxx").Type = 1
.Recipients.Add("max.mustermann@xxx.xxx").Type = 2
.Recipients.Add("max.mustermann@xxx.xxx").Type = 3
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Option Explicit
' Einige Konstanten
Const olMailItem = 0
Const olAppointmentItem = 1
Const olFormatHTML = 2
Const olDiscard = 1
Private Sub CreateAppointment()
Dim objOutLook As Object
Dim objMail As Object
Dim objApp As Object
Dim objMailInspector As Object
Dim objAppInspector As Object
Dim freeText As String
On Error Resume Next
Set objOutLook = GetObject(, "Outlook.Application")
If objOutLook Is Nothing Then
Set objOutLook = CreateObject("Outlook.Application")
End If
On Error GoTo 0
If Not objOutLook Is Nothing Then
freeText = "Guten Tag, mein Name ist Hase ich weiß Bescheid!" & vbCrLf ' anpassen!!
Set objMail = objOutLook.CreateItem(olMailItem)
With objMail
.BodyFormat = olFormatHTML
.HtmlBody = freeText & RangeToHtml("Beispiel", "B3:I15") ' anpassen!!
Set objMailInspector = .GetInspector
End With
Set objApp = objOutLook.CreateItem(olAppointmentItem)
With objApp
.Location = "wird noch bekannt gegeben"
.Subject = "Jahr_Monat_Tag_Kick-off_8D"
.Recipients.Add("max.mustermann@xxx.xxx").Type = 1
Set objAppInspector = .GetInspector
objAppInspector.Wordeditor.Range.FormattedText = objMailInspector.Wordeditor.Range.FormattedText
.Display
End With
objMail.Close (olDiscard)
Else
MsgBox "Auf diesem PC/Notebook ist kein Outlook installiert!", _
vbMsgBoxSetForeground + 16, "zur Information..."
End If
Set objOutLook = Nothing
Set objMail = Nothing
Set objAppInspector = Nothing
Set objMailInspector = Nothing
End Sub
Private Function RangeToHtml(ByVal pvstrWorksheetName As String, _
ByVal pvstrRangeAddress As String) As String
Dim objFilesytem As Object
Dim objTextstream As Object
Dim objPublishObject As PublishObject
Dim strFilename As String
Dim strTempText As String
strFilename = Environ$("temp") & "\" & _
Format(Now, "dd-mm-yy_hh-mm-ss") & ".htm"
Set objPublishObject = ThisWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=strFilename, _
Sheet:=pvstrWorksheetName, _
Source:=pvstrRangeAddress, _
HtmlType:=xlHtmlStatic)
Call objPublishObject.Publish(Create:=True)
Set objFilesytem = CreateObject("Scripting.FileSystemObject")
Set objTextstream = objFilesytem.GetFile(strFilename).OpenAsTextStream(1, -2)
strTempText = objTextstream.ReadAll
Call objTextstream.Close
RangeToHtml = Replace(strTempText, "align=center x:publishsource=", _
"align=left x:publishsource=")
Set objPublishObject = Nothing
Set objTextstream = Nothing
Set objFilesytem = Nothing
Call Kill(PathName:=strFilename)
End Function
With objMail
.BodyFormat = olFormatHTML
.HtmlBody = freeText & RangeToHtml("Beispiel", "B3:I15") ' anpassen!!
Set objMailInspector = .GetInspector
.display ' Diese Zeile einfügen
End With
Const olMeeting = 1
Set objAppInspector = .GetInspector
objAppInspector.Wordeditor.Range.FormattedText = objMailInspector.Wordeditor.Range.FormattedText
.MeetingStatus = olMeeting ' Bitte einfügen
.display
Option Explicit
' Einige Konstanten
Const olMailItem = 0
Const olAppointmentItem = 1
Const olFormatHTML = 2
Const olDiscard = 1
Const olMeeting = 1
Sub CreateAppointment()
Set objApp = objOutLook.CreateItem(olAppointmentItem)
With objApp
.Location = "wird noch bekannt gegeben"
.Subject = "Jahr_Monat_Tag_Kick-off_8D"
.Recipients.Add("max.mustermann@xxx.xxx").Type = 1
Set objAppInspector = .GetInspector
objAppInspector.Wordeditor.Range.FormattedText = objMailInspector.Wordeditor.Range.FormattedText
.MeetingStatus = olMeeting ' Bitte einfügen
.display
End With
objMail.Close (olDiscard)
Private Function RangeToHtml(ByVal pvstrWorksheetName As String, _
ByVal pvstrRangeAddress As String) As String
Dim objFilesytem As Object
Dim objTextstream As Object
Dim objPublishObject As PublishObject
Dim strFilename As String
Dim strTempText As String
strFilename = Environ$("temp") & "\" & _
Format(Now, "dd-mm-yy_hh-mm-ss") & ".htm"
Set objPublishObject = ThisWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=strFilename, _
Sheet:=pvstrWorksheetName, _
Source:=pvstrRangeAddress, _
HtmlType:=xlHtmlStatic)
Call objPublishObject.Publish(Create:=True)
Set objFilesytem = CreateObject("Scripting.FileSystemObject")
Set objTextstream = objFilesytem.GetFile(strFilename).OpenAsTextStream(1, -2)
strTempText = objTextstream.ReadAll
Call objTextstream.Close
RangeToHtml = Replace(strTempText, "align=center x:publishsource=", _
"align=left x:publishsource=")
Set objPublishObject = Nothing
Set objTextstream = Nothing
Set objFilesytem = Nothing
Call Kill(PathName:=strFilename)
End Function