Email aus Excel

Private Sub Worksheet_Change(ByVal Target As Range) If Cells(1, 1).Value = "1" Then sendmail Cells(4, 4).Value, Cells(4, 5).Value, Cells(4, 2).Value, Cells(4, 3).Value, _ _ Cells(4, 6).Value Cells(1, 1).Value = "0" End If End Sub

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Benutzer

Hallo Gorean,
sich funktioniert CDO unter Office 2007.
Ich würde das so lösen.

' **********************************************************************
' Modul: Tabelle1  Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  On Error GoTo ErrExit
  If Cells(1, 1).Value = "1" Then
    Application.EnableEvents = False
    sendMail_CDO Cells(4, 4).Value, Cells(4, 5).Value, Cells(4, 2).Value, Cells(4, 3).Value
    Cells(1, 1).Value = "0"
  End If
  
  ErrExit:
  Application.EnableEvents = True
End Sub


' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

'Don't Change!
Private Const cstrSchema As String = "http://schemas.microsoft.com/cdo/configuration/"
'End Don't Change!

Private Const cstrSMTPServer As String = "mail.provider.com"  'Fill in your SMTP-Server!
Private Const cstrUSERNAME As String = "Your Username" 'Fill in your Mailaccount Username
Private Const cstrPASSWORD As String = "Your Password" 'Fill in your Mailaccount Password
Private Const cstrADDRESS As String = "name@domain.com" 'Your Mail-Address

Sub sendMail_CDO(SenderName, Recever, Subject, Body)
  Dim objMsg As Object, objConf As Object
  Dim vntFields As Variant
  
  On Error GoTo ErrExit
  
  Set objMsg = CreateObject("CDO.Message")
  Set objConf = CreateObject("CDO.Configuration")
  
  objConf.Load -1    ' CDO Source Defaults
  
  Set vntFields = objConf.Fields
  
  With vntFields
    .Item(cstrSchema & "sendusing") = 2
    .Item(cstrSchema & "smtpserver") = cstrSMTPServer
    .Item(cstrSchema & "smtpserverport") = 25
    
    'When you also get the Authentication Required Error you can add this three lines.
    '  .Item(cstrSchema & "smtpauthenticate") = 1
    '  .Item(cstrSchema & "sendusername") = cstrUSERNAME
    '  .Item(cstrSchema & "sendpassword") = cstrPASSWORD
    
    .Update
  End With
  
  With objMsg
    Set .Configuration = objConf
    .To = Recever
    .CC = ""
    .BCC = ""
    .From = SenderName
    .Subject = Subject
    .TextBody = Body
    
    
    '      ' Set importance or Priority to high
    '      .Fields("urn:schemas:httpmail:importance") = 2
    '      .Fields("urn:schemas:mailheader:X-Priority") = 1
    '
    '      ' Request read receipt
    '      .Fields("urn:schemas:mailheader:return-receipt-to") = cstrADDRESS
    '      .Fields("urn:schemas:mailheader:disposition-notification-to") = cstrADDRESS
    '
    '      ' Update fields
    '      .Fields.Update
    
    .Send
  End With
  
  
  ErrExit:
  
  If Err.Number <> 0 Then
    MsgBox "Fehler:" & vbTab & Err.Number & vbLf & vbLf & Err.Description & _
      vbLf & vbLf, vbExclamation, "Fehler"
  End If
  
  Set objConf = Nothing
  Set objMsg = Nothing
End Sub

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread