Code aus modSMTP.bas
'# vbInside-Mail-Server
'# SMTP-Funktionen
'# --------------------
'# Datum:   31.08.2002
'# Autor:   Tim Braun
'# E-Mail:  tim@vbinside.de
'# Website: www.vbInside.de
'# --------------------

Option Explicit
Type SMTP_Packet
  Sender As String
  'Der Absender der E-Mail
  Receivers As String
  'Die (optional, sonst nur einer) Empfänger der E-Mail
  MailData As String
  'Der "Mail-Body", also der Text
  WasHelo As Boolean
  'Zeigt an, ob der User HELO gesendet hat
  wData As Boolean
  'Zeigt an, ob auf DATA-Input gewartet wird
End Type
Type TMail
  Sender As String
  Receiver As String
  Subject As String
  Filename As String
End Type
Public SMTP_Port As Long
Public HELO_Msg As String
Public QUIT_Msg As String
Public SMTP_MaxConnections As Long
Public SMTP_TempPath As String
Public SMTP_TimeOut As Long
Public SMTP_LastCommand As String
Private Messages() As SMTP_Packet
Function InitSMTP() As Boolean
' Funktion initialisiert die SMTP-Einstellungen aus \config\smtp.cfg
    On Error Goto errHND
  Dim strTmp As String
  Dim ser As String
  Dim Cfg As String
  Dim cfgCom() As String
  Dim FF As Integer
  Dim i As Long
    
    FF = FreeFile
    
    Open App.Path & "\config\smtp.cfg" For Input As FF
    
    While Not EOF(FF)
      Line Input #FF, ser
      If strTmp > "" Then
        strTmp = strTmp & vbCrLf & ser
      Else
        strTmp = ser
      End If
    Wend
    Close #FF
    
    cfgCom = Split(strTmp, vbCrLf)
    
    For i = LBound(cfgCom) To UBound(cfgCom)
      If cfgCom(i) > "" Then
        Cfg = cfgCom(i)
        If Not Mid(Cfg, 1, 1) = "#" Then
          Select Case Mid(Cfg, 1, InStr(1, Cfg, "=") - 1)
            Case "helo"
              'Begrüßungs-Message
              HELO_Msg = Mid(Cfg, InStr(1, Cfg, "=") + 1)
            Case "quit"
              'Ende-Message
              QUIT_Msg = Mid(Cfg, InStr(1, Cfg, "=") + 1)
            Case "port"
              'SMTP-Port, Standart: 25
              SMTP_Port = CLng(Mid(Cfg, InStr(1, Cfg, "=") + 1))
            Case "timeout"
              'Timeout (für Wiederholung des Sendens)
              SMTP_TimeOut = CLng(Mid(Cfg, InStr(1, Cfg, "=") + 1))
            Case "connections"
              'Maximale Verbindungen
              SMTP_MaxConnections = CLng(Mid(Cfg, InStr(1, Cfg, _
                  "=") + 1))
            Case "mailtemp"
              SMTP_TempPath = Replace(Mid(Cfg, InStr(1, Cfg, "=") _
                  + 1), "$APPPATH", App.Path)
          End Select
        End If
      End If
    Next
    
    'Dem SMTP-Winsock-Control den Port zuweisen,
    'vorher die Verbindung trennen und anschließend
    'überwachen
    
    frmMain.SMTP(0).Close
    frmMain.SMTP(0).LocalPort = SMTP_Port
    frmMain.SMTP(0).Listen
    ReDim Messages(0)
    
    AddSMTPLog "vbInside-SMTP-Server" & vbCrLf & "Initialisierung " & _
        "erfolgreich" & vbCrLf & "Port: " & SMTP_Port
    InitSMTP = True
    Exit Function
errHND:
    MsgBox "Es traten fehler bei der Initialisierung des " & _
        "SMTP-Servers auf." & " Die SMTP-Funktionen werden nicht " & _
        "verfügbar sein!" & vbCrLf & vbCrLf & Err.Description, _
        vbCritical, "SMTP-Initialisierung"
    AddSMTPLog "vbInside-SMTP-Server" & vbCrLf & "Initialisierung " & _
        "fehlgeschlagen" & vbCrLf & Err.Description & vbCrLf & _
        "Port: " & SMTP_Port
    InitSMTP = False
    Exit Function
    
End Function
Function AddSMTPLog(Log As String)
    If frmMain.txtSMTPLog > "" Then
      frmMain.txtSMTPLog = frmMain.txtSMTPLog & vbCrLf & Log
    Else
      frmMain.txtSMTPLog = Log
    End If
End Function
Function DeleteMessage(MesID As Integer)
'Bestimmte Message löschen
    On Error Resume Next
    With Messages(MesID)
      .MailData = ""
      .Receivers = ""
      .Sender = ""
    End With
End Function
Function CreateNewMessage(MesID As Integer)
'Diese Funktion erstellt ein neues Feld im Array
'Messages, welches im weiteren Transfer mit Sender,
'Empfänger und Mail-Daten gefüllt werden wird.
  Dim Filename As String
    Filename = SMTP_TempPath & Hex(Date) & Hex(Hour(Time)) & _
        Hex(Minute(Time)) & Hex(Second(Time)) & MesID & ".mail"
    If Not Dir(SMTP_TempPath, vbDirectory) <> "" Then
      MkDir SMTP_TempPath
    End If
    
    If MesID > UBound(Messages) Then
      ReDim Preserve Messages(MesID)
      Messages(MesID).MailData = Filename
      Messages(MesID).Receivers = ""
      Messages(MesID).Sender = ""
      Messages(MesID).WasHelo = False
    Else
      Messages(MesID).MailData = Filename
      Messages(MesID).Receivers = ""
      Messages(MesID).Sender = ""
      Messages(MesID).WasHelo = False
    End If
End Function
Function AddSender(MesID As Integer, Sender As String)
'Sender hinzufügen
    If Not MesID > UBound(Messages) Then
      Messages(MesID).Sender = Trim(Sender)
    End If
End Function
Function AddReceiver(MesID As Integer, Receiver As String)
'Empfänger hinzufügen
    If Not MesID > UBound(Messages) Then
      If Messages(MesID).Receivers <> "" Then
        Messages(MesID).Receivers = Messages(MesID).Receivers & _
            "," & Trim(Receiver)
      Else
        Messages(MesID).Receivers = Trim(Receiver)
      End If
    End If
End Function
Function AddMailData(MesID As Integer, MailData As String)
'Data-Teile hinzufügen
  Dim FF As Integer
    
    FF = FreeFile
    If Not MesID > UBound(Messages) Then
      Open Messages(MesID).MailData For Binary As #FF
      Seek #FF, LOF(FF) + 1
      Put #FF, , MailData
      Close #FF
    End If
End Function
Function SetHELO(MesID As Integer, HELO As Boolean)
'Gibt an ob der User HELO gesendet hat
    If Not MesID > UBound(Messages) Then
      Messages(MesID).WasHelo = HELO
    End If
End Function
Function WriteTemplateMessage(MesID As Integer)
'Alle bisherigen Daten in die temporäre Datei
'schreiben
  Dim FF As Integer
    
    FF = FreeFile
    
    Open Messages(MesID).MailData For Output As #FF
    Print #FF, Messages(MesID).Sender
    Print #FF, Messages(MesID).Receivers
    Close #FF
End Function
Function GetHELO(MesID As Integer) As Boolean
    On Error Resume Next
    GetHELO = Messages(MesID).WasHelo
End Function
Function IsvalidSender(Sender As String) As Boolean
'Stellt fest, ob die angegebene Adresse "echt" ist
    If Not InStr(1, Sender, "@") <> 0 Then
      IsvalidSender = False
    Else
      IsvalidSender = True
    End If
    If Not InStr(1, Sender, ".") <> 0 Then
      IsvalidSender = False
    Else
      IsvalidSender = True
    End If
    
End Function
Function IsvalidReceiver(Receiver As String) As Boolean
'Stellt fest, ob die angegebene Adresse "echt" ist
    If Not InStr(1, Receiver, "@") <> 0 Then
      IsvalidReceiver = False
    Else
      IsvalidReceiver = True
    End If
    If Not InStr(1, Receiver, ".") <> 0 Then
      IsvalidReceiver = False
    Else
      IsvalidReceiver = True
    End If
    If Not InStr(1, Receiver, "<") <> 0 Then
      IsvalidReceiver = False
    Else
      IsvalidReceiver = True
    End If
    If Not InStr(1, Receiver, ">") <> 0 Then
      IsvalidReceiver = False
    Else
      IsvalidReceiver = True
    End If
End Function
Function AddLWIP(IP As String, State As String, Index As Integer)
  Dim x As Long
    x = frmMain.lvwSMTP.ListItems.Count + 1
    With frmMain.lvwSMTP
      .ListItems.Add x, "#" & Index, IP
      .ListItems("#" & Index).SubItems(1) = State
    End With
End Function
Function DelLWIP(Index As Integer)
    On Error Resume Next
    frmMain.lvwSMTP.ListItems.Remove "#" & Index
End Function
Function SetLWState(Index As Integer, State As String)
    frmMain.lvwSMTP.ListItems("#" & Index).SubItems(1) = State
End Function
Function SetWData(MesID As Integer, wData As Boolean)
    If Not MesID > UBound(Messages) Then
      Messages(MesID).wData = wData
    End If
End Function
Function GetWData(MesID As Integer) As Boolean
    If Not MesID > UBound(Messages) Then
      GetWData = Messages(MesID).wData
    End If
End Function