无心恋战

 
 
 
  Public Sub Sending_JunkMail()
  '!!!特别注意选项邮件格式中先HTML，并且取消"使用Microsoft Office 2003 WORD编辑电子邮件"
  '======================================================================================
  '程序在WINDOWS XP+SP2 & Redepmtion(看以下介绍) & EXEL 2003 & OUTLOOK 2003
  '& Microsoft Scripting Runtime & VBscript Regular Expressions 5.5 类中调试成功
  '     下载 Redepmtion :http://www.dimastr.com/redemption/Redemption.zip
  '     Redepmtion 创建对象SafeItem替换 OUTLOOK的 MailItem, 使 SaftItem.send 方法不会引起Outlook提示 "有程序正在以你的名义发送电子邮件..."
  '自动实现1)邮件地址检查，提示错误邮件地址的数目<可关闭，MsgBox>，2)邮件重复检查，3)邮件排序,4)最近发送时间<I>，5)可屏蔽指定邮件地址<在I行加1>
  '变量 mailaddress为邮件地址,rName为邮件收件人名, mSubjrName为邮件标题, mBody为邮件正文
  '变量 e为错误数, i 为行，k 为邮件所在列, l 在提示有错误邮件地址时是否退出， m为错误邮件地址数,deferedgap为邮件分时发送的间隔参数
  '注意G列为EMAIL地址
  '注意F，J，K列为计数列，其中F列计算发送次数，J列为阻止列(0或空不阻止，其它阻止)，K列为邮件地址检查列(0或空为正确的邮件地址，其它表明EMAIL地址有问题)
  'H列提示收件人名，如果为空，默认为 Sir or Madam
  '邮件的标题由D:\EmailPool\subjectText.txt文件读取
  '邮件来源目前是从草稿箱上复制编好的模板
  '
  '======================================================================================
  '
 
 ' On Error Resume Next
 
  On Error GoTo Err_Hl '如果有错误则转到未尾"Err_Hl:"来处理错误
 
  Application.ScreenUpdating = False '关闭屏幕更新
   
  Dim mailaddress, rName, mSubj, mBody, Err_lines, m_mail As String
  Dim e, i, k, l, m, deferedgap, p, q As Integer
  Dim objOL, eobjOL As outlook.Application
  Dim myNamespace As outlook.Namespace
  Dim itmNewMail As outlook.MailItem
  Dim myFolder As outlook.MAPIFolder
  Dim myOutFolder As outlook.MAPIFolder
  Dim myItem As outlook.MailItem
  Dim myItemcopy As outlook.MailItem
 
  Dim fso  As New FileSystemObject
  'Dim ts As TextStream
  'Set ts = fso.OpenTextFile("D:\EmailPool\junkBodyText.htm", ForReading)
 

 
  Dim fso2  As New FileSystemObject
  Dim ts2 As TextStream
  Set eobjOL = Nothing
  Set ts2 = fso.OpenTextFile("D:\EmailPool\subjectText.txt", ForReading)
  e = 0
  m = 0 'The default number of invalid email address is zero
  k = 7 'This is the email address column No.
  'mBody = ts.ReadAll
  mSubj = ts2.ReadAll 'This is the email subject.

      ActiveSheet.Range("a:z").Sort Key1:=Columns(k), Header:=1
      p = WorksheetFunction.CountA(Columns(k))

    For i = 2 To p '从第二行到最后一行遍历当前邮件地址列来检查邮件地址

        If mMail(Trim(Application.WorksheetFunction.Clean(Cells(i, k))), False) = "Error" Then 'if the email address is valid
        Cells(i, k + 4) = Cells(i, k + 4) + 1
        m = m + 1
        Else
        Cells(i, k + 4) = ""
        m_mail = mMail(Trim(Application.WorksheetFunction.Clean(Cells(i, k))), False)
        End If

     Next i
    
     q = WorksheetFunction.CountA(Columns(k))
    
     For i = 2 To WorksheetFunction.CountA(Columns(k))  '从第二行到最后一行遍历当前邮件地址列来删除重复邮件地址
   
         q = WorksheetFunction.CountA(Columns(k))
        If (Cells(i + 1, k + 4) = "" And Cells(i + 1, k + 4) = "") Then ' if the email address is valid for sending junk emails?
        If ((Cells(i, k) = Cells(i + 1, k)) And (Not Cells(i, k) = "")) Then 'if the email address is duplicated
   
        Rows(i + 1).Delete

        End If
        End If

     Next i
    
        If m = 0 Then
        Else
        l = MsgBox("是否现在退出程序以便处理非法邮件地址?", vbYesNo, "有 " & m & " 个错误邮件地址!")   ' prompt for the number of invalid email addresses if any.
        If l = vbYes Then Exit Sub '如果选是，则退出
        End If
    
     For i = 2 To WorksheetFunction.CountA(Columns(k)) '从第二行到最后一行遍历当前邮件地址列发送邮件
    
        If (Cells(i, k + 3) < 1 And Cells(i, k + 4) < 1) Then '如果非阻止发送地址,且非错误地址
       
    
          Dim SafeItem, oItem, Utils, Btn, Ns, Sync, myItemcopymove '定义变量
          Set objOL = CreateObject("Outlook.Application") '创建对象
          Set SafeItem = CreateObject("Redemption.SafeMailItem") 'Create an instance of Redemption.SafeMailItem
          Set myNamespace = objOL.GetNamespace("MAPI") ' 定义命名空间
          Set myFolder = myNamespace.GetDefaultFolder(olFolderDrafts) ' 定义草稿箱
          Set myOutFolder = myNamespace.GetDefaultFolder(olFolderOutbox) '定义发件箱
          Set oItem = myFolder.Items("mailsample") '读模板邮件
          Set myItemcopy = oItem.Copy '生成模板邮件的一个附本
          Set myItemcopymove = myItemcopy.Move(myOutFolder) '拷贝邮件到发件箱
          SafeItem.Item = myItemcopymove '将待发邮件添加给REDEMPTION的SaftItem对象的Item属性
        '  Set itmNewMail = objOL.CreateItem(olMailItem) ' 新建邮件对象
          deferedgap = Int(i / 10) '每10行一个间隔
           
          mailaddress = Cells(i, k) '读邮件地址

          Cells(i, k + 2) = Now()
          Cells(i, k + 2).Font.Size = 9
          rName = Cells(i, k + 1)
         
                  If rName = "" Then rName = "Sir or Madam"
                          With SafeItem
               
                          .To = mailaddress
                          If m_mail <> "info" And m_mail <> "Error" Then
                          .BCC = m_mail
                          End If
                          .DeferredDeliveryTime = DateAdd("n", deferedgap + 1, Now)
                         
'DateAdd 的参数说明
'将一个日期加上一段期间后的日期。 I ：设定一个日期（ Date ）所加上的一段期间的单位。譬如 interval="d" 表示 N的单位为日。 I的设定值如下： 中国Web技术站 Q H {.j0Y
'yyyy Year 年
'H E8t&j A F kq Quarter 季 中国Web技术站"` q"M e F N X
'm Month 月 中国Web技术站9u1? `%q4F y9N T"Z
'd Day 日
'a 'y O {5n b Qw Weekday 星期
'"v B j m m9K x/Y2ih Hour 时
'y u m y,c d ^ ?n Minute 分
'5F ] S0L Zs Second 秒 中国Web技术站 _1V8o @"h E-P
'N ：数值表达式，设定一个日期所加上的一段期间，可为正值或负值，正值表示加（结果为 >date 以后的日期），负值表示减（结果为 >date 以前的日期）。
'} q ~ T7F"W(ID ：待加减的日期。
'例子： DateAdd （ "m" , 1 , "31-Jan-98") 中国Web技术站%x'_)S+K;o K3H }
'结果： 28-Feb-98 中国Web技术站 |0] d L l W+o4\.X d m
'说明：将日期 31-Jan-98 加上一个月，结果为 28-Feb-98 而非 31-Fe-98 。 中国Web技术站 V D9d N H x&B }'{
'例子： DateAdd （ "d" , 20 , "30-Jan-99")
'0V m f*r Y6G g结果： 1999/2/9
'y M p2W n h'~ {说明：将一个日期 30-Jan-99 加上 20 天后的日期。
                         
                          .Subject = mSubj
                          .HTMLBody = "<SPAN style='FONT-SIZE: 10 pt; COLOR: ; FONT-FAMILY: arial'>Dear " + rName + ",<br />" + .HTMLBody + " </SPAN>" '添加不指名称谓
                          .Send
                         
                          End With
                     Cells(i, k - 1) = Cells(i, k - 1) + 1 '记录发件次数
           
        End If
                 
                If (Not (eobjOL Is Nothing)) And (i = WorksheetFunction.CountA(Columns(k))) Then   ' Flush the mail pool space at the last circle

                    Set Ns = eobjOL.GetNamespace("MAPI")
                    Ns.Logon
                    Set Sync = Ns.SyncObjects.Item(1)
                    Sync.Start
                   
                    Set Btn = eobjOL.ActiveExplorer.CommandBars.FindControl(1, 7095)
                    Btn.Execute
                    If e + m > 0 Then
                        MsgBox "程序全部执行完毕.", vbInformation, "在" & Err_lines & "有 " & e & " 个错误!"  ' prompt for the number of invalid email addresses if any.
                    Else
                        MsgBox "程序全部执行完毕. 无错误!"  '
                    End If

                End If
            If Not (objOL Is Nothing) Then Set eobjOL = objOL

          Set objOL = Nothing
          Set itmNewMail = Nothing
         
      

    Next i
    If Not (i >= WorksheetFunction.CountA(Columns(k))) Then '对自身不执行错误检查/最后一次不顺序执行错误处理语句
'==错误处理开始
Err_Hl:
                        e = e + 1 '错误数加1
                        If e > 0 And i > 0 Then
                        Err_lines = Err_lines & CStr(i) & "行,"
                        Cells(i, k - 1) = "错误"
                        Resume Next       '继续执行
                        End If
'==错误处理结束
    End If
  ActiveWorkbook.Save ' 保存工作薄
  Application.ScreenUpdating = True ' 开启屏幕更新

  End Sub
  Sub DelectDulplicateLines()
'
' Macro1 Macro
' 宏由 Andrew.Mei 录制，时间: 2007-6-21
'
Dim i, j, k As Integer

'On Error GoTo ii

k = 7 'This is the email address column No.

j = 0

For i = 2 To WorksheetFunction.CountA(Columns(k))

    If ((LCase(Cells(i, k)) = LCase(Cells(i + 1, k))) And (Not Cells(i, k) = "")) Then

    Rows(i + 1).Select
    Selection.Delete
    i = i - 1

   
    End If
   
   
Next i

   
End Sub
 
Sub sortbyemail()

Dim k As Integer
k = 7 'This is the email address column No.
    ActiveSheet.Range("B1").Sort Key1:=Columns(k)
   
End Sub
Sub Send_Order_Mail()

Dim olkapp As outlook.Application
Dim newmail As MailItem

Set olkapp = CreateObject("outlook.application")

Set cnn = New ADODB.Connection
cnn.Open CurrentProject.Connection

Set rst_cusid = New ADODB.Recordset
rst_cusid.Open "select distinct CustomerID,CompanyName,Email from v_order_list", cnn, adOpenKeyset, adLockReadOnly

If rst_cusid.RecordCount < 1 Then Exit Sub

Set rst_order_list = New ADODB.Recordset

For i = 1 To rst_cusid.RecordCount

rst_order_list.Open "select * from v_order_list where CustomerID = " + "'" + rst_cusid.Fields(0) + "'", cnn, adOpenKeyset, adLockReadOnly

With rst_order_list
para = "Dear " + .Fields(1) + ":" + Chr(10)

para = para + Space(3) + "Your Company " + .Fields(0) + " has Order those Good:" + Chr(10)

For j = 1 To .RecordCount

para = para + Space(3) + "Good Name :" + .Fields(2) + " Order Date :" + CStr(.Fields(3)) + " Price:" + CStr(.Fields(4)) + Chr(10)

Next

End With

rst_order_list.Close

para = para + Space(30) + "Yours Loadhigh" 'para为信件内容

Set newmail = olkapp.CreateItem(olMailItem)

With newmail

.To = rst_cusid.Fields(2) '接收邮件的信箱
.Subject = rst_cusid.Fields(1) + " Order List" '信件标题
.Body = para
.Send '发送
End With

rst_cusid.MoveNext

para = ""
Next

rst_cusid.Close

Set rst_cusid = Nothing
Set rst_order_list = Nothing

cnn.Close

Set cnn = Nothing

End Sub

Function OkExcel(sEmail As String, Optional bDisplay As Boolean) As Integer
    '查验EMail地址
    'Ver 1.00
    '完成时间：2008.01.09
    '设计：okexcel
    '参数说明：
    'sEmail:EMail地址；bDisplay:True显示提示信息
    '返回值：True合法的Email地址,False非法的Email地址

    Dim RegEx As Object, Matches As Object
    Dim sPatrn, s As String
    sPatrn = "\w+([-+.]\w+)*@\w+([-.]\w+)*\.\w+([-.]\w+)*"
    Set RegEx = CreateObject("VBSCRIPT.REGEXP")                  'RegEx为建立正则表达式
    RegEx.Global = True                                                      '设置全局可用
    RegEx.Pattern = sPatrn                                                   '样式
    Set Matches = RegEx.Execute(Trim(sEmail)) ' 执行搜索。
    If Matches.Count <> 0 Then ' 如果找到匹配地址
        If (Matches.Count = 1 And Matches(0).FirstIndex = 0 And Matches(0).Value = Trim(sEmail)) Then
            OkExcel = 0
            'If bDisplay Then MsgBox "合法的Email地址。", vbInformation, "智能Excel www.okexcel.com.cn"
        Else
            OkExcel = 1
            'If bDisplay Then MsgBox "非法的Email地址。" & (Matches.Count) & "行." & (Matches(0).FirstIndex) & (Matches(0).Value) & (sEmail) & "|" & (Matches(0).Value = sEmail), vbExclamation, "智能Excel www.okexcel.com.cn"
        End If
    Else
    OkExcel = 1
    End If
    Set RegEx = Nothing
    Set Matches = Nothing
End Function

Function mMail(sEmail As String, Optional bDisplay As Boolean) As String
    '查验EMail地址
    'Ver 1.00
    '完成时间：2008.01.09
    '设计：okexcel
    '参数说明：
    'sEmail:EMail地址；bDisplay:True显示提示信息
    '返回值：True合法的Email地址,False非法的Email地址

    Dim RegEx, mRegEx, nRegEx As Object, Matches, mMatches, nMatches As Object
    Dim sPatrn, mPatrn, nPatrn As String
    sPatrn = "\w+([-+.]\w+)*@\w+([-.]\w+)*\.\w+([-.]\w+)*"
    mPatrn = "@\w+([-.]\w+)*\.\w+([-.]\w+)*"
    nPatrn = "\w+([-+.]\w+)*@"
   
    Set RegEx = CreateObject("VBSCRIPT.REGEXP")                  'RegEx为建立正则表达式
    RegEx.Global = True                                                      '设置全局可用
    RegEx.Pattern = sPatrn                                                   '样式
    Set Matches = RegEx.Execute(Trim(sEmail)) ' 执行搜索。
   
    If Matches.Count <> 0 Then ' 如果找到匹配地址
   
        Set nRegEx = CreateObject("VBSCRIPT.REGEXP")                  'RegEx为建立正则表达式
        nRegEx.Global = True                                                      '设置全局可用
        nRegEx.Pattern = nPatrn                                                   '样式
        Set nMatches = nRegEx.Execute(Trim(sEmail)) ' 执行搜索。
        If nMatches(0).Value <> "info@" Then
            Set mRegEx = CreateObject("VBSCRIPT.REGEXP")                  'RegEx为建立正则表达式
            mRegEx.Global = True                                                      '设置全局可用
            mRegEx.Pattern = mPatrn                                                   '样式
            Set mMatches = mRegEx.Execute(Trim(sEmail)) ' 执行搜索。
   
                If (Matches.Count = 1 And Matches(0).FirstIndex = 0 And Matches(0).Value = Trim(sEmail)) Then
                     mMail = "info" & mMatches(0).Value
                    'If bDisplay Then MsgBox "合法的Email地址。", vbInformation, "智能Excel www.okexcel.com.cn"
                Else
                    mMail = "Error" '1
                    'If bDisplay Then MsgBox "非法的Email地址。" & (Matches.Count) & "行." & (Matches(0).FirstIndex) & (Matches(0).Value) & (sEmail) & "|" & (Matches(0).Value = sEmail), vbExclamation, "智能Excel www.okexcel.com.cn"
                End If
        Else
        mMail = "info"
        End If
    Else
    mMail = "Error" '1
    End If
    Set RegEx = Nothing
    Set Matches = Nothing
End Function