Office: (Office 2016) For Schleife nicht initialisiert

firela112 · 24. November 2018

Hi,
bräuchte dringend Hilfe.

Ich sende per folgenden Befehl Emails raus.(per cdo)

Blos jetzt auf einmal bringt er mir den Laufzeitfehler 92 mit For Schleife nicht initalisiert.

Code:

Option Compare Database
Public Function MailversandCDO1(ByVal Postausgangsserver As String, _
ByVal Benutzername As String, _
ByVal Mailpasswort As String, _
ByVal Absender As String, _
ByVal Empfänger As String, _
ByVal Betreff As String, _
ByVal Nachricht As String, _
Optional ByVal HTML As Boolean = False, _
Optional PfadAnhang As Variant, _
Optional ByVal OhneSSL As Boolean = False _
) As Boolean

'Late Binding: Kein Verweis auf "Microsoft CDO for Windows 2000 Library" notwendig
'Pfad zur Bibliothek: 32bit: C:WindowsSystem32cdosys.dll, 64bit: C:WindowsSysWOW64cdosys.dll
'Quelle: DBWiki
Dim Anhang As Variant
Dim Mail As Object 'CDO.Message
Dim CC As Object 'CDO.Configuration
Dim Schema As String
Dim lgID As Long
lgID = DLookup("LoeschzugID", "tbl_Einstellungen_Loeschzugauswahl")

Const cdoSendUsingPort = 2
Const cdoBasic = 1

On Error GoTo Err_MailversandCDO1

'Sanduhr ein
DoCmd.Hourglass True

Set Mail = CreateObject("CDO.Message")
Set CC = CreateObject("CDO.Configuration")
Schema = "http://schemas.microsoft.com/cdo/configuration/"

'---------------------------------------------------------
'Konfiguration Mail-Server und Login

With CC.Fields

'Versandart: Über das Netzwerk
.Item(Schema & "sendusing").Value = cdoSendUsingPort

'Postausgangsserver (SMTP = Simple Mail Transfer Protocol)
.Item(Schema & "smtpserver").Value = Postausgangsserver

If OhneSSL = True Then
'ohne SSL-Verschlüsselung, Port 25 (alternativ 587)
.Item(Schema & "smtpserverport").Value = DLookup("Port_ohne_SSL", _
"tbl_Nachschlagen_Loeschzuege_Fachgruppen", "CodeLoeschzug = " & lgID)

Else
'mit SSL-Verschlüsselung, Port 465
.Item(Schema & "smtpusessl").Value = "true"
.Item(Schema & "smtpserverport").Value = DLookup("Port_mit_SSL", _
"tbl_Nachschlagen_Loeschzuege_Fachgruppen", "CodeLoeschzug = " & lgID)
End If

'Server erfordert Authentifizierung, mit Benutzernamen und Mail-Passwort
.Item(Schema & "smtpauthenticate").Value = cdoBasic
.Item(Schema & "sendusername").Value = Benutzername
.Item(Schema & "sendpassword").Value = Mailpasswort

.Update

End With

'---------------------------------------------------------
'Mail-Versand

With Mail

Set .Configuration = CC

'Empfänger E-Mail-Adresse
.To = Empfänger

'Absender E-Mail-Adresse
.FROM = Absender

'Betreff
.Subject = Betreff

'Nachricht im HTML-Format
If HTML = True Then
.HTMLBody = Nachricht

'Nachricht im Plaintext-Format
Else
.TextBody = Nachricht
End If

'Anhang

If IsArray(PfadAnhang) Then
For Each Anhang In PfadAnhang
.AddAttachment Anhang
Next
ElseIf Len(PfadAnhang) > 0 Then
.AddAttachment PfadAnhang
End If

'Mail senden
.Send

End With
'---------------------------------------------------------

MailversandCDO1 = True

Exit_MailversandCDO1:
Set CC = Nothing
Set Mail = Nothing
'Sanduhr aus
DoCmd.Hourglass False
Exit Function

Err_MailversandCDO1:
MailversandCDO1 = False
'Fehlermeldung
MsgBox "Laufzeitfehler '" & Err.Number & "':" & vbCrLf & vbLf & Err.Description
Resume Exit_MailversandCDO1

End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Code:

Private Sub Befehl16_Click()
Dim strPostausgangsserver As String
Dim strBenutzername As String
Dim strMailpasswort As String
Dim strAbsender As String
Dim strEmpfänger As String
Dim strBetreff As String
Dim strNachricht As String
Dim strHTMLNachricht As String
Dim strPfadAnhang As String
Dim lgID As Long
Dim bool As Boolean 'Überprüfung ob Internetverbindung besteht
Dim stDocName As String
Dim LinkCriteria As String
Dim rsf As Recordset
Dim strPfad As String
Dim strret() As String
Dim i As Long
Dim backupDir
Dim Antwort
lgID = DLookup("LoeschzugID", "tbl_Einstellungen_Loeschzugauswahl")
bool = InternetGetConnectedState(0&, 0&)
DoCmd.Hourglass True
Application.Echo False
Antwort = MsgBox("Tour per Email weiterleiten?", 4, "")
If Antwort = vbYes Then
If Len(vbNullString & DLookup("email", "tbl_Einstellungen_emailempfaenger", "id=11")) > 0 Then
If bool = True Then
stDocName = "Bericht_Hydranten_Tour_Pruefbericht"
LinkCriteria = "[Tour_ID] = " & Me.[Tour_ID]
On Error Resume Next
DoCmd.OpenReport stDocName, acPreview, , LinkCriteria, acHidden
On Error GoTo 0
On Error Resume Next
DoCmd.OutputTo acOutputReport, stDocName, acFormatPDF, DLookup("AblageOrdner", _
"tbl_Admin_Dateien_Ordner", "id=11") & "Tour_" & Me.Tour_ID.Value & ".pdf", False
On Error GoTo 0
DoCmd.Close acReport, stDocName
Set rsf = Forms!frm_Hydranten_Jahresabrechnung![frm_Hydranten_Details].Form.RecordsetClone
rsf.MoveFirst
Do Until rsf.EOF
rsf.Edit
rsf.Update
stDocName = "Bericht_Hydranten_Pruefbericht"
LinkCriteria = "[Hydranten_ID] = " & rsf!Hydranten_ID & " AND Tour_ID=" & _
rsf![Tour_ID]
On Error Resume Next
DoCmd.OpenReport stDocName, acPreview, , LinkCriteria, acHidden
On Error GoTo 0
On Error Resume Next
DoCmd.OutputTo acOutputReport, stDocName, acFormatPDF, DLookup("AblageOrdner", _
"tbl_Admin_Dateien_Ordner", "id=11") & "Tour_" & Me.Tour_ID.Value & "_" & "Hydrant_" & _
rsf!Hydranten_ID & ".pdf", False
On Error GoTo 0
DoCmd.Close acReport, stDocName
rsf.MoveNext
Loop
'Postausgangsserver mit SSL-Verschlüsselung: Beispiel für T-Online
strPostausgangsserver = DLookup("Postausgangsserver", _
"tbl_Nachschlagen_Loeschzuege_Fachgruppen", "CodeLoeschzug = " & lgID)

'Benutzer
strBenutzername = DLookup("Benutzername", "tbl_Nachschlagen_Loeschzuege_Fachgruppen", _
"CodeLoeschzug = " & lgID)

'Passwort
strMailpasswort = DLookup("Passwort", "tbl_Nachschlagen_Loeschzuege_Fachgruppen", _
"CodeLoeschzug = " & lgID)

'Absender-Adresse entweder mit oder ohne Vor- und Nachnamen
strAbsender = DLookup("Absendername", "tbl_Nachschlagen_Loeschzuege_Fachgruppen", _
"CodeLoeschzug = " & lgID)
'strAbsender = "max.mustermann@t-online.de"

'Empfänger-Mailadresse, mehrere Empfänger mit ";" trennen
strEmpfänger = DLookup("email", "tbl_Einstellungen_emailempfaenger", "id=11")
'strEmpfänger = "hans.mustermann@t-online.de; fritz.mustermann@t-online.de"

'Betreff, auch Umlaute möglich
strBetreff = "Hydrantentour_Prüfbogen" & "_" & Me!Tour_ID & "_" & _
Format(Me.Datum.Value, "dd-mm-yyyy")

'Anhang, Pfad zu einer Datei (optionaler Parameter)
strPfad = DLookup("AblageOrdner", "tbl_Admin_Dateien_Ordner", "id=11")
On Error Resume Next
strret = DateienAuflisten(strPfad, True)
For i = 0 To UBound(strret)
Debug.Print strret(i)
Next

'Muster für HTML-Textnachricht (ggf. mit einem HTML-Editor erzeugen)
strHTMLNachricht = ""

'--------------------------------------
'Versand-Beispiele:

If MailversandCDO1(strPostausgangsserver, strBenutzername, strMailpasswort, _
strAbsender, strEmpfänger, strBetreff, strHTMLNachricht, True, strret) = True Then
MsgBox "Mail wurde versandt"
backupDir = DLookup("AblageOrdner", "tbl_Admin_Dateien_Ordner", "id=11")
On Error Resume Next
Kill (backupDir & "*.*")
Me!Tour_weitergeleitet = -1
End If
Else
MsgBox "Internetverbindung besteht nicht"
End If
Else
MsgBox "Keine Emailadresse hinterlegt!!"
End If
End If
DoCmd.Hourglass False
Application.Echo True

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Code:

Public Function DateienAuflisten(Optional Ordnerpfad As String = "", _
Optional OhneUnterordner As Boolean) As String()

' Quelle: DBWiki

Dim idx As Long
Dim strDir As String
Dim strAktDir As String
Dim arrResult() As String
Dim colDir As New Collection

If Not Right$(Ordnerpfad, 1) = "" Then
Ordnerpfad = Ordnerpfad & ""
End If

' Fehler auslösen, wenn Ordnerpfad ungültig
Call GetAttr(Ordnerpfad)

colDir.Add Ordnerpfad

Do While colDir.Count > 0
strAktDir = colDir.Item(1)
colDir.Remove 1
strDir = Dir$(strAktDir, vbDirectory)

Do While Len(strDir) > 0
If strDir "." And strDir ".." Then

' Gefundenen Unterordner in Collection einlesen
If (GetAttr(strAktDir & strDir) And vbDirectory) = vbDirectory Then
If OhneUnterordner = False Then
colDir.Add strAktDir & strDir & ""
End If
Else
' Gefundene Datei in Array einlesen
ReDim Preserve arrResult(idx)
arrResult(idx) = strAktDir & strDir
idx = idx + 1
End If

End If
strDir = Dir$
Loop

Loop

DateienAuflisten = arrResult

End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Wo ist da mein Fehler?

:)

firela112 · 26. November 2018

Hi, hab den Fehler gefunden.
Es war eine Datei (mit nicht lesbaren Zeichem)im Ordner, die er nicht auslesen hat können.

hcscherzer · 26. November 2018

Ich finde es - mit Verlaub - ziemlich abartig, hier drei lange Code-Blöcke zu zeigen.

Und dann stehen da so hanebüchene Befehlsfolgen wie
Code:

On Error Resume Next
DoCmd.OpenReport stDocName, acPreview, , LinkCriteria, acHidden
On Error GoTo 0
On Error Resume Next
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Soll das eine Fehlerbehandlung sein?

Und wenn dann noch Kontrollstrukturen nicht ordentlich eingerückt erscheinen, dann weigere ich mich, mich damit zu beschäftigen.
Sorry.

elmar · 26. November 2018

Typisch für den Feuerwehrmann firela112.
Nun hat er es auch auf meine Igno-Liste geschafft, das Maß ist voll.

Office: (Office 2016) For Schleife nicht initialisiert

For Schleife nicht initialisiert

For Schleife nicht initialisiert

For Schleife nicht initialisiert

For Schleife nicht initialisiert - Similar Threads - For Schleife initialisiert

For Next Schleife

Access For next Schleife

For Each Schleife Anstatt ActiveSheet festen Tabellenblattnamen benutzen

For Schleife, schlechte Performance

For-Next-Schleife für Textfeldübertragung

Glücksrad mit VBA und For-Schleifen

"find and replace" mit "for-Schleife" kombinieren