smtp.frm

发送带附件Email

         BeginProperty Font 
            Name            =   "幼圆"
            Size            =   9.75
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   255
         Left            =   3840
         TabIndex        =   9
         Top             =   600
         Width           =   1215
      End
      Begin VB.Label Label5 
         Alignment       =   1  'Right Justify
         Caption         =   "主题："
         BeginProperty Font 
            Name            =   "幼圆"
            Size            =   9.75
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   255
         Left            =   60
         TabIndex        =   8
         Top             =   1020
         Width           =   1215
      End
   End
   Begin VB.Frame Frame1 
      Caption         =   "正文"
      BeginProperty Font 
         Name            =   "幼圆"
         Size            =   9.75
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   2295
      Left            =   60
      TabIndex        =   0
      Top             =   2220
      Width           =   7935
      Begin VB.TextBox txtContent 
         BeginProperty Font 
            Name            =   "幼圆"
            Size            =   9.75
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   1875
         Left            =   120
         MultiLine       =   -1  'True
         ScrollBars      =   2  'Vertical
         TabIndex        =   1
         Text            =   "smtp.frx":0000
         Top             =   300
         Width           =   7695
      End
   End
   Begin MSWinsockLib.Winsock Wsock 
      Left            =   6600
      Top             =   1680
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
End
Attribute VB_Name = "smtp"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public ServerIp As String 'SMTP服务器地址
Public ServerPort As Long 'SMTP服务器端口

Dim strSendName As String '发送人姓名
Dim strReceiveName As String '接收人姓名
Dim strFromMail As String '发送人地址
Dim strToMail As String '接收人地址
Dim m_Date As String '发送日期
Dim strSubject As String '主题
Dim strContent As String '正文
Dim Information As String '从服务器接收响应消息

Private Sub cmdAtt_Click()
Dim i As Integer
For i = 0 To cobAtt.ListCount - 1
    frmAtt.LstAtt.AddItem cobAtt.List(i)
Next i
cobAtt.Clear
frmAtt.Show vbModal
End Sub

Private Sub cmdSend_Click()
If cobAtt.ListCount > 0 Then
    GenMail True
Else
    GenMail False
End If
'设置Winsock
Wsock.Close
Wsock.RemoteHost = ServerIp
Wsock.RemotePort = ServerPort
'连接SMTP服务器
Wsock.Connect
If Not WaitForResponse("220", 10) Then
    txtMsg.Text = "邮件服务器连接不上......"
    Exit Sub
End If
'打开对话
Wsock.SendData "HELO" & " " & Wsock.LocalHostName & vbCrLf
If Not WaitForResponse("250", 10) Then
    txtMsg.Text = txtMsg.Text & "无法打开邮件发送对话" & vbCrLf
    Exit Sub
End If
'发送发送方地址
Wsock.SendData "MAIL FROM:" & " " & strFromMail & vbCrLf
If Not WaitForResponse("250", 10) Then
    txtMsg.Text = txtMsg.Text & "无法发送发送方地址" & vbCrLf
    Exit Sub
End If
'发送接收方地址
Wsock.SendData "RCPT TO:" & " " & strToMail & vbCrLf
If Not WaitForResponse("250", 10) Then
    txtMsg.Text = txtMsg.Text & "无法发送接收方地址" & vbCrLf
    Exit Sub
End If
'发送消息体
Wsock.SendData "DATA" & vbCrLf
If Not WaitForResponse("354", 10) Then
    txtMsg.Text = txtMsg.Text & "无法发送消息体" & vbCrLf
    Exit Sub
  
End If
Dim fnum As Integer
fnum = FreeFile
Open App.Path & "\mail.tmp" For Input As #fnum
'Wsock.SendData mData & vbCrLf
While Not EOF(fnum)
    Line Input #fnum, strContent
    Wsock.SendData strContent & vbCrLf
Wend
Close #fnum
Wsock.SendData "." & vbCrLf
If Not WaitForResponse("250", 20) Then
    txtMsg.Text = txtMsg.Text & "消息体发送不成功" & vbCrLf
    Exit Sub
End If
'结束邮件发送对话
Wsock.SendData "QUIT" & vbCrLf
If Not WaitForResponse("221", 10) Then
    Exit Sub
End If
Wsock.Close
txtMsg.Text = txtMsg.Text & "邮件发送成功"
End Sub

'该按扭事件过程用于设置smtp服务器
Private Sub cmdSetUp_Click()
frmSetup.Show
End Sub

'程序加载时读出上次的设置
Private Sub Form_Load()
ServerIp = GetSetting("email", "smtpserver", "serverip", "")
ServerPort = GetSetting("email", "smtpserver", "serverport", 25)
Wsock.Protocol = sckTCPProtocol
End Sub

'程序退出时保存设置
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
SaveSetting "email", "smtpserver", "serverip", ServerIp
SaveSetting "email", "smtpserver", "serverport", ServerPort
End Sub

'接收服务器的响应消息
Private Sub Wsock_DataArrival(ByVal bytesTotal As Long)
Wsock.GetData Information
txtMsg.Text = txtMsg.Text & Information & vbCrLf
End Sub

'该函数用于等待服务器响应码
Private Function WaitForResponse(strResponse As String, WaitTime As Integer) As Boolean
Dim WaitSt As Date
WaitSt = Now()
While InStr(1, Information, strResponse, vbTextCompare) < 1
    DoEvents
    If DateDiff("s", WaitSt, Now) > WaitTime Then
       Information = ""
       WaitForResponse = False
       Exit Function
    End If
Wend
Information = ""
WaitForResponse = True
End Function

'该函数用于构造信件内容
Private Sub GenMail(bAttachment As Boolean)
Dim fnum As Integer, FAttin As Integer
Dim strLine As String
strSendName = txtSName.Text
strReceiveName = txtRName.Text
strFromMail = txtFrom.Text
strToMail = txtTo.Text
m_Date = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0600"
strSubject = txtSubject.Text
strContent = txtContent.Text
fnum = FreeFile()
Open App.Path & "\mail.tmp" For Output As fnum
'构造信件标题字段
Print #fnum, "From:" & Chr(32) & strSendName
Print #fnum, "Date:" & Chr(32) & m_Date
Print #fnum, "X-Mailer: BigAnt Smtp Mailer V1.0"
Print #fnum, "To:" & Chr(32) & strReceiveName
Print #fnum, "Subject:" & Chr(32) & strSubject
If bAttachment = False Then
    Print #fnum, ""
    Print #fnum, strContent
    Exit Sub
End If
Print #fnum, "MIME-Version: 1.0"
Print #fnum, "Content-type:multipart/mixed;"
Print #fnum, " boundary =""----=_NextPart_000_000A_01BF9F1A"""
Print #fnum, ""
'书写信件的正文内容
Print #fnum, "--" & "----=_NextPart_000_000A_01BF9F1A"
Print #fnum, "Content-Type: text/plain;"
Print #fnum, "    Charset = ""gb2312"""
Print #fnum, "Content-Transfer-Encoding: 8bit"
Print #fnum, ""
Print #fnum, strContent
'附件内容
Dim i As Integer
For i = 0 To cobAtt.ListCount - 1
    Base64Encode cobAtt.List(i), App.Path & "\attachment" & i & ".tmp"
    Print #fnum, "--" & "----=_NextPart_000_000A_01BF9F1A"
    Print #fnum, "Content-Type: Application/octet-stream"
    Print #fnum, "  name=" & cobAtt.List(i)
    Print #fnum, "Content-Transfer-Encoding: base64"
    Print #fnum, "Content-Disposition: attachment;"
    Print #fnum, "  FileName=" & cobAtt.List(i)
    Print #fnum, ""
    FAttin = FreeFile
    Open App.Path & "\attachment" & i & ".tmp" For Input As #FAttin
    While Not EOF(FAttin)
        Line Input #FAttin, strLine
        Print #fnum, strLine
    Wend
    Close FAttin
Next i
Print #fnum, "--" & "----=_NextPart_000_000A_01BF9F1A" & "--"
Close fnum
End Sub