Apr 11, 2018

1634

Access Outlook VBA, Schleife hört auf, aber warum?

Hallo Zusammen,

ich habe wieder mal eine Frage.

Option Compare Database
Option Explicit

Private Sub Email_senden()

    Dim olApp As New Outlook.Application
    Dim olNamespace As NameSpace
    Dim objMailItem As MailItem
    Dim objFolder As mapiFolder
    Dim strTo As String
    Dim strCC As String
    Dim strTitle As String
    Dim strSubject As String
    Dim strHTMLHeader As String
    Dim strMessage As String
    Dim strAbsender As String
    Dim strVorname As String
    Dim strNachname As String
    Dim strKundennummer As String
    Dim strDatabase As String
    Dim db As Database
    Dim rs As Recordset
    Dim strSQL As String
    Dim oItem As Outlook.MailItem
    Dim intAnzahl As Integer
    Dim Betreff As String
    
    ' Datenbankverbindung herstellen  
        strDatabase = "C:\Users\username\Documents\Kontakte.accdb"  
        Set db = CurrentDb
        
    'Verbindungen zu Outlook aufmachen  
        Set olApp = CreateObject("Outlook.Application")  
        Set olNamespace = olApp.GetNamespace("MAPI")  
        Set objFolder = olNamespace.GetDefaultFolder(olFolderInbox)
        Set objMailItem = objFolder.Items.Add(olMailItem)
        
    'Tabelle öffnen  
            strSQL = "Select * FROM Kontakte;"  
            Set rs = db.OpenRecordset(strSQL)

            Do Until rs.EOF
            
            strAbsender = ""  
            strVorname = ""  
            strNachname = ""  
            strKundennummer = ""  
            
            If Not IsNull(rs!Absender) = True Then strAbsender = rs!Absender
            If Not IsNull(rs!Vorname) = True Then strVorname = rs!Vorname
            If Not IsNull(rs!Nachname) = True Then strNachname = rs!Nachname
            If Not IsNull(rs!Kundennummer) = True Then strKundennummer = rs!Kundennummer
            
                  If strAbsender = "" Then MsgBox "Keine E-Mailadresse gefunden": rs.MoveNext: Exit Do  
                  If strVorname = "" Then MsgBox "Keinen Vornamen gefunden": rs.MoveNext: Exit Do  
                  If strNachname = "" Then MsgBox "Keinen Nachnamen gefunden": rs.MoveNext: Exit Do  
                  If strKundennummer = "" Then MsgBox "Keine Kundennummer gefunden": rs.MoveNext: Exit Do  
                                
                    strSubject = "Alles ok"  
                    strHTMLHeader = "<!DOCTYPE html><html><head><style>p {font: 11pt Calibri; text-align: left;}</style><style>td {border:1px solid; font: 11pt Calibri; text-align: center;}</style><style>th {border:1px solid; font: 11pt Calibri;}</style></head>"  
                    strTitle = "<p>Hallo</p>"  
                    strMessage = "<p>Alles ist easy :)</p>"  
                    'HTML Footer  
                    strMessage = strMessage & "</body></html>"  
            
                    With objMailItem
                        If Not strAbsender = "" Then .To = strAbsender  
                        .Subject = strSubject
                        .HTMLBody = strHTMLHeader & strTitle & strMessage
                        .Display
                        .Save
                    End With
                           
                rs.MoveNext
                Loop
                rs.Close
        
        Set rs = Nothing
        Set db = Nothing
        Set olApp = Nothing
        Set olNamespace = Nothing
        Set objFolder = Nothing
        Set objMailItem = Nothing
        
End Sub

Also, ich habe einer Datenbank, bzw. Tabelle mit Absender (E-Mail), Vorname, Nachname und Kundennummer:

Es funktioniert alles super, aber wenn von der Datenbank eine E-Mailadresse rauslösche (z.B. in der Mitte), dann hört sich auf und kontrolliert den Rest nicht.
Warum ist es so, bzw. wie kann ich machen, dass der Rest auch kontrolliert wird?

Kann mir Jemand helfen?
Vielen Dank im Voraus.

Please also mark the comments that contributed to the solution of the article

Content-Key: 370800

Url: https://administrator.de/contentid/370800

Printed on: April 27, 2024 at 04:04 o'clock

19 Comments

Latest comment

Hi,
ich sehe zwar nicht, wo Du da etwas löschst, aber ich denke, Du meinst, wenn dort ein unvollständiger (leerer) Datensatz bei ist, dann bricht die Schleife ab.
Das ist auch logisch, weil Du die Schleife mit "Exit Do" explizit verlässt.

Versuche es mal so:

    DatenOK  = (strAbsender <> "")  AND (strVorname <> "")  AND (strNachname <> "") AND (strKundennummer <> "")  

    If DatenOK Then                                
                    strSubject = "Alles ok"  
                    strHTMLHeader = "<!DOCTYPE html><html><head><style>p {font: 11pt Calibri; text-align: left;}</style><style>td {border:1px solid; font: 11pt Calibri; text-align: center;}</style><style>th {border:1px solid; font: 11pt Calibri;}</style></head>"  
                    strTitle = "<p>Hallo</p>"  
                    strMessage = "<p>Alles ist easy :)</p>"  
                    'HTML Footer  
                    strMessage = strMessage & "</body></html>"  
            
                    With objMailItem
                        If Not strAbsender = "" Then .To = strAbsender  
                        .Subject = strSubject
                        .HTMLBody = strHTMLHeader & strTitle & strMessage
                        .Display
                        .Save
                    End With
    end if

Das schützt Dich zwar auch nicht vor falschen Daten (z.B. falsch formatierte Email-Adresse), aber das ist dann schon wieder eine andere Geschichte.

E.

Edit: Schreibfehler im Code korrigiert.

Hallo,

Zitat von @abenteuR:
Es funktioniert alles super, aber wenn von der Datenbank eine E-Mailadresse rauslösche (z.B. in der Mitte), dann hört sich auf und kontrolliert den Rest nicht.

Hast du nachdem du eine Datensatz loescht auch dein Programm und dessen Speicherinhalt akzualisiert oder sind es so viele Daten das die nicht im RAM gehalten werden können und dein Programm bei jeden Datensatz innerhalb deiner 2 Schleifen (Do Until und While) jedesmal die Datenquelle bemüht? Mal mit F8 ein Debugging (Einzelschritt) gemacht und geschaut welcher Datensatz dann dann ohne Inhalt ist? Welche Schleife macht denn deine Fehler? Was ist die genaue Fehlermeldung? Und was wurde ausgeführt was zu diesem Fehler führte?

Warum ist es so, bzw. wie kann ich machen, dass der Rest auch kontrolliert wird?

Dein Fehlerzustand mit Debugging finden und somit diesen Zustand nicht mehr enstehene lassen (Vermutlich das Löschen eines Datensatzes)

Gruß,
Peter

Hallo Peter,

danke für die Antwort.

- Ja, ich habe es aktualisiert gehabt. Es sind sehr wenig Daten, da es ist für mich nur Übung (lerne grade Programmieren).

- Es gibt kein Fehler.

Nach dem

If strAbsender = "" Then MsgBox "Keine E-Mailadresse gefunden": rs.MoveNext: Exit Do  

kommt die Meldung, dass "Keine E-Mailadresse gefunden", dann spring auf

rs.Close

, anstatt das nochmal von Vorne anfängt mit der nächste.

VG
Peter

...dann spring auf
rs.Close
, anstatt das nochmal von Vorne anfängt mit der nächste.

Und warum das so ist, habe ich Dir bereits erklärt.

Ich habe den Gefühl, dass den Wald vor lauter Bäumen nicht sehen.

Hallo,

Zitat von @abenteuR:
- Ja, ich habe es aktualisiert gehabt.

Wenn die Datenquelle unabhängig deines Programms aktualisiert wird, muss dein Programm natürlich auch seine Daten aktualisieren, notfalls wieder von vorn anfangen. Sonst hast du noch Rote Autos im Lager (bestand in dein Programm) aber es sind tatsäclich schon alle verkauft und ausgeliefert.

Es sind sehr wenig Daten

Dann werden diese auch alle im RAM gehalten und da erfahren die keine Aktualisierung.

(lerne grade Programmieren).

Nach dem

If strAbsender = "" Then MsgBox "Keine E-Mailadresse gefunden": rs.MoveNext: Exit Do  

Mehrere Befehle in einer Zeile ist absolut schlechter Code und schon seit 30 Jahren eher out. Das war zu Zeiten als die Editoren nur begrenzten Platz hatten. Mach es lieber so

Do
    If strAbsender = "" Then  
        MsgBox "Keine E-Mailadresse gefunden"  
        rs.MoveNext
        Exit Do
    End If
Loop

Natürlich ist die Do und Loop nur zur veranschaulichung.

Jetzt siehst du auch das dein RS.MoveNext jeglichen Sinn an dieser Stelle verloren hat da als nächste ja ein Exit Do aufgerufen wird. Und sollte die Datenquelle aus mehreren hunderttausende oder Millionen Zeilen bestehen, koste es aus deutlich Zeit die du warten musst.

anstatt das nochmal von Vorne anfängt mit der nächste.

Dann kein Exit Do

Gruß,
Peter

Entschuldigung, habe der erste Kommentar versehen.

Mit "Exit Do" springst Du hinter das "Loop". Ohne "Loop" kein nächstes "Do".
Hast du denn schon Mal meinen Ansatz mit dem "DatenOK" ausprobiert? Wenn nein, warum nicht?

Ich habe den Code gerade ausprobiert. Es zeigt kein Fehler, passiert aber nichts.

Mit F8 komme ich zum

If DatenOK Then

, der eine "False" Wert hat und bleibt als unendliche Schleife.

Post bitte Deinen neuen Code. Ich schätze, Du hast das "rs.MoveNext" vergessen.

Es war schon drin, habe aber inzwischen was anderes versucht, habe aber Syntaxfehler:

 If Not IsNull(rs!Absender) = True Then strAbsender = rs!Absender
                If Not IsNull(rs!Vorname) = True Then strVorname = rs!Vorname
                If Not IsNull(rs!Nachname) = True Then strNachname = rs!Nachname
                If Not IsNull(rs!Kundennummer) = True Then strKundennummer = rs!Kundennummer

                      If strAbsender = "" Then MsgBox "Keine E-Mailadresse gefunden": rs.MoveNext: Exit GoTo ContinueLoop  
                      If strVorname = "" Then MsgBox "Keinen Vornamen gefunden": rs.MoveNext: Exit Exit GoTo ContinueLoop  
                      If strNachname = "" Then MsgBox "Keinen Nachnamen gefunden": rs.MoveNext: Exit GoTo ContinueLoop  
                      If strKundennummer = "" Then MsgBox "Keine Kundennummer Gefunden": rs.MoveNext: Exit Exit GoTo ContinueLoop  

                        strSubject = "Alles ok"  
                        strHTMLHeader = "<!DOCTYPE html><html><head><style>p {font: 11pt Calibri; text-align: left;}</style><style>td {border:1px solid; font: 11pt Calibri; text-align: center;}</style><style>th {border:1px solid; font: 11pt Calibri;}</style></head>"  
                        strTitle = "<p>Hallo</p>"  
                        strMessage = "<p>Alles ist easy :)</p>"  
                        'HTML Footer  
                        strMessage = strMessage & "</body></html>"  

                        With objMailItem
                            If Not strAbsender = "" Then .To = strAbsender  
                            .Subject = strSubject
                            .HTMLBody = strHTMLHeader & strTitle & strMessage
                            .Display
                            .Save
                        End With

     
                rs.MoveNext
ContinueLoop:
                Loop
                rs.Close
        
        Set rs = Nothing
        Set db = Nothing
        Set olApp = Nothing
        Set olNamespace = Nothing
        Set objFolder = Nothing
        Set objMailItem = Nothing

Aber mit Deinen Code:

Option Compare Database
Option Explicit

Private Sub Email_senden()

    Dim olApp As New Outlook.Application
    Dim olNamespace As NameSpace
    Dim objMailItem As MailItem
    Dim objFolder As mapiFolder
    Dim strTo As String
    Dim strCC As String
    Dim strTitle As String
    Dim strSubject As String
    Dim strHTMLHeader As String
    Dim strMessage As String
    Dim strAbsender As String
    Dim strVorname As String
    Dim strNachname As String
    Dim strKundennummer As String
    Dim strDatabase As String
    Dim db As Database
    Dim rs As Recordset
    Dim strSQL As String
    Dim oItem As Outlook.MailItem
    Dim intAnzahl As Integer
    Dim Betreff As String
    Dim DatenOK As String
    
    ' Datenbankverbindung herstellen  
        strDatabase = "C:\Users\bcsikos\Documents\Kontakte.accdb"  
        Set db = CurrentDb
        
    'Verbindungen zu Outlook aufmachen  
        Set olApp = CreateObject("Outlook.Application")  
        Set olNamespace = olApp.GetNamespace("MAPI")  
        Set objFolder = olNamespace.GetDefaultFolder(olFolderInbox)
        Set objMailItem = objFolder.Items.Add(olMailItem)
        
    'Tabelle öffnen  
            strSQL = "Select * FROM Kontakte;"  
            Set rs = db.OpenRecordset(strSQL)

            Do Until rs.EOF
            
            strAbsender = ""  
            strVorname = ""  
            strNachname = ""  
            strKundennummer = ""  
            
            DatenOK = (strAbsender <> "") And (strVorname <> "") And (strNachname <> "") And (strKundennummer <> "")  

        If DatenOK Then

                        strSubject = "Alles ok"  
                        strHTMLHeader = "<!DOCTYPE html><html><head><style>p {font: 11pt Calibri; text-align: left;}</style><style>td {border:1px solid; font: 11pt Calibri; text-align: center;}</style><style>th {border:1px solid; font: 11pt Calibri;}</style></head>"  
                        strTitle = "<p>Hallo</p>"  
                        strMessage = "<p>Alles ist easy :)</p>"  
                        'HTML Footer  
                        strMessage = strMessage & "</body></html>"  

                        With objMailItem
                            If Not strAbsender = "" Then .To = strAbsender  
                            .Subject = strSubject
                            .HTMLBody = strHTMLHeader & strTitle & strMessage
                            .Display
                            .Save
                        End With

        

     
                rs.MoveNext

                Loop
                rs.Close
        
        Set rs = Nothing
        Set db = Nothing
        Set olApp = Nothing
        Set olNamespace = Nothing
        Set objFolder = Nothing
        Set objMailItem = Nothing
        
End Sub

Aber mit meinem Code .... was?

Wie ich vorher geschrieben habe, bekomme kein Fehler, passiert aber auch nichts, nur endlose Schleife

Mann, nicht mal fehlerfrei abschreiben können ...

Da fehlt das "End If" vor dem "rs.MoveNext".

Hi.

Dim DatenOK As String

Hust ... das sollte eigentlich als Boolean deklariert sein.

Gruß m.

Zitat von @135950:

Dim DatenOK As String

Hust ... das sollte eigentlich als Boolean deklariert sein.

lol
Das habe ich gar nicht gesehen. Das also auch noch ...

Moin,

bezieht sich auf den letzten geposteten Code:

Wie soll denn

strAbsender = ""   
...
 DatenOK = (strAbsender <> "")   

zu irgendwas anderes führen als zu DatenOK = FALSE ?

lg,
Slainte

Das war ja auch ein Problem, jetzt aber geschafft

Option Compare Database
Option Explicit

Private Sub Email_senden()

    Dim olApp As New Outlook.Application
    Dim olNamespace As NameSpace
    Dim objMailItem As MailItem
    Dim objFolder As mapiFolder
    Dim strTo As String
    Dim strCC As String
    Dim strTitle As String
    Dim strSubject As String
    Dim strHTMLHeader As String
    Dim strMessage As String
    Dim strAbsender As String
    Dim strVorname As String
    Dim strNachname As String
    Dim strKundennummer As String
    Dim strDatabase As String
    Dim db As Database
    Dim rs As Recordset
    Dim strSQL As String
    Dim oItem As Outlook.MailItem
    Dim intAnzahl As Integer
    Dim Betreff As String
    Dim DatenOK As Boolean
    
    ' Datenbankverbindung herstellen  
        strDatabase = "C:\Users\bcsikos\Documents\Kontakte.accdb"  
        Set db = CurrentDb
        
    'Verbindungen zu Outlook aufmachen  
        Set olApp = CreateObject("Outlook.Application")  
        Set olNamespace = olApp.GetNamespace("MAPI")  
        Set objFolder = olNamespace.GetDefaultFolder(olFolderInbox)
        Set objMailItem = objFolder.Items.Add(olMailItem)
        
    'Tabelle öffnen  
            strSQL = "Select * FROM Kontakte;"  
            Set rs = db.OpenRecordset(strSQL)

            Do Until rs.EOF
            
            strAbsender = ""  
            strVorname = ""  
            strNachname = ""  
            strKundennummer = ""  
            
                If Not IsNull(rs!Absender) = True Then strAbsender = rs!Absender
                If Not IsNull(rs!Vorname) = True Then strVorname = rs!Vorname
                If Not IsNull(rs!Nachname) = True Then strNachname = rs!Nachname
                If Not IsNull(rs!Kundennummer) = True Then strKundennummer = rs!Kundennummer
            
            DatenOK = (strAbsender <> "") And (strVorname <> "") And (strNachname <> "") And (strKundennummer <> "")  

        If DatenOK Then

                strSubject = "Alles ok"  
                strHTMLHeader = "<!DOCTYPE html><html><head><style>p {font: 11pt Calibri; text-align: left;}</style><style>td {border:1px solid; font: 11pt Calibri; text-align: center;}</style><style>th {border:1px solid; font: 11pt Calibri;}</style></head>"  
                strTitle = "<p>Hallo</p>"  
                strMessage = "<p>Alles ist easy :)</p>"  
                'HTML Footer  
                strMessage = strMessage & "</body></html>"  

                With objMailItem
                    If Not strAbsender = "" Then .To = strAbsender  
                    .Subject = strSubject
                    .HTMLBody = strHTMLHeader & strTitle & strMessage
                    .Display
                    .Save
                End With
                
                Else
                MsgBox "Daten unvollständig"  
                

        End If
            
                rs.MoveNext
                Loop
                rs.Close
        
        Set rs = Nothing
        Set db = Nothing
        Set olApp = Nothing
        Set olNamespace = Nothing
        Set objFolder = Nothing
        Set objMailItem = Nothing
        
End Sub

Vielen Dank für Euch alle.

Och, keine Ursache ...

German solved Question Microsoft Office Microsoft