Finde den Fehler nicht -.-

  • #1
S

sp00n

Aktives Mitglied
Themenersteller
Dabei seit
20.01.2006
Beiträge
35
Reaktionspunkte
0
Ort
Osnabrück / Göttingen
Irgendwie finde ich den fehler in meinem Script nicht... und da dachte ich mir, ich lass euch mal gucken ;)

Hier nochmal was dazu, was das Script eigentlich macht:

Es wird von einer anderen Form um eine bestimmte uhrzeit geladen..
Deshalb startet auch alles direkt aus Form_Load und nicht aus nem Button oder so ;)

Nunja.. das Script erstellt eine Textdatei aus verschiedenen Log-Zusammenschnitten ;) und versendet diesen Text dann per email :)

Nun zu meinem Problem..
..Das Script sendet die Email immer wieder.. und wieder.. und wieder ... .. .. :(

Und ich find den Fehler nicht.. hier der Code:

Code: 
Option Explicit
Dim Mailing As Boolean
Dim Result As String
Dim Sec As Integer
Dim TimeOut As Integer
Dim oStream As TextStream
Dim theDrive As Drive

Dim ServerAdd As String
Dim ServerPort As Integer
Dim SendName As String
Dim SendEMail As String
Dim ReceiverMail As String
Dim Domain As String
Dim Login As String
Dim Pass As String
Dim Login64 As String
Dim Pass64 As String

Dim Subject As String
Dim Mailtext As String
Dim Sourcetext As String

Dim var_base64
Dim B64() As Byte

Private Sub Form_Load()
  If GetINI(StatusMail, Status) = 1 Then
    TimeOut = 20
    CreateMsg
    TimerSend.Enabled = True
  Else
    lblMainStatus.ForeColor = &HC0&
    lblMainStatus.Caption = Dienst ist inaktiv
    TimerClose.Enabled = True
  End If
End Sub

'Wenn Prozess noch läuft und geschlossen wird -> protokolieren
Private Sub Form_Unload(Cancel As Integer)
  If Mailing = True Then
    ini = WriteLog(StatusMail, CDbl(CDate(Now)), Abbruch durch Benutzer)
  End If
End Sub

Private Sub TimerClose_Timer()
  Unload Me
  TimerClose.Enabled = False
End Sub

Private Sub TimerSend_Timer()
  SendmailStart
  TimerSend.Enabled = False
End Sub

Private Sub TimerSec_Timer()
  Sec = Sec + 1
  DoEvents
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
  Winsock1.GetData Result
End Sub

Private Function SendmailStart()
  ServerAdd = GetINI(StatusMail, ServerAdd)
  ServerPort = GetINI(StatusMail, ServerPort)
  SendName = GetINI(StatusMail, SendName)
  SendEMail = GetINI(StatusMail, SendEMail)
  Login = GetINI(StatusMail, Login)
  Pass = GetINI(StatusMail, Pass)
  Domain = gcd.de
  ReceiverMail = GetINI(StatusMail, ReceiverMail)
  Subject = GetINI(StatusMail, Subject)
  
  Set oStream = oFSO.OpenTextFile(.\SendMail.txt, ForReading)
  Mailtext = oStream.ReadAll
  
  var_base64 = ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/

 ->Die Austauschtabelle wird in ein Bytearray uebertragen.
  B64() = StrConv(var_base64, vbFromUnicode)
  Login64 = base64_encode(B64(), Login)
  Pass64 = base64_encode(B64(), Pass)
  
  If Mailing = False Then
    If Sendmail Then
      lblMainStatus.ForeColor = &H8000&
      lblMainStatus.Caption = E-Mail erfolgreich versendet
      ini = WriteLog(StatusMail, CDbl(CDate(Now)), E-Mail erfolgreich versendet)
    Else
      lblMainStatus.ForeColor = &HC0&
      lblMainStatus.Caption = Fehler beim Versenden aufgetreten
      ini = WriteLog(StatusMail, CDbl(CDate(Now)), Fehler beim Versenden aufgetreten)
      Exit Function
    End If
  Else
    MsgBox Vorherige E-Mail wird noch gesendet!, vbCritical Or vbOKOnly, Error
  End If
  TimerClose.Enabled = True
End Function

Private Function Sendmail() As Boolean
  On Error GoTo ERRORMail
  
  If Mailing = True Then Exit Function
  Mailing = True
  Sourcetext = 

 ->Wenn keine Verbindung besteht..
  If Winsock1.State = sckClosed Then
    Sourcetext = Sourcetext & From:  & SendName &  < & SendEMail & >
    Sourcetext = Sourcetext & vbCrLf & Date:  & Format(Date, Ddd)
    Sourcetext = Sourcetext & ,  & Format(Date, dd Mmm YYYY) &  
    Sourcetext = Sourcetext & Format(Time, hh:mm:ss) &  +0100 & vbCrLf
    Sourcetext = Sourcetext & X-Mailer: Visual Basic Mailing Tester
    Sourcetext = Sourcetext & vbCrLf & To: < & ReceiverMail & >
    Sourcetext = Sourcetext & vbCrLf & Subject:  & Subject & vbCrLf
    Sourcetext = Sourcetext & vbCrLf & Mailtext & vbCrLf & vbCrLf & . & vbCrLf
    
   ->Verbindung aufbauen
    lblStatus.Caption = Verbindung zum Server wird aufgebaut & vbNewLine
    ini = WriteLog(StatusMail, CDbl(CDate(Now)), Verbindung zum Server wird aufgebaut)
    Winsock1.LocalPort = 0
    Winsock1.RemotePort = ServerPort
    Winsock1.Connect (ServerAdd)
    If Not Response(220) Then
      lblStatusErg.Caption = lblStatusErg.Caption & ERROR & vbNewLine
      GoTo ERRORMail
    End If
    lblStatusErg.Caption = lblStatusErg.Caption & OK & vbNewLine
    
   ->Verbunden
    Winsock1.SendData (HELO  & Domain & vbCrLf)
    ini = WriteLog(StatusMail, CDbl(CDate(Now)), Verbindung erfolgreich aufgebaut)
    
   ->Authorisierung
    lblStatus.Caption = lblStatus.Caption & Authorisierung & vbNewLine
    ini = WriteLog(StatusMail, CDbl(CDate(Now)), Authorisierung)
    Winsock1.SendData (AUTH LOGIN & vbCrLf)
    If Not Response(334) Then
      lblStatusErg.Caption = lblStatusErg.Caption & ERROR & vbNewLine
      GoTo ERRORMail
    End If
    lblStatusErg.Caption = lblStatusErg.Caption & vbNewLine
   
   ->Loginname wird base64 codiert übergeben
    lblStatus.Caption = lblStatus.Caption & Überprüfe Login & vbNewLine
    ini = WriteLog(StatusMail, CDbl(CDate(Now)), Überprüfe Login)
    Winsock1.SendData (Login64 & vbCrLf)
    If Not Response(334) Then
      lblStatusErg.Caption = lblStatusErg.Caption & ERROR & vbNewLine
      ini = WriteLog(StatusMail, CDbl(CDate(Now)), Login: Falsch - Überprüfen Sie die Einstellungen)
      GoTo ERRORMail
    End If
    lblStatusErg.Caption = lblStatusErg.Caption & OK & vbNewLine
    ini = WriteLog(StatusMail, CDbl(CDate(Now)), Login: OK)
    
   ->Passwort wird base64 codiert und übergeben
    lblStatus.Caption = lblStatus.Caption & Überprüfe Passwort & vbNewLine
    ini = WriteLog(StatusMail, CDbl(CDate(Now)), Überprüfe Passwort)
    Winsock1.SendData (Pass64 & vbCrLf)
    If Not Response(235) Then
      lblStatusErg.Caption = lblStatusErg.Caption & ERROR & vbNewLine
      ini = WriteLog(StatusMail, CDbl(CDate(Now)), Passwort: Falsch - Überprüfen Sie die Einstellungen)
      GoTo ERRORMail
    End If
    lblStatusErg.Caption = lblStatusErg.Caption & OK & vbNewLine
    ini = WriteLog(StatusMail, CDbl(CDate(Now)), Password: OK)
    
   ->Mail Senden
    lblStatus.Caption = lblStatus.Caption & Email wird gesendet & vbNewLine
    ini = WriteLog(StatusMail, CDbl(CDate(Now)), Email wird gesendet)
    Winsock1.SendData (MAIL FROM:< & SendEMail & > & vbCrLf)
    If Not Response(250) Then
      lblStatusErg.Caption = lblStatusErg.Caption & ERROR & vbNewLine
      ini = WriteLog(StatusMail, CDbl(CDate(Now)), Fehler! beim senden von: MAIL FROM:< & SendEMail & >)
      GoTo ERRORMail
    End If
    Winsock1.SendData (RCPT TO:< & ReceiverMail & > & vbCrLf)
    If Not Response(250) Then
      lblStatusErg.Caption = lblStatusErg.Caption & ERROR & vbNewLine
      ini = WriteLog(StatusMail, CDbl(CDate(Now)), Fehler! beim senden von: RCPT TO:< & ReceiverMail & >)
      GoTo ERRORMail
    End If
    Winsock1.SendData (DATA & vbCrLf)
    If Not Response(354) Then
      lblStatusErg.Caption = lblStatusErg.Caption & ERROR & vbNewLine
      ini = WriteLog(StatusMail, CDbl(CDate(Now)), Fehler! beim senden von: DATA)
      GoTo ERRORMail
    End If
    Winsock1.SendData (Sourcetext)
    If Not Response(250) Then
      lblStatusErg.Caption = lblStatusErg.Caption & ERROR & vbNewLine
      ini = WriteLog(StatusMail, CDbl(CDate(Now)), Fehler! beim senden vom Sourcetext)
      GoTo ERRORMail
    End If
    
    lblStatusErg.Caption = lblStatusErg.Caption & OK & vbNewLine
    
   ->Trennen
    lblStatus.Caption = lblStatus.Caption & Verbindung mit Server trennen & vbNewLine
    ini = WriteLog(StatusMail, CDbl(CDate(Now)), Verbindung mit Server trennen)
    Winsock1.SendData (quit & vbCrLf)
    lblStatusErg.Caption = lblStatusErg.Caption & OK & vbNewLine
    ini = WriteLog(StatusMail, CDbl(CDate(Now)), Verbindung getrennt)
    Sendmail = True
  End If
  
ERRORMail:
  Winsock1.Close
  Mailing = False
End Function

Private Function Response(RCode$) As Boolean
  Sec = 0
  TimerSec.Interval = 200
  TimerSec.Enabled = True
  Response = True
  
  Do While InStr(1, Result, RCode) = 0
    DoEvents
    If Sec > TimeOut * 5 Then
      If Len(Result) Then
        lblMainStatus.ForeColor = &HC0&
        lblMainStatus.Caption = SMTP Error! Falscher Rückgabewert
        ini = WriteLog(StatusMail, CDbl(CDate(Now)), SMTP Error! Falscher Rückgabewert)
      Else
        lblMainStatus.ForeColor = &HC0&
        lblMainStatus.Caption = SMTP Error! Time out
        ini = WriteLog(StatusMail, CDbl(CDate(Now)), SMTP Error! Time out)
      End If
      
      Response = False
      Exit Do
    End If
  Loop
 
  Result = 
  TimerSec.Enabled = False
End Function

Private Function base64_encode(Code2() As Byte, Source As String) As String
  On Error GoTo base64_encode_Err
  
  Dim n As Long
  Dim i As Long
  Dim c1 As Integer
  Dim c2 As Integer
  Dim c3 As Integer
  Dim w(4) As Integer
  Dim sourceB() As Byte
  Dim Result() As Byte
  Dim l As Long
  Dim k As Long
  Dim rest As Long
  Dim cnt
  
  l = Len(Source)
  If l = 0 Then Exit Function
  sourceB() = StrConv(Source, vbFromUnicode)
  rest = l Mod 3
  If rest > 0 Then
    n = ((l \ 3) + 1) * 3
    ReDim Preserve sourceB(n - 1)
  Else
    n = l
  End If
  ReDim Result(4 * n / 3 - 1)
  cnt = 0
  For i = 0 To n / 3 - 1
    k = 3 * i
    c1 = sourceB(k)
    c2 = sourceB(k + 1)
    c3 = sourceB(k + 2)
    
    w(1) = Int(c1 / 4)
    w(2) = (c1 And 3) * 16 + Int(c2 / 16)
    w(3) = (c2 And 15) * 4 + Int(c3 / 64)
    w(4) = c3 And 63
    
    k = 4 * i
    Result(k) = B64(w(1))
    Result(k + 1) = B64(w(2))
    Result(k + 2) = B64(w(3))
    Result(k + 3) = B64(w(4))
  Next
  
  Select Case rest
    Case 1
      Result(UBound(Result)) = 61
      Result(UBound(Result) - 1) = 61
    Case 2
      Result(UBound(Result)) = 61
  End Select
  
  base64_encode = StrConv(Result, vbUnicode)

base64_encode_End:
  Exit Function
  
base64_encode_Err:
  lblMainStatus.ForeColor = &HC0&
  lblMainStatus.Caption = Fehler beim encoden
  ini = WriteLog(StatusMail, CDbl(CDate(Now)), Fehler beim encoden:  & Err &  /  & Error$ &  / )
  Resume base64_encode_End
End Function

Private Function CreateMsg()
  Set oStream = oFSO.CreateTextFile(.\SendMail.txt, True)
  With oStream
    .WriteLine ===================================================
    .WriteLine Tägliche Status-Mail ( & Format(Now, dd.mm.yyyy - hh:mm:ss) & )
    .WriteLine ===================================================
    .WriteBlankLines 1
    
    .Write Virenupdate 
    If GetINI(VirenUpdate, Status) = 1 Then
      .Write vom  & Format(GetINI(VirenUpdate, LastCheck), dd.mm.yyyy)
      .WriteBlankLines 1
      .WriteLine Replace(GetINI(VirenUpdate, MailStatus), |, vbNewLine)
    Else
      .Write deaktiviert!
    End If
    .WriteBlankLines 1
    .WriteLine ====================================================================================
    .WriteBlankLines 1
    
    .Write Datensicherung 
    If GetINI(Datensicherung, Status) = 1 Then
      .Write vom  & Format(GetINI(Datensicherung, LastCheck), dd.mm.yyyy)
      .WriteBlankLines 1
      .WriteLine Replace(GetINI(Datensicherung, MailStatus), |, vbNewLine)
    Else
      .Write deaktiviert!
    End If
    .WriteBlankLines 1
    .WriteLine ====================================================================================
    .WriteBlankLines 1
    
    .Write File-System 
    If GetINI(FileSystem, Status) = 1 Then
      .Write vom  & Format(Now, dd.mm.yyyy)
      .WriteBlankLines 1
      
      For Each theDrive In oFSO.Drives
         .WriteBlankLines 1
        .WriteLine --------------------------------------------------------------
        .WriteBlankLines 1
        .WriteLine  - Laufwerk  & theDrive
        .WriteBlankLines 1
        If theDrive.IsReady Then
          If GetINI(FileSystem, SendDriveType) = 1 Then .WriteLine     Laufwerkstyp:   & frmFileSystemMain.Laufwerkstyp(theDrive.DriveType)
          If GetINI(FileSystem, SendTotalSize) = 1 Then .WriteLine     Gesamtkapazität:   & FormatNumber(theDrive.TotalSize / 1024, 0) &  KB
          If GetINI(FileSystem, SendAvailableSpace) = 1 Then .WriteLine     Noch verfügbar:   & FormatNumber(theDrive.AvailableSpace / 1024, 0) &  KB
          If GetINI(FileSystem, SendFileSystem) = 1 Then .WriteLine     Dateisystem:   & theDrive.FileSystem
          If GetINI(FileSystem, SendVolumeName) = 1 Then .WriteLine     Bezeichnung:   & theDrive.VolumeName
          If GetINI(FileSystem, SendSerialNumber) = 1 Then .WriteLine     Seriennummer:   & theDrive.SerialNumber
          If GetINI(FileSystem, SendShareName) = 1 And theDrive.DriveType = 3 Then .WriteLine     Freigabename:   & theDrive.ShareName
        Else
          .WriteLine     Laufwerk ist nicht bereit!
        End If
      Next
    Else
      .Write deaktiviert!
    End If
    .WriteBlankLines 1
    .WriteLine ====================================================================================
  End With
End Function


Ich weiss, ich weiss.. ist ziehmlich lang, aber wer lust und Laune hat, darf ruhig nach Fehlern suchen ;)

hF & gL :p


mfG
sp00n
 
  • #2
OuuhhhOuuuhhOuuhhh ;)
wie peinlich.. hab den Fehler schon :)

Die Timer dürfen nicht so aussehen:
Code: 
Private Sub TimerClose_Timer()
  Unload Me
  TimerClose.Enabled = False
End Sub

Private Sub TimerSend_Timer()
  SendmailStart
  TimerSend.Enabled = False
End Sub

sondern so:

Code: 
Private Sub TimerClose_Timer()
  TimerClose.Enabled = False
  Unload Me
End Sub

Private Sub TimerSend_Timer()
  TimerSend.Enabled = False
  SendmailStart
End Sub

*g :D

mfG sp00n
 
Thema:

Finde den Fehler nicht -.-

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums

Themen
113.836
Beiträge
707.957
Mitglieder
51.489
Neuestes Mitglied
DonMartin
Oben