gerry1506
10-15-2014, 05:26 AM
Hi!
To create and send reports I use currently an Access (2003) database. After creating, the reports are automatically sent via Outlook. Currently I am using a function that is built into "This Outlook Session" (see below).
Public Function SendMailWithOutSafe(Optional strTo As String = "", _
Optional strCC As String = "", _
Optional strBCC As String = "", _
Optional strSubject As String = "", _
Optional strMessageBody As String = "", _
Optional strAttachments As String = "", _
Optional strTempFileSpez As String = "", _
Optional bSave As Boolean) As Long
'Funktion zum Senden von Mails ohne Windows Sicherheitsabfrage
'bSave = True >>> Entwurf wird gespeichert Version 1.1 Feb.2014
Dim lRet As Long
Dim oOlApp As Outlook.Application
Dim oOlRec As Outlook.Recipient
Dim oOLMail As Outlook.MailItem
Dim bWithTemplate As Boolean
Dim sTemp As String
On Error GoTo ErrHandler
Do
lRet = 0
bWithTemplate = False
If oOlApp Is Nothing Then Set oOlApp = Outlook.Application
If strTempFileSpez <> "" Then
If InStr(strTempFileSpez, Dir(strTempFileSpez)) > 0 Then
If oOLMail Is Nothing Then
Set oOLMail = oOlApp.CreateItemFromTemplate(strTempFileSpez)
bWithTemplate = True
' es werden nur noch die Anlagen angehangen
End If
End If
End If
If oOLMail Is Nothing Then Set oOLMail = oOlApp.CreateItem(olMailItem)
With oOLMail
'Empfänger
If strTo <> "" Then
Set oOlRec = .Recipients.Add(strTo)
oOlRec.Type = olTo
End If
If strCC <> "" Then
Set oOlRec = .Recipients.Add(strCC)
oOlRec.Type = olCC
End If
If strBCC <> "" Then
Set oOlRec = .Recipients.Add(strBCC)
oOlRec.Type = olBCC
End If
'Betreff
If strSubject <> "" Then .Subject = strSubject
'Nachricht
If strMessageBody <> "" Then .Body = strMessageBody
'Dateianhang
If strAttachments <> "" Then
sTemp = strAttachments
Do While InStr(sTemp, ";") > 0
.Attachments.Add Left(sTemp, InStr(sTemp, ";") - 1)
sTemp = Mid(sTemp, InStr(sTemp, ";") + 1)
Loop
If sTemp <> "" Then
.Attachments.Add sTemp
End If
End If
If bSave = True Then
.Save
Else
'.Save
.Send
End If
End With
Exit Do
Loop
If Not oOLMail Is Nothing Then Set oOLMail = Nothing
If Not oOlApp Is Nothing Then Set oOlApp = Nothing
SendMailWithOutSafe = lRet
Exit Function
ErrHandler:
lRet = Err
MsgBox "Fehler: " & CStr(lRet) & vbCrLf & Error(lRet)
Resume Next
End Function
[/QUOTE]
This function is controlled by a separate class in Access (see also below).
Public Function OlSendMailWithOutSafe(Optional strTo As String = "", Optional strCc As String = "", Optional strBCC As String = "", Optional strSubject As String = "", Optional strMessageBody As String = "", Optional strAttachments As String = "", Optional bsave As Boolean) As Long
On Error GoTo errHandler
ool.SendMailWithOutSafe strTo, strCc, strBCC, strSubject, strMessageBody, strAttachments, , bsave
Exit Function
errHandler:
MsgBox (Error)
Resume Next
End Function
'******************************
Private Sub Class_Initialize()
On Error Resume Next
Set ool = GetObject(, "Outlook.Application")
Debug.Print Err
If Err <> 0 Then
Set ool = CreateObject("Outlook.Application")
End If
End Sub
'*******************************
'Terminate Class
'----------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
On Error Resume Next
Set ool = Nothing
End Sub
[/QUOTE]
Trying to use these features in Office 2010, always results in an error.
Does anyone have an idea or a solution to this problem!
Thanks Gerry
To create and send reports I use currently an Access (2003) database. After creating, the reports are automatically sent via Outlook. Currently I am using a function that is built into "This Outlook Session" (see below).
Public Function SendMailWithOutSafe(Optional strTo As String = "", _
Optional strCC As String = "", _
Optional strBCC As String = "", _
Optional strSubject As String = "", _
Optional strMessageBody As String = "", _
Optional strAttachments As String = "", _
Optional strTempFileSpez As String = "", _
Optional bSave As Boolean) As Long
'Funktion zum Senden von Mails ohne Windows Sicherheitsabfrage
'bSave = True >>> Entwurf wird gespeichert Version 1.1 Feb.2014
Dim lRet As Long
Dim oOlApp As Outlook.Application
Dim oOlRec As Outlook.Recipient
Dim oOLMail As Outlook.MailItem
Dim bWithTemplate As Boolean
Dim sTemp As String
On Error GoTo ErrHandler
Do
lRet = 0
bWithTemplate = False
If oOlApp Is Nothing Then Set oOlApp = Outlook.Application
If strTempFileSpez <> "" Then
If InStr(strTempFileSpez, Dir(strTempFileSpez)) > 0 Then
If oOLMail Is Nothing Then
Set oOLMail = oOlApp.CreateItemFromTemplate(strTempFileSpez)
bWithTemplate = True
' es werden nur noch die Anlagen angehangen
End If
End If
End If
If oOLMail Is Nothing Then Set oOLMail = oOlApp.CreateItem(olMailItem)
With oOLMail
'Empfänger
If strTo <> "" Then
Set oOlRec = .Recipients.Add(strTo)
oOlRec.Type = olTo
End If
If strCC <> "" Then
Set oOlRec = .Recipients.Add(strCC)
oOlRec.Type = olCC
End If
If strBCC <> "" Then
Set oOlRec = .Recipients.Add(strBCC)
oOlRec.Type = olBCC
End If
'Betreff
If strSubject <> "" Then .Subject = strSubject
'Nachricht
If strMessageBody <> "" Then .Body = strMessageBody
'Dateianhang
If strAttachments <> "" Then
sTemp = strAttachments
Do While InStr(sTemp, ";") > 0
.Attachments.Add Left(sTemp, InStr(sTemp, ";") - 1)
sTemp = Mid(sTemp, InStr(sTemp, ";") + 1)
Loop
If sTemp <> "" Then
.Attachments.Add sTemp
End If
End If
If bSave = True Then
.Save
Else
'.Save
.Send
End If
End With
Exit Do
Loop
If Not oOLMail Is Nothing Then Set oOLMail = Nothing
If Not oOlApp Is Nothing Then Set oOlApp = Nothing
SendMailWithOutSafe = lRet
Exit Function
ErrHandler:
lRet = Err
MsgBox "Fehler: " & CStr(lRet) & vbCrLf & Error(lRet)
Resume Next
End Function
[/QUOTE]
This function is controlled by a separate class in Access (see also below).
Public Function OlSendMailWithOutSafe(Optional strTo As String = "", Optional strCc As String = "", Optional strBCC As String = "", Optional strSubject As String = "", Optional strMessageBody As String = "", Optional strAttachments As String = "", Optional bsave As Boolean) As Long
On Error GoTo errHandler
ool.SendMailWithOutSafe strTo, strCc, strBCC, strSubject, strMessageBody, strAttachments, , bsave
Exit Function
errHandler:
MsgBox (Error)
Resume Next
End Function
'******************************
Private Sub Class_Initialize()
On Error Resume Next
Set ool = GetObject(, "Outlook.Application")
Debug.Print Err
If Err <> 0 Then
Set ool = CreateObject("Outlook.Application")
End If
End Sub
'*******************************
'Terminate Class
'----------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
On Error Resume Next
Set ool = Nothing
End Sub
[/QUOTE]
Trying to use these features in Office 2010, always results in an error.
Does anyone have an idea or a solution to this problem!
Thanks Gerry