VB6 发送电子邮件源码

Private Sub SendInf()
Dim strserver As String
Dim ColonPos As Integer
Dim lngPort As Long
Dim NameSpace As String

On Error GoTo err

again1:

        getaddress = "32*******9@qq.com"    '收件邮箱
            
        strserver = "smtp.163.com"         '发件邮箱smtp服务器
        txtfrom = "13*******58@163.com"    '发件邮箱
        user = "13********8@163.com"       '发件邮箱登录名称
        txtpwa = "ro**********1"           '发件邮箱登录密码
        
        subject = "张三丰 的登录验证码：1Li0P" 
        toname = "张三丰"
        txtMessage = "尊敬的" + "张三丰" + "阁下，您" + Format(Now, "YYYY年MM月DD日 HH时MM分SS秒") + "的登录验证码为：1Li0P ，祝您工作愉快！"
        
        If Option1.Value = True Then
                Winsock1.Close
                Winsock1.LocalPort = 0
                strserver = strserver
                ColonPos = InStr(strserver, ":")
                If ColonPos = 0 Then
                    Winsock1.Connect strserver, 25
                Else
                    lngPort = CLng(Right$(strserver, Len(strserver) - ColonPos))
                    strserver = Left$(strserver, ColonPos - 1)
                    Winsock1.Connect strserver, lngPort
                End If
                m_State = MAIL_CONNECT    '
                Frame2.Visible = True
                Label5.Caption = "试图连接邮件服务器" + strserver + "，请稍等..."
        Else                                                                      '使用CDO.Message来发送邮件
                NameSpace = "http://schemas.microsoft.com/cdo/configuration/"
                Set email = CreateObject("CDO.Message")
                email.From = txtfrom          '发件邮箱
                email.To = getaddress         '收件邮箱
                email.subject = subject       '邮件主题
                email.Textbody = txtMessage   '邮件内容
            
                With email.Configuration.Fields
                    .Item(NameSpace & "sendusing") = 2
                    .Item(NameSpace & "smtpserver") = strserver   'smtp服务器，QQ的是：smtp.qq.com
                    .Item(NameSpace & "smtpserverport") = 25      '端口，不要改！好象除smtp.qq.com外，其它服务器都是用 25 端口
                    .Item(NameSpace & "smtpauthenticate") = 1
                    .Item(NameSpace & "sendusername") = user      '邮箱用户名（QQ的对应QQ号）
                    .Item(NameSpace & "sendpassword") = txtpwa    '邮箱密码（QQ的对应邮箱密码）
                    .Update
                End With
                        
                Frame2.Visible = True
                Label5.Caption = "试图连接邮件服务器" + strserver + "，请稍等..."
                
                email.Send
                
                If Error <> "" Then
                    SendErrNo = SendErrNo + 1
                    If SendErrNo < 6 Then
                       GoTo again1:
                    Else
                        Label5.Caption = "发验证码到 ********" + Right(getaddress, Len(getaddress) - InStr(getaddress, "@") + 3) & " 失败！请稍候再获取验证码。"
                        EmailPoi = EmailNumber + 1
                    End If
                Else
                    Label5.Caption = "验证码已发送到邮箱 ********" + Right(getaddress, Len(getaddress) - InStr(getaddress, "@") + 3)
                    SendErrNo = 0
                    Command3.Enabled = False
                    Timer6.Enabled = True
                    EmailPoi = EmailPoi + 1
                    GoTo again1:
                End If
        End If



Exit Sub

err:
   If Option1.Value = True Then
        Frame2.Visible = False
        MsgBox "系统监测到异常的错误编号：" & err.Number & " ，错误描述：" & err.Description & "，有可能是winsock控件为能注册，请退出系统，以管理员身份运行系统目录下‘注册控件.bat’！", vbCritical + vbOKOnly, "错误提示"
   Else
        SendErrNo = SendErrNo + 1
        If SendErrNo < 6 Then
            GoTo again1:
        Else
            Label5.Caption = "发验证码到 ********" + Right(getaddress, Len(getaddress) - InStr(getaddress, "@") + 3) & " 失败！请稍候再获取验证码。"
            EmailPoi = EmailNumber + 1
        End If
   End If
End Sub

​