Consulting

Results 1 to 7 of 7

Thread: Update Notes field for all contacts in folder

  1. #1
    VBAX Newbie
    Joined
    Nov 2020
    Location
    Frankfurt
    Posts
    4
    Location

    Post Update Notes field for all contacts in folder

    Hello,

    I would like to create a macro that does the following:

    In a selected contact folder:

    1. Open contact form
    2. Select Notes field
    3. Insert new line with a defined text. (pop-up text box to insert text)
    4. Close contact form
    5. Loop through all the contacts in the folder

    Result: The Note field has been updated with a new text for all contacts in the folder.
    N.B. The macro "adds" a new line to the Note field. It does not replace existing text.

    Thank you

    Regards,
    Czap1

  2. #2
    The following should work. It will add the note to all items in the selected folder. I have included a macro to remove the entries if you mess up while testing. I would recommend copying a few contacts to a new folder while testing:
    Option Explicit
    'Graham Mayor - https://www.gmayor.com - Last updated - 04 Nov 2020
    
    Sub AddNote()
    Dim olFolder As Outlook.Folder
    Dim olItems As Outlook.items
    Dim olItem As Outlook.ContactItem
    Dim i As Long
    Dim strText As String
        On Error Resume Next
        strText = InputBox("Enter the text to add to all contacts' notes." & vbCr & vbCr & _
                           "Text entered is case sensitive!")
        If strText = "" Then GoTo lbl_Exit
        Set olFolder = Session.PickFolder
        Set olItems = olFolder.items
        For i = olItems.Count To 1 Step -1
            Set olItem = olItems(i)
            With olItem
                .Display
                If .Body = "" Then
                    .Body = strText
                Else
                    .Body = .Body & vbCrLf & strText
                End If
                .Save
                .Close 0
            End With
            DoEvents
        Next i
    lbl_Exit:
        MsgBox strText & vbCr & "added to all items in" & vbCr & olFolder.Name, vbInformation
        Set olFolder = Nothing
        Set olItems = Nothing
        Set olItem = Nothing
        Exit Sub
    End Sub
    
    Sub RemoveNote()
    Dim olFolder As Outlook.Folder
    Dim olItems As Outlook.items
    Dim olItem As Outlook.ContactItem
    Dim i As Long
    Dim strText As String
        On Error Resume Next
        strText = InputBox("Enter the text to Remove from all contacts' notes." & vbCr & vbCr & _
                           "Text entered is case sensitive!")
        If strText = "" Then GoTo lbl_Exit
        Set olFolder = Session.PickFolder
        Set olItems = olFolder.items
        For i = olFolder.items.Count To 1 Step -1
            Set olItem = olItems(i)
            With olItem
                .Display
                If InStr(1, .Body, vbCrLf) > 0 Then
                    .Body = Replace(.Body, vbCrLf & strText, "")
                Else
                    .Body = Replace(.Body, strText, "")
                End If
                .Save
                .Close 0
            End With
            DoEvents
        Next i
    lbl_Exit:
        MsgBox strText & "removed from" & vbCr & olFolder.Name, vbInformation
        Set olFolder = Nothing
        Set olItems = Nothing
        Set olItem = Nothing
        Exit Sub
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Newbie
    Joined
    Nov 2020
    Location
    Frankfurt
    Posts
    4
    Location
    Hello Graham, that works very well. I have two extra questions.
    1. the text should appear as a new line at the top of the Notes field, not at the bottom (if possible). The reason is I am building a Timeline with the latest input at the top.
    2. Can I have an option to change the colour of the Text

    Thanks.
    Czap

  4. #4
    The following appears to work
    Option Explicit
    'Graham Mayor - https://www.gmayor.com - Last updated - 05 Nov 2020
    
    Sub AddNote()
    Dim olFolder As Outlook.Folder
    Dim olItems As Outlook.items
    Dim olItem As Outlook.ContactItem
    Dim i As Long
    Dim strText As String
    Dim olInsp As Outlook.Inspector
    Dim wdDoc As Object
    Dim oRng As Object
    
        On Error Resume Next
        strText = InputBox("Enter the text to Add to all contacts' notes." & vbCr & vbCr & _
                           "Text entered is case sensitive!")
        If strText = "" Then GoTo lbl_Exit
        On Error GoTo 0
        Set olFolder = Session.PickFolder
        Set olItems = olFolder.items
        For i = olItems.Count To 1 Step -1
            Set olItem = olItems(i)
            With olItem
                .Display
                Set olInsp = .GetInspector
                Set wdDoc = olInsp.WordEditor
                Set oRng = wdDoc.Range
                oRng.collapse 1
                If .Body = "" Then
                    oRng.Text = strText
                Else
                    oRng.Text = strText & vbCrLf
                End If
                oRng.Font.Bold = True 'set font to bold
                oRng.Font.Color = RGB(255, 0, 0) ' set font colour to red
                .Save
                .Close 0
            End With
            DoEvents
        Next i
    lbl_Exit:
        MsgBox strText & vbCr & "added to all items in" & vbCr & olFolder.Name, vbInformation
        Set olFolder = Nothing
        Set olItems = Nothing
        Set olItem = Nothing
        Set olInsp = Nothing
        Set wdDoc = Nothing
        Set oRng = Nothing
        Exit Sub
    End Sub
    
    Sub RemoveNote()
    Dim olFolder As Outlook.Folder
    Dim olItems As Outlook.items
    Dim olItem As Outlook.ContactItem
    Dim i As Long
    Dim strText As String
        On Error Resume Next
        strText = InputBox("Enter the text to Remove from all contacts' notes." & vbCr & vbCr & _
                           "Text entered is case sensitive!")
        If strText = "" Then GoTo lbl_Exit
        On Error GoTo 0
        Set olFolder = Session.PickFolder
        Set olItems = olFolder.items
        For i = olFolder.items.Count To 1 Step -1
            Set olItem = olItems(i)
            With olItem
                .Display
                If InStr(1, .Body, vbCrLf) > 0 Then
                    .Body = Replace(.Body, strText & vbCrLf, "")
                Else
                    .Body = Replace(.Body, strText, "")
                End If
                .Save
                .Close 0
            End With
            DoEvents
        Next i
    lbl_Exit:
        MsgBox strText & "removed from" & vbCr & olFolder.Name, vbInformation
        Set olFolder = Nothing
        Set olItems = Nothing
        Set olItem = Nothing
        Exit Sub
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    VBAX Newbie
    Joined
    Nov 2020
    Location
    Frankfurt
    Posts
    4
    Location
    Quote Originally Posted by gmayor View Post
    The following appears to work
    Option Explicit
    'Graham Mayor - https://www.gmayor.com - Last updated - 05 Nov 2020
    
    Sub AddNote()
    Dim olFolder As Outlook.Folder
    Dim olItems As Outlook.items
    Dim olItem As Outlook.ContactItem
    Dim i As Long
    Dim strText As String
    Dim olInsp As Outlook.Inspector
    Dim wdDoc As Object
    Dim oRng As Object
    
        On Error Resume Next
        strText = InputBox("Enter the text to Add to all contacts' notes." & vbCr & vbCr & _
                           "Text entered is case sensitive!")
        If strText = "" Then GoTo lbl_Exit
        On Error GoTo 0
        Set olFolder = Session.PickFolder
        Set olItems = olFolder.items
        For i = olItems.Count To 1 Step -1
            Set olItem = olItems(i)
            With olItem
                .Display
                Set olInsp = .GetInspector
                Set wdDoc = olInsp.WordEditor
                Set oRng = wdDoc.Range
                oRng.collapse 1
                If .Body = "" Then
                    oRng.Text = strText
                Else
                    oRng.Text = strText & vbCrLf
                End If
                oRng.Font.Bold = True 'set font to bold
                oRng.Font.Color = RGB(255, 0, 0) ' set font colour to red
                .Save
                .Close 0
            End With
            DoEvents
        Next i
    lbl_Exit:
        MsgBox strText & vbCr & "added to all items in" & vbCr & olFolder.Name, vbInformation
        Set olFolder = Nothing
        Set olItems = Nothing
        Set olItem = Nothing
        Set olInsp = Nothing
        Set wdDoc = Nothing
        Set oRng = Nothing
        Exit Sub
    End Sub
    
    Sub RemoveNote()
    Dim olFolder As Outlook.Folder
    Dim olItems As Outlook.items
    Dim olItem As Outlook.ContactItem
    Dim i As Long
    Dim strText As String
        On Error Resume Next
        strText = InputBox("Enter the text to Remove from all contacts' notes." & vbCr & vbCr & _
                           "Text entered is case sensitive!")
        If strText = "" Then GoTo lbl_Exit
        On Error GoTo 0
        Set olFolder = Session.PickFolder
        Set olItems = olFolder.items
        For i = olFolder.items.Count To 1 Step -1
            Set olItem = olItems(i)
            With olItem
                .Display
                If InStr(1, .Body, vbCrLf) > 0 Then
                    .Body = Replace(.Body, strText & vbCrLf, "")
                Else
                    .Body = Replace(.Body, strText, "")
                End If
                .Save
                .Close 0
            End With
            DoEvents
        Next i
    lbl_Exit:
        MsgBox strText & "removed from" & vbCr & olFolder.Name, vbInformation
        Set olFolder = Nothing
        Set olItems = Nothing
        Set olItem = Nothing
        Exit Sub
    End Sub

  6. #6
    VBAX Newbie
    Joined
    Nov 2020
    Location
    Frankfurt
    Posts
    4
    Location
    Hi Graham, it works. Fantastic! Thank you.

    One thing. The remove Note macro removes the latest input but also changes the colour of all the text in the Notes field back to black. It should only remove the last input and not change the previous colours.

    I have seen how I can change the colours of the input by changing the RGB code, so that is good as well.

    I have limited experience with VBA and am always learning by asking experts and then creating building blocks for my own processes. My question here is, where do you define the "Notes" field in the macro?

    Best regards,
    Czap

  7. #7
    The concept and CRM product design documentation are complete. Now, the client understands the type of application they need and how it will improve their business. It was a fluid, productive collaboration. The https://theappsolutions.com team was a reliable, detail-oriented partner.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •