Some VBA Examples

Visual Basic for Application Example Code,
Outlook email process automation,

example 1: del_mails demonstrates how to 
 delete email by creation date 
 prompt user to select email folder
 select folder by folder name

example 2:

Sub del_mails()
  Dim ol As New Outlook.Application
  ' access outlook information through Messaging Application Programming Interface
  Set olns = ol.GetNamespace("MAPI")
  'Set f = olns.PickFolder
  Set defaultFolders = olns.Folders("Mailbox - Your Name (QQ/EEE)")
  Set f = defaultFolders.Folders("auto_update")

Set delFolder = defaultFolders.Folders("Deleted Items")
  'MsgBox f.Name
  Sheet1.Cells(4, 4).Value = f.Name
  Set MyItems = f.Items
  MyItems.Sort "[CreationTime]", olAscending
  
  ' remember to count down idx, as there is re-sort (mail movement) invovled in the for loop
  For Each Item In f.Items
      Keywords = "CCQ-TR"
      
      s = Left(Item.Subject, Len(Keywords))
      If StrComp(s, Keywords) = 0 Then
         If CDate(Item.CreationTime) < #8/10/2005# Then
           Item.Move delFolder
         End If
      End If
  Next

'
End Sub

Sub del_attachments()
  Dim ol As New Outlook.Application
  ' access outlook infomation through Messaging Application Programming Interface
  Set olns = ol.GetNamespace("MAPI")
  Set f = olns.PickFolder
  
  Set MyItems = f.Items
'  MyItems.Sort "[Subject]", False
  
  ' remember to count down idx, as there is re-sort (mail movement) invovled in the for loop
  For Each Item In f.Items
        Set myattachments = Item.Attachments
        While myattachments.Count > 0
               myattachments.Remove 1
        Wend
        'TOFIX seems not working
        Item.Save
  Next

'
End Sub

Sub merge_two_samesubject()
  Dim ol As New Outlook.Application
  ' access outlook infomation through Messaging Application Programming Interface
  Set olns = ol.GetNamespace("MAPI")
  'Set f = olns.Folders("Garbage").Folders("g4")
  Set f = olns.PickFolder
  'Set delFolder = olns.Folders("Garbage").Folders("Deleted Items")
  Set delFolder = olns.PickFolder
  
  Set MyItems = f.Items
  MyItems.Sort "[Subject]", False
  'get same subject items
  'MsgBox " I am here"
  'MsgBox MyItems(162).Body
  i = 2
  ' remember to count down idx, as there is re-sort (mail movement) invovled in the for loop
  For idx = MyItems.Count - 1 To 1 Step -1
    'MsgBox sitem.Subject
    sa = MyItems(idx).Subject
    sb = MyItems(idx + 1).Subject
    If StrComp(sa, sb) = 0 Then
        ss = sa
        'MsgBox sa & " " & idx
        sa = MyItems(idx).Body
        sb = MyItems(idx + 1).Body
       If InStr(sa, sb) > 0 Then
        
        'Sheet1.Cells(i, 3).Value = ss
        'Sheet1.Cells(i, 8).Value = sa
        '   MyItems(idx).Display
        '  MyItems(idx + 1).Display
        MyItems(idx + 1).Move delFolder
        i = i + 1
       End If
    End If
'    If i > 10 Then Exit For
   Next

'
End Sub
Sub Macro_getfoldid()
'1
  ' early binding
  Dim ol As New Outlook.Application
  ' access outlook infomation through Messaging Application Programming Interface
  Set olns = ol.GetNamespace("MAPI")
  MsgBox olns.Folders("Garbage").Name
  For i = 2 To 5
  Set f = olns.PickFolder
  'MsgBox f.EntryID
  'MsgBox f.StoreID
  'Set objFolder = olns.GetDefaultFolder(olFolderInbox)
  'Set myFolder = olns.GetDefaultFolder(olFolderContacts)
  'Set f = olns.Folders("references")
       'MsgBox sitem.Subject
    With Sheet2
     .Cells(i, 2).Value = f.EntryID
     .Cells(i, 3).Value = f.StoreID
     '.Cells(i, 4).Value = sitem.CreationTime
     '.Cells(i, 7).Value = sitem.BodyFormat
     '.Cells(i, 8).Value = sitem.Body
    End With
  Next

'
End Sub

Sub add_subject_ifnone()
 ' late binding
  'Dim ol As Object
  'Set ol = CreateObject("Outlook.Application")
  
  ' early binding
  Dim ol As New Outlook.Application
  ' access outlook infomation through Messaging Application Programming Interface
  Set olns = ol.GetNamespace("MAPI")
  Set f = olns.Folders("Garbage").Folders("g4")

Set MyItems = f.Items
  MyItems.Sort "[Subject]", False
  'get same subject items
  'MsgBox " I am here"
  i = 2
  For Each sitem In MyItems
    'MsgBox sitem.Subject
    With Sheet1
     .Cells(i, 2).Value = sitem.SenderName
     .Cells(i, 3).Value = sitem.Subject
     .Cells(i, 4).Value = sitem.CreationTime
     '.Cells(i, 5).Value = sitem.BodyFormat
     .Cells(i, 8).Value = sitem.Body
      ss = sitem.Subject
      ss = Trim(ss)
      lenSubject = Len(ss)
      If lenSubject < 4 Then
         a = ss
         ss = Left(sitem.Body, 100)
         ss = Replace(ss, Chr(10), "")
         ss = Replace(ss, Chr(13), "")
         ss = Replace(ss, "  ", " ")
         .Cells(i, 3).Value = a & ss
         sitem.Subject = a & ss
         sitem.Save
      End If
    End With
    i = i + 1
    'If i > 20 Then Exit For
    If lenSubject >= 4 Then Exit For
  Next

'
End Sub