Attribute VB_Name = "Module2"
Dim aObjNSMapi As NameSpace
Sub sendtoyahoo()

Dim aObjNSMapi As NameSpace
Dim aObjMapiFold ', targfolder As MAPIFolder
Dim recMail As MailItem
Dim myMail As MailItem
Dim targfldername As String
Dim header As String
Dim fs As Object
Dim TOString As String, CCString As String

'myMail.EntryID
Set aObjNSMapi = GetNamespace("MAPI")
Set aObjMapiFold = aObjNSMapi.GetDefaultFolder(olFolderInbox)
'Set targfolder = aObjMapiFold.Folders("JOHN")

'Set aObjNewMail = aObjMapiFold.items.GetFirst
Set fs = CreateObject("Scripting.FileSystemObject")
total = aObjMapiFold.items.Count

For j = total To 1 Step -1

    Set recMail = aObjMapiFold.items(j) '.GetLast 'First 'targfolder.items.GetFirst
    mlg = recMail.Mileage
    
    If mlg = 1000 Or recMail.UnRead = False Then Exit Sub
                        ' If mlg = 10000 Then Exit Sub  '  DEBUGGING PURPOSES!
    CCString = ""
    TOString = ""
    
    Set myMail = outlook.CreateItem(olMailItem)
    myMail.Display
    myMail.To = "mycbkmail@yahoo.com" 'contact.Email1Address
    myMail.Subject = "FROM: " & recMail.SenderEmailAddress & " Subject: " & recMail.Subject
    
    For Each rc In recMail.Recipients
        If rc.Type = olCC Then CCString = CCString & "; " & rc.Address
        If rc.Type = olTo Then TOString = TOString & "; " & rc.Address
    Next
    
    CCString = Mid(CCString, 3)
    TOString = Mid(TOString, 3)
    
    header1 = "FROM: " & recMail.SenderName & ", " & recMail.SenderEmailAddress
    'For Each rec In recMail.Recipients
    '    header2 = header2 & ", " & rec
    header2 = "TO: " & TOString '& recMail.To
    header3 = "CC: " & CCString '& recMail.CC
    header4 = "SUBJECT: " & recMail.Subject
    
    If recMail.BodyFormat = olFormatHTML Then
        myMail.HTMLBody = header1 & "<br>" & header2 & "<br>" & header3 & "<br>" & header4 & "<br><br>" & recMail.HTMLBody
    Else
        myMail.Body = header1 & vbCrLf & header2 & vbCrLf & header3 & vbCrLf & header4 & vbCrLf & recMail.Body
    End If
    
    If recMail.Attachments.Count <> 0 Then
        For i = 1 To recMail.Attachments.Count ' Each at In recAttachments
            tempname = "c:\temp\" & recMail.Attachments(i).filename
            recMail.Attachments(i).SaveAsFile tempname
            myMail.Attachments.Add (tempname)   'recMail.Attachments(i))
            fs.deletefile (tempname)
        Next
    End If
    
   ' Set myMail = ActiveInspector.CurrentItem
    If recMail.SenderEmailAddress <> "" Then myMail.ReplyRecipients.Add recMail.SenderEmailAddress Else myMail.ReplyRecipients.Add "johnsinit@yahoo.com"
    
    'myMail.SentOnBehalfOfName "Try One"
    'myMail.Reply = "johnsint@yahoo.com"
   'myMail.Send
    recMail.Mileage = 1000
    recMail.Save
   
Next
   
End Sub