frmmassemail.frm

用VB实现的一个Email群发(邮件群发)的功能

   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      BackColor       =   &H8000000B&
      Caption         =   "发信人名称："
      BeginProperty Font 
         Name            =   "Times New Roman"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   225
      Left            =   120
      TabIndex        =   9
      Top             =   480
      Width           =   1440
   End
End
Attribute VB_Name = "FrmMassEmail"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim Response As String, Reply As Integer, DateNow As String
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
Dim start As Single, Tmr As Single
Private FilePathName As String
Sub SendEmail(MailServerName As String, FromName As String, FromEmailAddress As String, ToName As String, ToEmailAddress As String, EmailSubject As String, EmailBodyOfMessage As String)
'邮件发送函数
    '注意一定要将本地端口设置为0，否则只能发送一封邮件
    Winsock1.LocalPort = 0
    If Winsock1.State = sckClosed Then
        '信息初始化
        DateNow = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0600"
        first = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf
        Second = "rcpt to:" + Chr(32) + ToEmailAddress + vbCrLf
        Third = "Date:" + Chr(32) + DateNow + vbCrLf
        Fourth = "From:" + Chr(32) + FromName + vbCrLf
        Fifth = "To:" + Chr(32) + ToNametxt + vbCrLf
        Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf
        Seventh = EmailBodyOfMessage + vbCrLf
        Ninth = "" + vbCrLf
        Eighth = Fourth + Third + Ninth + Fifth + Sixth
        Winsock1.Protocol = sckTCPProtocol
        '设置服务器和端口
        Winsock1.RemoteHost = MailServerName
        Winsock1.RemotePort = 25
        Winsock1.Connect
        '以下代码请读者查看服务器返回的代码表
        WaitFor ("220")
        StatusTxt.Caption = "连接中…"
        StatusTxt.Refresh
        Winsock1.SendData ("HELO " + vbCrLf)
        WaitFor ("250")
        StatusTxt.Caption = "已连接"
        StatusTxt.Refresh
        Winsock1.SendData (first)
        StatusTxt.Caption = "消息发送…"
        StatusTxt.Refresh
        WaitFor ("250")
        Winsock1.SendData (Second)
        WaitFor ("250")
        Winsock1.SendData ("data" + vbCrLf)
        WaitFor ("354")
        Winsock1.SendData (Eighth + vbCrLf)
        Winsock1.SendData (Seventh + vbCrLf)
        Winsock1.SendData ("." + vbCrLf)
        WaitFor ("250")
        Winsock1.SendData ("quit" + vbCrLf)
        StatusTxt.Caption = "断开连接中…"
        StatusTxt.Refresh
        WaitFor ("221")
        Winsock1.Close
    Else
        MsgBox (Str(Winsock1.State))
    End If
End Sub
Sub WaitFor(ResponseCode As String)
'等待服务器代码
        start = Timer
        While Len(Response) = 0
            Tmr = start - Timer
            '注意务必使用下面的DoEvents
            DoEvents
            If Tmr > 50 Then
                MsgBox "SMTP服务器错误， 相应时间超出！", 64, MsgTitle
                Exit Sub
            End If
        Wend
        While Left(Response, 3) <> ResponseCode
            DoEvents
            If Tmr > 50 Then
                MsgBox "SMTP 服务器错误！, 代码为：" + ResponseCode + " Code recieved: " + Response, 64, MsgTitle
                Exit Sub
            End If
        Wend
    '清空，不给下次调用带来麻烦
    Response = ""
End Sub


Private Sub Command1_Click()
On Error Resume Next
If List1.ListCount = 0 Then
MsgBox "至少应用一个收信人！", vbCritical
Exit Sub
End If
Dim x As Long
Dim Y As Long
Y = 0
x = Text1.Text
PB1.Max = List1.ListCount * Text1.Text
PB1.Min = 0
PB1.Value = 0
List1.ListIndex = 0
Do Until List1.ListIndex = List1.ListCount - 1
Do Until Y = x
    SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, List1.Text, List1.Text, txtEmailSubject.Text, txtEmailBodyOfMessage.Text
    StatusTxt.Caption = "Mail Sent"
    Label9.Caption = "正在发送第" & PB1.Value & "个，总数为" & PB1.Max
    StatusTxt.Refresh
    Label9.Refresh
    DoEvents
    DoEvents
    Close
Y = Y + 1
PB1.Value = PB1.Value + 1
Loop
    List1.ListIndex = List1.ListIndex + 1
Loop
Y = 0
Do Until Y = x
    SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, List1.Text, List1.Text, txtEmailSubject.Text, txtEmailBodyOfMessage.Text
    StatusTxt.Caption = "Mail Sent"
    Label9.Caption = "Sending message " & PB1.Value & " of " & PB1.Max
    StatusTxt.Refresh
    Label9.Refresh
    DoEvents
    DoEvents
    Close
Y = Y + 1
PB1.Value = PB1.Value + 1
Loop
StatusTxt.Caption = "发送完毕！"
Label9.Caption = "发送完毕！"
Label9.Refresh
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub Command3_Click()
FrmMassEmailAdd.Show
End Sub
Private Sub Command4_Click()
On Error Resume Next
List1.RemoveItem List1.ListIndex
End Sub
Private Sub Form_Load()
    On Error Resume Next
    Dim AppDir As String
    Dim name As String
    AppDir = App.Path
    '读入文件，完成初始化
    Call List_Load(List1, App.Path & "\EmailList.ini")
    DoEvents
    FilePathName = AppDir + "\MassEmail.inf"
    EmailAddress = GetPrivateProfileString("settings", "emailaddress", "", FilePathName)
    name = GetPrivateProfileString("settings", "name", "", FilePathName)
    smtp = GetPrivateProfileString("settings", "smtp", "", FilePathName)
    subject = GetPrivateProfileString("settings", "subject", "", FilePathName)
    boomb = GetPrivateProfileString("settings", "boomb", "", FilePathName)
    DoEvents
    txtFromEmailAddress.Text = EmailAddress
    txtFromName.Text = name
    txtEmailServer.Text = smtp
    txtEmailSubject.Text = subject
    Text1.Text = boomb
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Dim fFile As Integer
    fFile = FreeFile
    Winsock1.Close
    '写入记录
    Call List_Save(List1, App.Path & "\EmailList.ini")
    DoEvents
    Open App.Path & "\MassEmail.inf" For Output As fFile
    Print #fFile, "[settings]"
    Print #fFile, "emailaddress=" & txtFromEmailAddress.Text
    Print #fFile, "name=" & txtFromName.Text
    Print #fFile, "smtp=" & txtEmailServer.Text
    Print #fFile, "subject=" & txtEmailSubject.Text
    Print #fFile, "boomb=" & Text1.Text
    Close fFile
    DoEvents
    End
End Sub
Private Sub Timer1_Timer()
    Label4.Caption = "已有总人数：" & List1.ListCount
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Winsock1.GetData Response
End Sub
Public Sub List_Add(list As listbox, txt As String)
On Error Resume Next
    List1.AddItem txt
End Sub
Public Sub List_Load(thelist As listbox, FileName As String)
    On Error Resume Next
    Dim TheContents As String
    Dim fFile As Integer
    fFile = FreeFile
    Open FileName For Input As fFile
    Do
        Line Input #fFile, TheContents$
        If TheContents$ = "" Then
        Else
        Call List_Add(List1, TheContents$)
        End If
    Loop Until EOF(fFile)
    Close fFile
End Sub
Public Sub List_Save(thelist As listbox, FileName As String)
    On Error Resume Next
    Dim Save As Long
    Dim fFile As Integer
    fFile = FreeFile
    Open FileName For Output As fFile
    For Save = 0 To thelist.ListCount - 1
        Print #fFile, List1.list(Save)
    Next Save
    Close fFile
End Sub
Private Function GetPrivateProfileString(ByVal szSection As String, ByVal szEntry As Variant, ByVal szDefault As String, ByVal szFileName As String) As String
'处理INI文件的函数
   Dim szTmp As String
   Dim nRet As Long
   If (IsNull(szEntry)) Then
      szTmp = String$(nBUFSIZEINIALL, 0)
      nRet = OSGetPrivateProfileString(szSection, 0&, szDefault, szTmp, nBUFSIZEINIALL, szFileName)
   Else
      szTmp = String$(nBUFSIZEINI, 0)
      nRet = OSGetPrivateProfileString(szSection, CStr(szEntry), szDefault, szTmp, nBUFSIZEINI, szFileName)
   End If
   GetPrivateProfileString = Left$(szTmp, nRet)
End Function
Private Function GetProfileString(ByVal szSection As String, ByVal szEntry As Variant, ByVal szDefault As String) As String
   Dim szTmp As String
   Dim nRet As Long
   If (IsNull(szEntry)) Then
      szTmp = String$(nBUFSIZEINIALL, 0)
      nRet = OSGetProfileString(szSection, 0&, szDefault, szTmp, nBUFSIZEINIALL)
   Else
      szTmp = String$(nBUFSIZEINI, 0)
      nRet = OSGetProfileString(szSection, CStr(szEntry), szDefault, szTmp, nBUFSIZEINI)
   End If
   GetProfileString = Left$(szTmp, nRet)
End Function