无心恋战

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Copyright: free of distribution with this notes.
'Download:http://www.dimastr.com/redemption/Redemption.zip
'Objects: "junkmailsample" in olfolderdrafts with

'  subject "junkmailsample"
'Objects: Excel file: email within F column in numerical

'  format initiated, G with header,
'Objects:   H column for Names, I for validation.
' Email sent after 1 hours at least, and 50 email sent for another hour delay
' Editor: Andrew
' Date: 20070629
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Public Sub Sending_JunkMail()

  On Error Resume Next

  Application.ScreenUpdating = False

  Dim mailaddress, rName    As String
  Dim i, k, deferedgap  As Integer
  Dim objOL 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

  k = 7 'This is the email address column No.
      ActiveSheet.Range("A1").Sort Key1:=Columns(k), Header:=1
    For i = 2 To WorksheetFunction.CountA(Columns(k)) + 1
        If ((Cells(i, k) = Cells(i + 1, k)) And (Not Cells(i, k) = "")) Then

        Rows(i + 1).Select
        Selection.Delete

        Else

        i = i + 1

        End If
     Next i

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

        If Cells(i, k + 2) = 1 Then
        Rows(i).Select
        Selection.Font.Color = RGB(255, 0, 0)

        Else

          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("junkmailsample")
          Set myItemcopy = oItem.Copy
          Set myItemcopymove = myItemcopy.Move(myOutFolder)
          SafeItem.Item = myItemcopymove
        '  Set itmNewMail = objOL.CreateItem(olMailItem)
        deferedgap = Int(i / 50)

          mailaddress = Cells(i, k)
          Cells(i, k - 1) = Cells(i, k - 1) + 1
          rName = Cells(i, k + 1)

          If rName = "" Then

          rName = "Sir or Madam"
            With SafeItem
          .To = mailaddress
          .DeferredDeliveryTime = DateAdd("h", deferedgap + 1, Now)
          .Subject = "Our latest products! Updated Quotation."
          .HTMLBody = "<DIV><BLOCKQUOTE dir=ltr style='MARGIN-RIGHT: 0px'><SPAN style='FONT-SIZE: 10pt; COLOR: navy; FONT-FAMILY: Palatino Linotype'>Dear " + rName + ",</SPAN></BLOCKQUOTE></DIV>" + .HTMLBody
          .Send

          End With

          Else
           With SafeItem
          .To = mailaddress
          .DeferredDeliveryTime = DateAdd("h", deferedgap + 1, Now)
          .Subject = "Our latest products! Updated Quotation."
          .HTMLBody = "<DIV><BLOCKQUOTE dir=ltr style='MARGIN-RIGHT: 0px'><SPAN style='FONT-SIZE: 10pt; COLOR: navy; FONT-FAMILY: Palatino Linotype'>Dear " + WorksheetFunction.Proper(rName) + ",</SPAN></BLOCKQUOTE></DIV>" + .HTMLBody
          .Send

          End With


          End If



Set Ns = objOL.GetNamespace("MAPI")
Ns.Logon
Set Sync = Ns.SyncObjects.Item(1)
Sync.Start

Set Btn = objOL.ActiveExplorer.CommandBars.FindControl(1, 7095)
Btn.Execute
Set Utils = CreateObject("Redemption.MAPIUtils")
Utils.DeliverNow

          Set objOL = Nothing
          Set itmNewMail = Nothing
          End If
    Next i

  ActiveWorkbook.Save
  Application.ScreenUpdating = True


  End Sub