Change the folder the contacts link to on the contact form

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

How can I programmatically change the folder links for the contacts section
of the contact form. I am using Exchange 2000 and Outlook 2002. I recently
moved the contacts in a public folder to a new folder. Now the links for the
contacts are trying to go to the old deleted folder. How can I easily change
where Outlook is trying to find the contacts.
 
I have tried to use the two scripts together but does not seem to work. I
added the Set objFolder to point to the public folder "test". Can someone
look at the code to see what needs to be changed?

Thanks,
Tommy

Sub ReconnectLinks()
Dim objApp As Application
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Dim colItems As Items
Dim objItem As Object
Dim colLinks As Links
Dim objLink As Link
Dim colContacts As Items
Dim objContact As ContactItem
Dim strFind As String
Dim intCount As Integer

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")

Set objFolder = GetFolder("Public Folders/All Public Folders/test")

' Set objFolder = objNS.PickFolder
If TypeName(objFolder) <> "Nothing" Then
Set colContacts = objNS.GetDefaultFolder(olFolderContacts).Items
Set colItems = objFolder.Items
For Each objItem In colItems

Set colLinks = objItem.Links
intCount = colLinks.Count
If intCount > 0 Then
For I = intCount To 1 Step -1
Set objLink = colLinks.Item(I)
On Error Resume Next

If objLink.Item Is Nothing Then

strFind = "[FullName] = " & AddQuotes(objLink.Name)
Set objContact = colContacts.Find(strFind)

If Not objContact Is Nothing Then
' remove the old link
colLinks.Remove I
' add the replacement link
colLinks.Add objContact
End If
End If
Next
If Not objItem.Saved Then
objItem.Save
End If
End If
Next
End If

Set objLink = Nothing
Set colLinks = Nothing
Set objItem = Nothing
Set objItems = Nothing
Set objFolder = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub

Private Function AddQuotes(MyText) As String
AddQuotes = Chr(34) & MyText & Chr(34)
End Function

Public Function GetFolder(strFolderPath As String) As MAPIFolder
' folder path needs to be something like
' "Public Folders\All Public Folders\Company\Sales"
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim I As Long
On Error Resume Next

strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For I = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(I))
If objFolder Is Nothing Then
Exit For
End If
Next
End If

Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Function
 
Which is the folder containing the moved contacts and which is the folder
containing the items whose links you want to update?

--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers



Tommy said:
I have tried to use the two scripts together but does not seem to work. I
added the Set objFolder to point to the public folder "test". Can someone
look at the code to see what needs to be changed?

Thanks,
Tommy

Sub ReconnectLinks()
Dim objApp As Application
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Dim colItems As Items
Dim objItem As Object
Dim colLinks As Links
Dim objLink As Link
Dim colContacts As Items
Dim objContact As ContactItem
Dim strFind As String
Dim intCount As Integer

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")

Set objFolder = GetFolder("Public Folders/All Public Folders/test")

' Set objFolder = objNS.PickFolder
If TypeName(objFolder) <> "Nothing" Then
Set colContacts = objNS.GetDefaultFolder(olFolderContacts).Items
Set colItems = objFolder.Items
For Each objItem In colItems

Set colLinks = objItem.Links
intCount = colLinks.Count
If intCount > 0 Then
For I = intCount To 1 Step -1
Set objLink = colLinks.Item(I)
On Error Resume Next

If objLink.Item Is Nothing Then

strFind = "[FullName] = " & AddQuotes(objLink.Name)
Set objContact = colContacts.Find(strFind)

If Not objContact Is Nothing Then
' remove the old link
colLinks.Remove I
' add the replacement link
colLinks.Add objContact
End If
End If
Next
If Not objItem.Saved Then
objItem.Save
End If
End If
Next
End If

Set objLink = Nothing
Set colLinks = Nothing
Set objItem = Nothing
Set objItems = Nothing
Set objFolder = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub

Private Function AddQuotes(MyText) As String
AddQuotes = Chr(34) & MyText & Chr(34)
End Function



Sue Mosher said:
There is no easy method. The article at
http://www.exchangeadmin.com/Articles/Index.cfm?ArticleID=22254 has a
reconnect script that should get you started. Since the contacts are in a
folder other than a user's default Contacts folder, you will have to
adapt
the script to search in that specific folder. The function at
http://www.outlookcode.com/d/code/getfolder.htm should help.


--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
Click to expand...
Click to expand...
 
Sue,

All of the contacts and the linked contacts are in one folder named "test".
I'm using a test folder until I get the script to work.

Thanks,
Tommy

Sue Mosher said:
Which is the folder containing the moved contacts and which is the folder
containing the items whose links you want to update?

--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers



Tommy said:
I have tried to use the two scripts together but does not seem to work. I
added the Set objFolder to point to the public folder "test". Can someone
look at the code to see what needs to be changed?

Thanks,
Tommy

Sub ReconnectLinks()
Dim objApp As Application
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Dim colItems As Items
Dim objItem As Object
Dim colLinks As Links
Dim objLink As Link
Dim colContacts As Items
Dim objContact As ContactItem
Dim strFind As String
Dim intCount As Integer

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")

Set objFolder = GetFolder("Public Folders/All Public Folders/test")

' Set objFolder = objNS.PickFolder
If TypeName(objFolder) <> "Nothing" Then
Set colContacts = objNS.GetDefaultFolder(olFolderContacts).Items
Set colItems = objFolder.Items
For Each objItem In colItems

Set colLinks = objItem.Links
intCount = colLinks.Count
If intCount > 0 Then
For I = intCount To 1 Step -1
Set objLink = colLinks.Item(I)
On Error Resume Next

If objLink.Item Is Nothing Then

strFind = "[FullName] = " & AddQuotes(objLink.Name)
Set objContact = colContacts.Find(strFind)

If Not objContact Is Nothing Then
' remove the old link
colLinks.Remove I
' add the replacement link
colLinks.Add objContact
End If
End If
Next
If Not objItem.Saved Then
objItem.Save
End If
End If
Next
End If

Set objLink = Nothing
Set colLinks = Nothing
Set objItem = Nothing
Set objItems = Nothing
Set objFolder = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub

Private Function AddQuotes(MyText) As String
AddQuotes = Chr(34) & MyText & Chr(34)
End Function



Sue Mosher said:
There is no easy method. The article at
http://www.exchangeadmin.com/Articles/Index.cfm?ArticleID=22254 has a
reconnect script that should get you started. Since the contacts are in a
folder other than a user's default Contacts folder, you will have to
adapt
the script to search in that specific folder. The function at
http://www.outlookcode.com/d/code/getfolder.htm should help.


--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers



How can I programmatically change the folder links for the contacts
section
of the contact form. I am using Exchange 2000 and Outlook 2002. I
recently
moved the contacts in a public folder to a new folder. Now the links
for
the
contacts are trying to go to the old deleted folder. How can I easily
change
where Outlook is trying to find the contacts.
Click to expand...
Click to expand...
Click to expand...
 
Then you need to be using that folder to set both objFolder and the folder
used for colContacts.

--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers



Tommy said:
Sue,

All of the contacts and the linked contacts are in one folder named
"test".
I'm using a test folder until I get the script to work.
Tommy said:
I have tried to use the two scripts together but does not seem to work.
I
added the Set objFolder to point to the public folder "test". Can
someone
look at the code to see what needs to be changed?

Thanks,
Tommy

Sub ReconnectLinks()
Dim objApp As Application
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Dim colItems As Items
Dim objItem As Object
Dim colLinks As Links
Dim objLink As Link
Dim colContacts As Items
Dim objContact As ContactItem
Dim strFind As String
Dim intCount As Integer

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")

Set objFolder = GetFolder("Public Folders/All Public Folders/test")

' Set objFolder = objNS.PickFolder
If TypeName(objFolder) <> "Nothing" Then
Set colContacts = objNS.GetDefaultFolder(olFolderContacts).Items
Set colItems = objFolder.Items
For Each objItem In colItems

Set colLinks = objItem.Links
intCount = colLinks.Count
If intCount > 0 Then
For I = intCount To 1 Step -1
Set objLink = colLinks.Item(I)
On Error Resume Next

If objLink.Item Is Nothing Then

strFind = "[FullName] = " & AddQuotes(objLink.Name)
Set objContact = colContacts.Find(strFind)

If Not objContact Is Nothing Then
' remove the old link
colLinks.Remove I
' add the replacement link
colLinks.Add objContact
End If
End If
Next
If Not objItem.Saved Then
objItem.Save
End If
End If
Next
End If

Set objLink = Nothing
Set colLinks = Nothing
Set objItem = Nothing
Set objItems = Nothing
Set objFolder = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub

Private Function AddQuotes(MyText) As String
AddQuotes = Chr(34) & MyText & Chr(34)
End Function



:

There is no easy method. The article at
http://www.exchangeadmin.com/Articles/Index.cfm?ArticleID=22254 has a
reconnect script that should get you started. Since the contacts are
in a
folder other than a user's default Contacts folder, you will have to
adapt
the script to search in that specific folder. The function at
http://www.outlookcode.com/d/code/getfolder.htm should help.


--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers



How can I programmatically change the folder links for the contacts
section
of the contact form. I am using Exchange 2000 and Outlook 2002. I
recently
moved the contacts in a public folder to a new folder. Now the links
for
the
contacts are trying to go to the old deleted folder. How can I
easily
change
where Outlook is trying to find the contacts.
Click to expand...
Click to expand...
Click to expand...
 
Sue,

The script worked perfectly.

Thanks,
Tommy


Sue Mosher said:
Then you need to be using that folder to set both objFolder and the folder
used for colContacts.

--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers



Tommy said:
Sue,

All of the contacts and the linked contacts are in one folder named
"test".
I'm using a test folder until I get the script to work.
I have tried to use the two scripts together but does not seem to work.
I
added the Set objFolder to point to the public folder "test". Can
someone
look at the code to see what needs to be changed?

Thanks,
Tommy

Sub ReconnectLinks()
Dim objApp As Application
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Dim colItems As Items
Dim objItem As Object
Dim colLinks As Links
Dim objLink As Link
Dim colContacts As Items
Dim objContact As ContactItem
Dim strFind As String
Dim intCount As Integer

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")

Set objFolder = GetFolder("Public Folders/All Public Folders/test")

' Set objFolder = objNS.PickFolder
If TypeName(objFolder) <> "Nothing" Then
Set colContacts = objNS.GetDefaultFolder(olFolderContacts).Items
Set colItems = objFolder.Items
For Each objItem In colItems

Set colLinks = objItem.Links
intCount = colLinks.Count
If intCount > 0 Then
For I = intCount To 1 Step -1
Set objLink = colLinks.Item(I)
On Error Resume Next

If objLink.Item Is Nothing Then

strFind = "[FullName] = " & AddQuotes(objLink.Name)
Set objContact = colContacts.Find(strFind)

If Not objContact Is Nothing Then
' remove the old link
colLinks.Remove I
' add the replacement link
colLinks.Add objContact
End If
End If
Next
If Not objItem.Saved Then
objItem.Save
End If
End If
Next
End If

Set objLink = Nothing
Set colLinks = Nothing
Set objItem = Nothing
Set objItems = Nothing
Set objFolder = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub

Private Function AddQuotes(MyText) As String
AddQuotes = Chr(34) & MyText & Chr(34)
End Function



:

There is no easy method. The article at
http://www.exchangeadmin.com/Articles/Index.cfm?ArticleID=22254 has a
reconnect script that should get you started. Since the contacts are
in a
folder other than a user's default Contacts folder, you will have to
adapt
the script to search in that specific folder. The function at
http://www.outlookcode.com/d/code/getfolder.htm should help.


--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers



How can I programmatically change the folder links for the contacts
section
of the contact form. I am using Exchange 2000 and Outlook 2002. I
recently
moved the contacts in a public folder to a new folder. Now the links
for
the
contacts are trying to go to the old deleted folder. How can I
easily
change
where Outlook is trying to find the contacts.
Click to expand...
Click to expand...
Click to expand...
 
Back
Top