Printable View
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
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:
Code: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
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
The following appears to work
Code: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
Quote:
Originally Posted by gmayor
Hi Graham, it works. Fantastic! Thank you.:yes
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
CRM is always a good idea. You need to hire CRM developers if you want to get a system developed considering all peculiarities of your business. This will help you to achieve the following goals: simplify routine work; analyze the results of sales department work in great detail; manage a business regardless of your current location; increase sales.