form1.frm

Winsock控件发送Email

         Caption         =   "SMTP Help"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim Progress
Dim Green_Light As Boolean
Dim DATAFile As String
Dim Helo_Ok As Boolean
Dim do_cancel As Boolean

Private Sub about_Click()
Dim a
a = MsgBox("This program was made by Martin McCormick", vbOKOnly + vbInformation, "About")

End Sub

Private Sub CANCEL_SEND_Click()
    Winsock1.Close
    Winsock1.RemotePort = 0
    Winsock1.LocalPort = 0
    do_cancel = True
    Progress = 0
    STATUS.Text = "Canceled."
    Log "Canceled Sending."
End Sub

Private Sub Command1_Click()
Call hhelp_Click
End Sub

Private Sub exer_Click()
End
End Sub

Private Sub Form_Load()
    Progress = 0
    do_cancel = False
    Load LOG_FORM
    LOG_FORM.Show
End Sub

Private Sub Form_Terminate()
    Unload Me
    Me.Hide
    Unload LOG_FORM
    LOG_FORM.Hide
    End
End Sub

Private Sub Form_Unload(Cancel As Integer)
    End
End Sub

Private Sub hhelp_Click()
Dim aa
aa = MsgBox("For SMTP Host either type the SMTP Host of your fake e-mail address or pick one of the buttons above to give you an SMTP Host name Also your fake e-mail must work with the SMTP Host name (if you picked yahoo your fake e-mail must be, [e-mail])", vbOKOnly + vbInformation, "Help")


End Sub

Private Sub MAIL_RESET_Click()
    ' this way is better, just in case we add more controls
    ' we dont have to change the code.
    Dim oCtl As Control
    For Each oCtl In Me.Controls
        If TypeOf oCtl Is TextBox Then
            oCtl.Text = ""
        End If
    Next oCtl
End Sub
Private Function CheckText() As Boolean
    Dim bReturn As Boolean
    Dim oCtl As Control
    bReturn = True
    For Each oCtl In Me.Controls
        If TypeOf oCtl Is TextBox Then
            If oCtl.Text = "" And oCtl.Name <> "STATUS" Then
                bReturn = False
                Log "No text in " & oCtl.Name
            End If
        End If
    Next oCtl
    
    CheckText = bReturn
    
End Function

Private Sub Option1_Click()
SMTP_HOST.Text = "smtp.email.msn.com"

End Sub

Private Sub Option10_Click()
'mail.geocities.com
SMTP_HOST.Text = "mail.geocities.com"
End Sub

Private Sub Option11_Click()
SMTP_HOST.Text = "mail.bluelight.com"
End Sub

Private Sub Option12_Click()
'inbound-mail.netzero.net
SMTP_HOST.Text = "inbound-mail.netzero.net"
End Sub

Private Sub Option13_Click()
'mail5.microsoft.com
SMTP_HOST.Text = "mail5.microsoft.com"
End Sub

Private Sub Option2_Click()
SMTP_HOST.Text = "smtp.mail.yahoo.com"
End Sub

Private Sub Option3_Click()
SMTP_HOST.Text = "mail.hotmail.com"
End Sub

Private Sub Option4_Click()
'209.174.47.10
SMTP_HOST.Text = "mccracken.skokie735.k12.il.us"
Dim ac
ac = MsgBox("Fake email must be [e-mail]", vbInformation + vbOKOnly, "Reminder")
End Sub

Private Sub Option5_Click()
SMTP_HOST.Text = "mail.atl.bellsouth.net"
End Sub

Private Sub Option6_Click()
SMTP_HOST.Text = "smtp.paradise.net.nz"
End Sub

Private Sub Option7_Click()
SMTP_HOST.Text = "smtp.xtra.co.nz"
End Sub

Private Sub Option8_Click()
SMTP_HOST.Text = "mail-intake-1.mail.com"
End Sub

Private Sub Option9_Click()
SMTP_HOST.Text = "mx.boston.juno.com"
End Sub

Private Sub SEND_MAIL_Click()
REPLY_TO.Text = MAIL_FROM.Text
    
    Green_Light = False
    Progress = 0
    Helo_Ok = False
    do_cancel = False
    On Error Resume Next
    
    Dim i As Boolean
    i = CheckText()
    If i = False Then MsgBox "Missing Something, read log.": Exit Sub
        
    If InStr(1, MAIL_FROM, "@") = 0 Then
        MsgBox "the Senders email address must contain an @ character"
        MAIL_FROM.SetFocus
        MAIL_FROM.SelStart = 0
        MAIL_FROM.SelLength = Len(MAIL_FROM)
        Log "Error, no @ in senders email address, stoping send."
        Exit Sub
    End If
    
    Winsock1.Close
    Winsock1.Connect SMTP_HOST, "25"
    
    Do While Winsock1.State <> sckConnected
        DoEvents
        STATUS.Text = "Connecting to " & SMTP_HOST & ". Please wait."
        If do_cancel = True Then STATUS = "Canceled...": do_cancel = False: Winsock1.SendData "QUIT" & Chr$(13) & Chr$(10): Exit Sub
    Loop
    
    STATUS.Text = "Connected to " & SMTP_HOST & "."
    Log "Connected to " & SMTP_HOST & "."
    
    Do While Green_Light = False
        DoEvents
        STATUS.Text = "Waiting for reply..."
        If do_cancel = True Then STATUS = "Canceled...": do_cancel = False: Winsock1.SendData "QUIT" & Chr$(13) & Chr$(10): Exit Sub
    Loop
    
    Winsock1.SendData "HELO " & Mid(MAIL_FROM, InStr(1, MAIL_FROM, "@") + 1, Len(MAIL_FROM)) & Chr$(13) & Chr$(10)
    Log "HELO " & Mid(MAIL_FROM, InStr(1, MAIL_FROM, "@") + 1, Len(MAIL_FROM))
    
    Do While Helo_Ok = False
        DoEvents
        STATUS.Text = "Waiting for reply..."
        If do_cancel = True Then STATUS = "Canceled...": do_cancel = False: Winsock1.SendData "QUIT" & Chr$(13) & Chr$(10): Exit Sub
    Loop
    
    Winsock1.SendData "MAIL FROM: <" & MAIL_FROM & ">" & Chr$(13) & Chr$(10)
    Log "MAIL FROM: " & MAIL_FROM
    
    Do While Progress <> 1
        DoEvents
        STATUS.Text = "Sending data. (1 of 3)"
        If do_cancel = True Then STATUS = "Canceled...": do_cancel = False: Winsock1.SendData "QUIT" & Chr$(13) & Chr$(10): Exit Sub
    Loop
    
    Winsock1.SendData "RCPT TO: <" & RCPT_TO & ">" & Chr$(13) & Chr$(10)
    Log "RCPT TO: " & RCPT_TO
    
    Do While Progress <> 2
        DoEvents
        STATUS.Text = "Sending data. (2 of 3)"
        If do_cancel = True Then STATUS = "Canceled...": do_cancel = False: Winsock1.SendData "QUIT" & Chr$(13) & Chr$(10): Exit Sub
    Loop
    
    Winsock1.SendData "DATA" & Chr$(13) & Chr$(10)
    Log "DATA"
    
    Do While Progress <> 3
        DoEvents
        STATUS.Text = "Setting up body transfer..."
        If do_cancel = True Then STATUS = "Canceled...": do_cancel = False: Winsock1.SendData "QUIT" & Chr$(13) & Chr$(10): Exit Sub
    Loop
    
    Winsock1.SendData GenerateMessageID(Mid(MAIL_FROM, InStr(1, MAIL_FROM, "@") + 1, Len(MAIL_FROM))) & Chr$(13) & Chr$(10)
    Winsock1.SendData "DATE: " & Format(Now, "h:mm:ss") & Chr$(13) & Chr$(10)
    Winsock1.SendData "FROM: " & FROM & " <" & MAIL_FROM & ">" & Chr$(13) & Chr$(10)
    Winsock1.SendData "TO: " & MAIL_TO & " <" & RCPT_TO & ">" & Chr$(13) & Chr$(10)
    Winsock1.SendData "Reply-to: " & " <" & REPLY_TO & ">" & Chr$(13) & Chr$(10)
    Winsock1.SendData "SUBJECT: " & SUBJECT & Chr$(13) & Chr$(10)
    Winsock1.SendData "MIME-Version: 1.0" & Chr$(13) & Chr$(10)
    Winsock1.SendData "Content-Type: text/plain; charset=us-ascii" & Chr$(13) & Chr$(10)
    Winsock1.SendData Chr$(13) & Chr$(10)
    
    Winsock1.SendData DATA & Chr$(13) & Chr$(10)
    Log DATA
    Winsock1.SendData Chr$(13) & Chr$(10) & "." & Chr$(13) & Chr$(10)
    
    Log Chr$(13) & Chr$(10) & "."
    
    Do While Progress <> 4
        DoEvents
        STATUS.Text = "Sending data. (3 of 3)"
        If do_cancel = True Then STATUS = "Canceled...": do_cancel = False: Winsock1.SendData "QUIT" & Chr$(13) & Chr$(10): Exit Sub
    Loop
    
    Winsock1.SendData "QUIT" & Chr$(13) & Chr$(10)
    STATUS.Text = "Done"
    Winsock1.Close
    Winsock1.RemotePort = 0
    Winsock1.LocalPort = 0
    do_cancel = False
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim Reply
On Error GoTo retry:
retry:
    Winsock1.GetData DATAFile
On Error Resume Next
    Reply = Mid(DATAFile, 1, 3)
    
    Log DATAFile
    ' this is cleaner, alot less If/Then's, if we handle
    ' all of the replies in a select/case
    Select Case Reply
        Case 250, 354
            Progress = Progress + 1
            Helo_Ok = True
        Case 220
            Green_Light = True
        Case 503
            Log "Error, helo command failed, or was never sent."
        Case 451
            MsgBox "The site you are attempting to send to requires that the hostname ([e-mail]) actually exists." & vbCrLf & vbCrLf & "This means that you cannot use " & Me.RCPT_TO & " as the fake from address."
            Log "The site you are attempting to send to requires that the hostname ([e-mail]) actually exists." & vbCrLf & vbCrLf & "This means that you cannot use " & Me.RCPT_TO & " as the fake from address."
            CANCEL_SEND_Click
    End Select
        
End Sub

Private Sub Log(ByVal sText As String)
    ' this way it doesnt refresh the whole thing every time, no blinking...
    With LOG_FORM.LOG_TEXT
        .SelStart = Len(.Text)
        .SelText = sText & Chr$(13) & Chr$(10)
        .SelLength = 0
    End With

End Sub

Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
    Log Number & " / " & Description
End Sub

Private Function GenerateMessageID(ByVal sHost As String) As String
    Dim idnum As Double
    Dim sMessageID As String
    
    sMessageID = "Message-ID: "
    
    ' this makes the randomize seed different every time
    Randomize Int(CDbl((Now))) + Timer
    
    idnum = GetRandom(9999999999999#, 99999999999999#)
    
    sMessageID = sMessageID & CStr(idnum)
    
    idnum = GetRandom(9999, 99999)
    
    sMessageID = sMessageID & "." & CStr(idnum) & ".qmail@" & sHost
    
    GenerateMessageID = sMessageID
    
End Function
Private Function GetRandom(ByVal dFrom As Double, ByVal dTo As Double) As Double

    Dim x As Double
    Randomize
    x = dTo - dFrom
    GetRandom = Int((x * Rnd) + 1) + dFrom
    
End Function