StartDownloadsServiceSamplesWorkshopsContact DeutschEnglish
Awarded by
Microsoft since 2005:
mvp logo
VBOffice Info
Privacy Policy
Journal: Create a new item based on an existing one
Author: Michael BauerHomepage
Date: 03.04.2007Accessed: 21497

The journal in Outlook is very good for tracking working hours. And it happens frequently that you have to create a lot of entries for the same project, all of which have always the same data - except the start time and duraton, of course.

To avoid that you always have to enter the same data (like the subject, contact data and categories) you could create a copy of an existing item with the mouse. But the disadvantage then is that every entry gets the same Creation Time, and it would be impossible to sort your journal entries chronologically.

Therefore, this sample creates a new journal item and copies all of the relevant data from a currently selected, existing item.

Simply add a button to your toolbar to start the macro - and save a lot of time daily

Public Sub CreateNewFromCurrentItem()
  Dim obj As Object
  Dim Sel As Outlook.Selection
  Dim J1 As Outlook.JournalItem
  Dim J2 As Outlook.JournalItem
  Dim Links1 As Outlook.Links
  Dim Links2 As Outlook.Links
  Dim T1 As Outlook.TaskItem
  Dim T2 As Outlook.TaskItem
  Dim i&
  Dim Link As Outlook.Link
  Dim F As Outlook.MAPIFolder

  Set Sel = Application.ActiveExplorer.Selection
  If Sel.Count Then
    Set obj = Sel(1)
    Set F = obj.Parent

    If TypeOf obj Is Outlook.JournalItem Then
      Set J1 = obj
      Set J2 = F.Items.Add(olJournalItem)

      With J1
        J2.Categories = .Categories
        J2.Companies = .Companies
        J2.ContactNames = .ContactNames
        J2.start = Now
        J2.Subject = .Subject
        J2.Type = .Type
      End With

      Set Links1 = J1.Links
      Set Links2 = J2.Links

      On Error Resume Next
      For i = 1 To Links1.Count
        Set Link = Links1(i)
        Links2.Add Link.Item


    ElseIf TypeOf obj Is Outlook.TaskItem Then
      Set T1 = obj
      Set T2 = F.Items.Add(olTaskItem)

      With T1
        T2.Categories = .Categories
        T2.Companies = .Companies
        T2.ContactNames = .ContactNames
        T2.Subject = .Subject
      End With

      Set Links1 = T1.Links
      Set Links2 = T2.Links

      On Error Resume Next
      For i = 1 To Links1.Count
        Set Link = Links1(i)
        Links2.Add Link.Item

    End If

    Set T1 = Nothing: Set T2 = Nothing
    Set J1 = Nothing: Set Links1 = Nothing
    Set J2 = Nothing: Set Links2 = Nothing
    Set obj = Nothing

  End If
End Sub

ReplyAll alerts you before unintentionally replying all, or if you are a confidential BCC recipient of the ... [more]


Access the master category list in the blink of an eye, share your categories in a network, get a reminder service, and ... [more]


SAM automatically sets the sender, signature, and folder for sent items, for instance based on the recipient ... [more]


OLKeeper reliably prevents users from closing their Outlook window and thus possibly missing reminders or ... [more]