Attribute VB_Name = "basExternalApps"

Sub AddToolbar2()
  Dim tlbCustomBar As CommandBar
  Dim btnNewCustom As CommandBarButton
  
  Set tlbCustomBar = Application.ActiveExplorer.CommandBars _
    .Add(Name:="Custom External Applications", Position:=msoBarTop, _
    Temporary:=True)
  
  tlbCustomBar.Visible = True
  
  Set btnNewCustom = tlbCustomBar.Controls.Add(Type:=msoControlButton)

  btnNewCustom.OnAction = "SendLetterToContact"
  btnNewCustom.Style = msoButtonIconAndCaption
  btnNewCustom.Caption = "Send Letter to Contact"

  Set btnNewCustom = tlbCustomBar.Controls.Add(Type:=msoControlButton)

  btnNewCustom.OnAction = "ImportTasksFromAccess"
  btnNewCustom.Style = msoButtonIconAndCaption
  btnNewCustom.Caption = "Import Tasks From Access"

  Set btnNewCustom = tlbCustomBar.Controls.Add(Type:=msoControlButton)

  btnNewCustom.OnAction = "SaveAsXML"
  btnNewCustom.Style = msoButtonIconAndCaption
  btnNewCustom.Caption = "Save Current Folder as XML"

End Sub

Public Function SendLetterToContact()
  Dim itmContact As Outlook.ContactItem
  Dim selContacts As Selection
  Dim objWord As Word.Application
  Dim objLetter As Word.Document
  Dim secNewArea As Word.Section
  
  Set selContacts = Application.ActiveExplorer.Selection
  
  If selContacts.Count > 0 Then
    Set objWord = New Word.Application
        
    For Each itmContact In selContacts
      Set objLetter = objWord.Documents.Add
      
      objLetter.Select
      
      objWord.Selection.InsertAfter itmContact.FullName
      objLetter.Paragraphs.Add
      
      If itmContact.CompanyName <> "" Then
        objWord.Selection.InsertAfter itmContact.CompanyName
        objLetter.Paragraphs.Add
      End If
      
      objWord.Selection.InsertAfter itmContact.BusinessAddress
      
      objWord.Selection.Paragraphs.Alignment = wdAlignParagraphRight

      With objLetter
        .Paragraphs.Add
        .Paragraphs.Add
      End With

      With objWord.Selection
        .Collapse wdCollapseEnd
        .InsertAfter "Dear " & itmContact.FullName
        .Paragraphs.Alignment = wdAlignParagraphLeft
      End With
      
      Set secNewArea = objLetter.Sections.Add(Start:=wdSectionContinuous)
      
      With secNewArea.Range
        .Paragraphs.Add
        .Paragraphs.Add
        .InsertAfter "<Insert text of letter here>"
        .Paragraphs.Add
        .Paragraphs.Add
      End With
       
      Set secNewArea = objLetter.Sections.Add(Start:=wdSectionContinuous)
      
      With secNewArea.Range
        .Paragraphs.Add
        .InsertAfter "Regards"
        .Paragraphs.Add
        .Paragraphs.Add
        .InsertAfter Application.GetNamespace("MAPI").CurrentUser
      End With
      
    Next
    objWord.Visible = True
  
  End If
End Function

Public Sub ImportTasksFromAccess()

  Dim fdrTasks As Outlook.MAPIFolder
  Dim itmTask As Outlook.TaskItem
  
  Dim rsTasks As ADODB.Recordset
  Dim conTasks As ADODB.Connection
  Dim strConnectionString As String
  
  'Set the connection string and open the connection
  Set conTasks = New ADODB.Connection
  strConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=C:\Temp\OutlookBook.mdb;" & _
                        "Persist Security Info=False"
  conTasks.Open strConnectionString
  
  'Attempt to retrieve task records from the database for the given job
  Set rsTasks = New ADODB.Recordset
  rsTasks.Open "select * from Tasks", _
    conTasks, adOpenStatic, adLockReadOnly

  Set fdrTasks = _
    Application.GetNamespace("MAPI").GetDefaultFolder(olFolderTasks)
  
  'Add Tasks
  Do While Not rsTasks.EOF
    Set itmTask = fdrTasks.Items.Add
    
    With itmTask
      'Add custom properties to the task item
      .UserProperties.Add "TaskID", olText
      
      'Populate the task properties
      .UserProperties("TaskID") = rsTasks.Fields("TaskID")
      .Subject = rsTasks.Fields("Name")
      .Body = IIf(IsNull(rsTasks.Fields("Description")), "", _
              rsTasks.Fields("Description"))
      .PercentComplete = rsTasks.Fields("PercentComplete")
      .Save
    
    End With
    
    rsTasks.MoveNext
  Loop
End Sub


Sub SaveAsXML()

  Dim fdrActive As Outlook.MAPIFolder
  Dim rsXML As ADODB.Recordset
  
  Set fdrActive = ActiveExplorer.CurrentFolder
  Set rsXML = New ADODB.Recordset
  
  Dim itmType As Object
  Dim iCol As Integer
  
  On Error Resume Next
  rsXML.AddNew
  For Each itmType In fdrActive.Items
    For iCol = 0 To itmType.ItemProperties.Count - 1
      If itmType.ItemProperties.Item(iCol).Type = olText Then
        rsXML.Fields.Append _
              itmType.ItemProperties.Item(iCol).Name, adVarChar, 5000
      End If
    Next iCol
  Next
  
  If rsXML.State = adStateClosed Then
    rsXML.Open
  End If
  
On Error GoTo NextItem

  For Each itmType In fdrActive.Items
    rsXML.AddNew
    
    For iCol = 0 To itmType.ItemProperties.Count - 1
      If itmType.ItemProperties.Item(iCol).Type = olText Then
        rsXML.Fields(itmType.ItemProperties.Item(iCol).Name).Value = _
          IIf(IsNull(itmType.ItemProperties.Item(iCol).Value), "", _
              itmType.ItemProperties.Item(iCol).Value)
      End If
    Next iCol
    rsXML.Update

NextItem:
  Next
  
  On Error GoTo 0
  rsXML.Save "c:\temp\" & fdrActive.Name & ".xml", adPersistXML
  
End Sub